Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -107,12 +107,12 @@ (vector #f (vector exn call-chain dat))) ;; return some stuff for debug if an exception happens (if (not (vector? dat)) ;; it is an error to not receive a vector (vector #f #f "remote must be called with a vector") (vector ;; return a vector + the returned data structure #t - (let ((cmd (vector-ref dat 0)) - (params (vector-ref dat 1))) + (let ((cmd (safe-vector-ref dat 0)) + (params (safe-vector-ref dat 1))) (case (if (symbol? cmd) cmd (string->symbol cmd)) ;;=============================================== @@ -229,11 +229,11 @@ (define (api:process-request dbstruct $) ;; the $ is the request vars proc (let* ((cmd ($ 'cmd)) (paramsj ($ 'params)) (params (db:string->obj paramsj transport: 'http)) ;; (rmt:json-str->dat paramsj)) (resdat (api:execute-requests dbstruct (vector cmd params))) ;; #( flag result ) - (res (vector-ref resdat 1))) + (res (safe-vector-ref resdat 1))) ;; This can be here but needs controls to ensure it doesn't run more than every 4 seconds ;; (rmt:dat->json-str ;; (if (or (string? res) ;; (list? res) Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -59,12 +59,12 @@ ;; with adequate diskspace ;; (let* ((existing-blocks (rmt:archive-get-allocations testname itempath dused)) (candidate-disks (map (lambda (block) (list - (vector-ref block 1) ;; archive-area-name - (vector-ref block 2))) ;; disk-path + (safe-vector-ref block 1) ;; archive-area-name + (safe-vector-ref block 2))) ;; disk-path existing-blocks))) (or (common:get-disk-with-most-free-space candidate-disks dused) (archive:allocate-new-archive-block testname itempath)))) ;; allocate a new archive area Index: client.scm ================================================================== --- client.scm +++ client.scm @@ -172,11 +172,11 @@ ((nmsg)(nmsg-transport:client-connect hostname port)))) (ping-res (case *transport-type* ((http)(rmt:login-no-auto-client-setup start-res run-id)) ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id))) (if logininfo - (car (vector-ref logininfo 1)) + (car (safe-vector-ref logininfo 1)) #f)))))) (if (and start-res ping-res) (begin (hash-table-set! *runremote* run-id start-res) @@ -199,16 +199,17 @@ (server:try-running run-id) (thread-sleep! 5) ;; give server a little time to start up (client:setup run-id remaining-tries: (- remaining-tries 1)) ))) (begin ;; no server registered - (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) - (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) - (if (< num-available 2) - (server:try-running run-id)) - (thread-sleep! (+ 5 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. - (client:setup run-id remaining-tries: (- remaining-tries 1))))))))) + ;; (let ((num-available (tasks:num-in-available-state (db:dbdat-get-db tdbdat) run-id))) + ;; (debug:print-info 0 "client:setup, no server registered, remaining-tries=" remaining-tries " num-available=" num-available) + ;; (if (< num-available 2) + ;; (server:try-running run-id)) + (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries) + ;; (thread-sleep! (+ 2 (random (- 20 remaining-tries)))) ;; give server a little time to start up, randomize a little to avoid start storms. + (client:setup run-id remaining-tries: (- remaining-tries 1)))))))) ;; (let ((host-info (hash-table-ref/default *runremote* run-id #f))) ;; (if host-info ;; this is a bit circular. the host-info *is* the start-res FIXME ;; (let* ((iface (http-transport:server-dat-get-iface host-info)) ;; (port (http-transport:server-dat-get-port host-info)) @@ -218,11 +219,11 @@ ;; (else #f))) ;; (ping-res (case *transport-type* ;; ((http)(rmt:login-no-auto-client-setup start-res run-id)) ;; ((nmsg)(let ((logininfo (rmt:login-no-auto-client-setup start-res run-id))) ;; (if logininfo -;; (vector-ref (vector-ref logininfo 1) 1) +;; (safe-vector-ref (safe-vector-ref logininfo 1) 1) ;; #f))) ;; (else #f)))) ;; (if ping-res ;; sucessful login? ;; (begin ;; (debug:print-info 2 "client:setup, ping is good using host-info=" host-info ", remaining-tries=" remaining-tries) Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -27,10 +27,18 @@ (define-syntax name (syntax-rules () ((name arg ...) (begin body ...))))))) (define-syntax common:handle-exceptions (syntax-rules () ((_ exn-in errstmt ...)(handle-exceptions exn-in errstmt ...)))) + +(define (safe-vector-ref vec indx) + (if vec + (vector-ref vec indx) + (begin + (debug:print 0 "vector-ref called with #f") + (print-call-chain (current-error-port)) + (exit)))) (define (debug:calc-verbosity vstr) (cond ((number? vstr) vstr) ((not (string? vstr)) 1) Index: dashboard-guimonitor.scm ================================================================== --- dashboard-guimonitor.scm +++ dashboard-guimonitor.scm @@ -40,14 +40,14 @@ (keyentries (iup:frame #:title "Keys" (apply iup:vbox (map (lambda (key) - (iup:hbox (iup:label (vector-ref key 0) #:size "60x15") ; #:expand "HORIZONTAL") + (iup:hbox (iup:label (safe-vector-ref key 0) #:size "60x15") ; #:expand "HORIZONTAL") (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj a val) - (hash-table-set! key-params (vector-ref key 0) val))))) + (hash-table-set! key-params (safe-vector-ref key 0) val))))) keys)))) (othervars (iup:frame #:title "Run Vars" (apply iup:vbox Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -237,12 +237,12 @@ (define *state-status* (vector #f #f #f)) (define (update-state-status-buttons testdat) (let* ((state (db:test-get-state testdat)) (status (db:test-get-status testdat)) (color (car (gutils:get-color-for-state-status state status)))) - ((vector-ref *state-status* 0) state color) - ((vector-ref *state-status* 1) status color))) + ((safe-vector-ref *state-status* 0) state color) + ((safe-vector-ref *state-status* 1) status color))) (define *dashboard-test-db* #t) (define *dashboard-comment-share-slot* #f) ;;====================================================================== Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -159,11 +159,11 @@ (if t-sort (cadr t-sort) 3))) (define (get-curr-sort) - (vector-ref *tests-sort-options* *tests-sort-reverse*)) + (safe-vector-ref *tests-sort-options* *tests-sort-reverse*)) (define *hide-empty-runs* #f) (define *hide-not-hide* #t) ;; toggle for hide/not hide (define *hide-not-hide-button* #f) (define *hide-not-hide-tabs* #f) @@ -173,14 +173,14 @@ (debug:setup) (define uidat #f) -(define-inline (dboard:uidat-get-keycol vec)(vector-ref vec 0)) -(define-inline (dboard:uidat-get-lftcol vec)(vector-ref vec 1)) -(define-inline (dboard:uidat-get-header vec)(vector-ref vec 2)) -(define-inline (dboard:uidat-get-runsvec vec)(vector-ref vec 3)) +(define-inline (dboard:uidat-get-keycol vec)(safe-vector-ref vec 0)) +(define-inline (dboard:uidat-get-lftcol vec)(safe-vector-ref vec 1)) +(define-inline (dboard:uidat-get-header vec)(safe-vector-ref vec 2)) +(define-inline (dboard:uidat-get-runsvec vec)(safe-vector-ref vec 3)) (if (get-environment-variable "MT_RUN_AREA_HOME")(change-directory (get-environment-variable "MT_RUN_AREA_HOME"))) (define (message-window msg) (iup:show @@ -218,12 +218,12 @@ (result '()) (maxtests 0) (states (hash-table-keys *state-ignore-hash*)) (statuses (hash-table-keys *status-ignore-hash*)) (sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) + (sort-by (safe-vector-ref sort-info 1)) + (sort-order (safe-vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname 'itempath))) ;; ;; trim runs to only those that are changing often here @@ -263,11 +263,11 @@ (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) - (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) + (let* ((btn (safe-vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "(")) (basetestname (if (null? parts) "" (car parts)))) ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) (if (hash-table-ref/default *collapsed* basetestname #f) @@ -290,12 +290,12 @@ res)) lst)) (define (collapse-rows inlst) (let* ((sort-info (get-curr-sort)) - (sort-by (vector-ref sort-info 1)) - (sort-order (vector-ref sort-info 2)) + (sort-by (safe-vector-ref sort-info 1)) + (sort-order (safe-vector-ref sort-info 2)) (bubble-type (if (member sort-order '(testname)) 'testname 'itempath)) (newlst (filter (lambda (x) (let* ((tparts (string-split x "(")) @@ -310,13 +310,13 @@ (else #t)))) inlst)) (vlst (run-item-name->vectors newlst)) (vlst2 (bubble-up vlst priority: bubble-type))) (map (lambda (x) - (if (equal? (vector-ref x 1) "") - (vector-ref x 0) - (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) + (if (equal? (safe-vector-ref x 1) "") + (safe-vector-ref x 0) + (conc (safe-vector-ref x 0) "(" (safe-vector-ref x 1) ")"))) vlst2))) (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) @@ -328,14 +328,14 @@ (if (<= rown maxn) (vector-set! allvals rown name)) ;) (set! rown (+ 1 rown))) *alltestnamelst*) (let loop ((i 0)) - (let* ((lbl (vector-ref lftcol i)) - (keyval (vector-ref keycol i)) + (let* ((lbl (safe-vector-ref lftcol i)) + (keyval (safe-vector-ref keycol i)) (oldval (iup:attribute lbl "TITLE")) - (newval (vector-ref allvals i))) + (newval (safe-vector-ref allvals i))) (if (not (equal? oldval newval)) (let ((munged-val (let ((parts (string-split newval "("))) (if (> (length parts) 1)(conc " " (car (string-split (cadr parts) ")"))) newval)))) (vector-set! keycol i newval) (iup:attribute-set! lbl "TITLE" munged-val))) @@ -345,12 +345,12 @@ ;; (define (get-itemized-tests test-dats) (let ((tnames '())) (for-each (lambda (tdat) - (let ((tname (vector-ref tdat 0)) ;; (db:test-get-testname tdat)) - (ipath (vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) + (let ((tname (safe-vector-ref tdat 0)) ;; (db:test-get-testname tdat)) + (ipath (safe-vector-ref tdat 1))) ;; (db:test-get-item-path tdat))) (if (not (equal? ipath "")) (if (and (list? tnames) (string? tname) (not (member tname tnames))) (set! tnames (append tnames (list tname))))))) @@ -367,12 +367,12 @@ (let* ((tnames '()) ;; list of names used to reserve order (tests (make-hash-table)) ;; hash of lists, used to build as we go (itemized (get-itemized-tests test-dats))) (for-each (lambda (testdat) - (let* ((tname (vector-ref testdat 0)) ;; db:test-get-testname testdat)) - (ipath (vector-ref testdat 1))) ;; db:test-get-item-path testdat))) + (let* ((tname (safe-vector-ref testdat 0)) ;; db:test-get-testname testdat)) + (ipath (safe-vector-ref testdat 1))) ;; db:test-get-item-path testdat))) ;; (seen (hash-table-ref/default tests tname #f))) (if (not (member tname tnames)) (if (or (and (eq? priority 'itempath) (not (equal? ipath ""))) (and (eq? priority 'testname) @@ -413,11 +413,11 @@ (set! *alltestnamelst* '()) ;; create a concise list of test names (for-each (lambda (rundat) (if (vector? rundat) - (let* ((testdat (vector-ref rundat 1)) + (let* ((testdat (safe-vector-ref rundat 1)) (testnames (map test:test-get-fullname testdat))) (if (not (and *hide-empty-runs* (null? testnames))) (for-each (lambda (testname) (if (not (member testname *alltestnamelst*)) @@ -435,32 +435,32 @@ (for-each (lambda (rundat) (if (not rundat) ;; handle padded runs ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) - (let* ((run (vector-ref rundat 0)) - (testsdat (vector-ref rundat 1)) - (key-val-dat (vector-ref rundat 2)) + (let* ((run (safe-vector-ref rundat 0)) + (testsdat (safe-vector-ref rundat 1)) + (key-val-dat (safe-vector-ref rundat 2)) (run-id (db:get-value-by-header run *header* "id")) (key-vals (append key-val-dat (list (let ((x (db:get-value-by-header run *header* "runname"))) (if x x ""))))) (run-key (string-intersperse key-vals "\n"))) ;; fill in the run header key values (let ((rown 0) - (headercol (vector-ref tableheader coln))) + (headercol (safe-vector-ref tableheader coln))) (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) + (let* ((labl (safe-vector-ref headercol rown))) (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (iup:attribute-set! (safe-vector-ref headercol rown) "TITLE" kval)) (set! rown (+ rown 1)))) key-vals)) ;; For this run now fill in the buttons for each test (let ((rown 0) - (columndat (vector-ref table coln))) + (columndat (safe-vector-ref table coln))) (for-each (lambda (testname) (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) (if buttondat (let* ((test (let ((matching (filter @@ -481,14 +481,14 @@ ((and (equal? teststate "NOT_STARTED") (member teststatus '("ZERO_ITEMS" "BLOCKED" "PREQ_FAIL" "PREQ_DISCARDED" "TIMED_OUT" "KEEP_TRYING" "TEN_STRIKES"))) teststatus) (else teststate))) - (button (vector-ref columndat rown)) + (button (safe-vector-ref columndat rown)) (color (car (gutils:get-color-for-state-status teststate teststatus))) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (curr-color (safe-vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (safe-vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) (if (not (equal? curr-color color)) (iup:attribute-set! button "BGCOLOR" color)) (if (not (equal? curr-title buttontxt)) (iup:attribute-set! button "TITLE" buttontxt)) (vector-set! buttondat 0 run-id) @@ -573,12 +573,12 @@ newval)))))) (define (dashboard:update-target-selector key-lbs #!key (action-proc #f)) (let* ((runconf-targs (common:get-runconfig-targets)) (db-target-dat (db:get-targets *dbstruct-local*)) - (header (vector-ref db-target-dat 0)) - (db-targets (vector-ref db-target-dat 1)) + (header (safe-vector-ref db-target-dat 0)) + (db-targets (safe-vector-ref db-target-dat 1)) (all-targets (append db-targets (map (lambda (x) (list->vector (take (append (string-split x "/") (make-list (length header) "na")) @@ -805,12 +805,12 @@ (dboard:data-set-run-name! *data* val) (dashboard:update-run-command)))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) (runs-for-targ (db:get-runs-by-patt *dbstruct-local* *keys* "%" target #f #f)) - (runs-header (vector-ref runs-for-targ 0)) - (runs-dat (vector-ref runs-for-targ 1)) + (runs-header (safe-vector-ref runs-for-targ 0)) + (runs-dat (safe-vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) (iup:attribute-set! lb "REMOVEITEM" "ALL") @@ -1049,11 +1049,11 @@ (test-id (hash-table-ref/default cell-lookup key -1)) (cmd (conc toolpath " -test " (dboard:data-get-curr-run-id *data*) "," test-id "&"))) (system cmd))))) (updater (lambda () (let* ((runs-dat (db:get-runs-by-patt db *keys* "%" #f #f #f)) - (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records + (runs-header (safe-vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:data-get-curr-run-id *data*)) (tests-dat (let ((tdat (db:get-tests-for-run db run-id (hash-table-ref/default *searchpatts* "test-name" "%/%") (hash-table-keys *state-ignore-hash*) ;; '() (hash-table-keys *status-ignore-hash*) ;; '() @@ -1060,12 +1060,12 @@ #f #f *hide-not-hide* #f #f "id,testname,item_path,state,status"))) ;; get 'em all (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) + (let* ((aval (safe-vector-ref a 2)) + (bval (safe-vector-ref b 2)) (anum (string->number aval)) (bnum (string->number bval))) (if (and anum bnum) (< anum bnum) (string<= aval bval))))))) @@ -1080,11 +1080,11 @@ (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) - (vector-ref runs-dat 1)) + (safe-vector-ref runs-dat 1)) ht)) (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)) @@ -1222,11 +1222,11 @@ (mark-for-update) ;; (set! *tests-sort-reverse* *tests-sort-reverse*0) lb) ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) - ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) + ;; (iup:attribute-set! obj "TITLE" (safe-vector-ref (safe-vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) ;; (mark-for-update))) (iup:button "HideEmpty" #:action (lambda (obj) (set! *hide-empty-runs* (not *hide-empty-runs*)) (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+HideE" "-HideE")) (mark-for-update))) @@ -1378,12 +1378,12 @@ #:expand "HORIZONTAL" #:fontsize "10" #:action (lambda (x) (let* ((toolpath (car (argv))) (buttndat (hash-table-ref *buttondat* button-key)) - (test-id (db:test-get-id (vector-ref buttndat 3))) - (run-id (db:test-get-run_id (vector-ref buttndat 3))) + (test-id (db:test-get-id (safe-vector-ref buttndat 3))) + (run-id (db:test-get-run_id (safe-vector-ref buttndat 3))) (cmd (conc toolpath " -test " run-id "," test-id "&"))) ;(print "Launching " cmd) (system cmd)))))) (hash-table-set! *buttondat* button-key (vector 0 "100 100 100" button-key #f #f)) (vector-set! testvec testnum butn) Index: datashare.scm ================================================================== --- datashare.scm +++ datashare.scm @@ -76,25 +76,25 @@ ;;====================================================================== ;; make-vector-record "testing" datastore pkg id area version_name store_type copied source_path iteration submitter datetime storegrp datavol quality disk_id comment ;; testing (define (make-datashare:pkg)(make-vector 15)) -(define-inline (datashare:pkg-get-id vec) (vector-ref vec 0)) -(define-inline (datashare:pkg-get-area vec) (vector-ref vec 1)) -(define-inline (datashare:pkg-get-version_name vec) (vector-ref vec 2)) -(define-inline (datashare:pkg-get-store_type vec) (vector-ref vec 3)) -(define-inline (datashare:pkg-get-copied vec) (vector-ref vec 4)) -(define-inline (datashare:pkg-get-source_path vec) (vector-ref vec 5)) -(define-inline (datashare:pkg-get-iteration vec) (vector-ref vec 6)) -(define-inline (datashare:pkg-get-submitter vec) (vector-ref vec 7)) -(define-inline (datashare:pkg-get-datetime vec) (vector-ref vec 8)) -(define-inline (datashare:pkg-get-storegrp vec) (vector-ref vec 9)) -(define-inline (datashare:pkg-get-datavol vec) (vector-ref vec 10)) -(define-inline (datashare:pkg-get-quality vec) (vector-ref vec 11)) -(define-inline (datashare:pkg-get-disk_id vec) (vector-ref vec 12)) -(define-inline (datashare:pkg-get-comment vec) (vector-ref vec 13)) -(define-inline (datashare:pkg-get-stored_path vec) (vector-ref vec 14)) +(define-inline (datashare:pkg-get-id vec) (safe-vector-ref vec 0)) +(define-inline (datashare:pkg-get-area vec) (safe-vector-ref vec 1)) +(define-inline (datashare:pkg-get-version_name vec) (safe-vector-ref vec 2)) +(define-inline (datashare:pkg-get-store_type vec) (safe-vector-ref vec 3)) +(define-inline (datashare:pkg-get-copied vec) (safe-vector-ref vec 4)) +(define-inline (datashare:pkg-get-source_path vec) (safe-vector-ref vec 5)) +(define-inline (datashare:pkg-get-iteration vec) (safe-vector-ref vec 6)) +(define-inline (datashare:pkg-get-submitter vec) (safe-vector-ref vec 7)) +(define-inline (datashare:pkg-get-datetime vec) (safe-vector-ref vec 8)) +(define-inline (datashare:pkg-get-storegrp vec) (safe-vector-ref vec 9)) +(define-inline (datashare:pkg-get-datavol vec) (safe-vector-ref vec 10)) +(define-inline (datashare:pkg-get-quality vec) (safe-vector-ref vec 11)) +(define-inline (datashare:pkg-get-disk_id vec) (safe-vector-ref vec 12)) +(define-inline (datashare:pkg-get-comment vec) (safe-vector-ref vec 13)) +(define-inline (datashare:pkg-get-stored_path vec) (safe-vector-ref vec 14)) (define-inline (datashare:pkg-set-id! vec val)(vector-set! vec 0 val)) (define-inline (datashare:pkg-set-area! vec val)(vector-set! vec 1 val)) (define-inline (datashare:pkg-set-version_name! vec val)(vector-set! vec 2 val)) (define-inline (datashare:pkg-set-store_type! vec val)(vector-set! vec 3 val)) (define-inline (datashare:pkg-set-copied! vec val)(vector-set! vec 4 val)) @@ -774,16 +774,16 @@ ;; (print "area-name=" area-name " args=" args " *args-hash*=" (hash-table->alist *args-hash*)) (map (lambda (x) (if (args:get-arg "-full") (format #t "~10a~10a~4a~27a~30a\n" - (vector-ref x 0) - (vector-ref x 1) - (vector-ref x 2) - (conc "\"" (time->string (seconds->local-time (vector-ref x 3))) "\"") - (conc "\"" (vector-ref x 4) "\"")) - (print (vector-ref x 0)))) + (safe-vector-ref x 0) + (safe-vector-ref x 1) + (safe-vector-ref x 2) + (conc "\"" (time->string (seconds->local-time (safe-vector-ref x 3))) "\"") + (conc "\"" (safe-vector-ref x 4) "\"")) + (print (safe-vector-ref x 0)))) versions) (sqlite3:finalize! db))))) ;; ease debugging by loading ~/.dashboardrc - REMOVE FROM PRODUCTION! (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.datasharerc"))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -118,11 +118,11 @@ ;;====================================================================== ;; K E E P F I L E D B I N dbstruct ;;====================================================================== ;; (define (db:get-filedb dbstruct run-id) -;; (let ((db (vector-ref dbstruct 2))) +;; (let ((db (safe-vector-ref dbstruct 2))) ;; (if db ;; db ;; (let ((fdb (filedb:open-db (conc *toplevel* "/db/files.db")))) ;; (vector-set! dbstruct 2 fdb) ;; fdb)))) @@ -573,16 +573,16 @@ (sqlite3:with-transaction db (lambda () (for-each ;; (lambda (fromrow) - (let* ((a (vector-ref fromrow 0)) + (let* ((a (safe-vector-ref fromrow 0)) (curr (hash-table-ref/default todat a #f)) (same #t)) (let loop ((i 0)) (if (or (not curr) - (not (equal? (vector-ref fromrow i)(vector-ref curr i)))) + (not (equal? (safe-vector-ref fromrow i)(safe-vector-ref curr i)))) (set! same #f)) (if (and same (< i (- num-fields 1))) (loop (+ i 1)))) (if (not same) @@ -635,12 +635,12 @@ ;; kill servers (if (member 'killservers options) (for-each (lambda (server) - (tasks:server-delete-record (db:delay-if-busy tdbdat) (vector-ref server 0) "dbmigration") - (tasks:kill-server (vector-ref server 2)(vector-ref server 1))) + (tasks:server-delete-record (db:delay-if-busy tdbdat) (safe-vector-ref server 0) "dbmigration") + (tasks:kill-server (safe-vector-ref server 2)(safe-vector-ref server 1))) servers)) ;; clear out junk records ;; (if (member 'dejunk options) @@ -1359,17 +1359,17 @@ (if (null? header) #f (let loop ((hed (car header)) (tal (cdr header)) (n 0)) (if (equal? hed field) - (vector-ref row n) + (safe-vector-ref row n) (if (null? tal) #f (loop (car tal)(cdr tal)(+ n 1))))))) ;; Accessors for the header/data structure ;; get rows and header from -(define (db:get-header vec)(vector-ref vec 0)) -(define (db:get-rows vec)(vector-ref vec 1)) +(define (db:get-header vec)(safe-vector-ref vec 0)) +(define (db:get-rows vec)(safe-vector-ref vec 1)) ;;====================================================================== ;; R U N S ;;====================================================================== @@ -1934,17 +1934,17 @@ (else res))))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment - (vector (vector-ref inrec 0) ;; id - (vector-ref inrec 1) ;; run_id - (vector-ref inrec 2) ;; testname - (vector-ref inrec 4) ;; state - (vector-ref inrec 5) ;; status + (vector (safe-vector-ref inrec 0) ;; id + (safe-vector-ref inrec 1) ;; run_id + (safe-vector-ref inrec 2) ;; testname + (safe-vector-ref inrec 4) ;; state + (safe-vector-ref inrec 5) ;; status -1 "" -1 -1 "" "-" - (vector-ref inrec 3) ;; item-path + (safe-vector-ref inrec 3) ;; item-path -1 "-" "-")) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (let* ((res '()) @@ -2278,11 +2278,11 @@ (define (db:prep-megatest.db-adj-test-ids mtdb run-id testrecs) (debug:print-info 0 "Adjusting test ids in megatest.db for run " run-id) (let ((min-test-id (* run-id 30000))) (for-each (lambda (testrec) - (let* ((test-id (vector-ref testrec (db:field->number "id" db:test-record-fields)))) + (let* ((test-id (safe-vector-ref testrec (db:field->number "id" db:test-record-fields)))) (db:adj-test-id (db:dbdat-get-db mtdb) min-test-id test-id))) testrecs))) ;; 1. move test ids into the 30k * run_id range ;; 2. move step ids into the 30k * run_id range @@ -2752,12 +2752,12 @@ ;; (define (db:get-matching-previous-test-run-records dbstruct run-id test-name item-path) (let* ((dbdat (db:get-db dbstruct #f)) (db (db:dbdat-get-db dbdat)) (keys (db:get-keys db)) - (selstr (string-intersperse (map (lambda (x)(vector-ref x 0)) keys) ",")) - (qrystr (string-intersperse (map (lambda (x)(conc (vector-ref x 0) "=?")) keys) " AND ")) + (selstr (string-intersperse (map (lambda (x)(safe-vector-ref x 0)) keys) ",")) + (qrystr (string-intersperse (map (lambda (x)(conc (safe-vector-ref x 0) "=?")) keys) " AND ")) (keyvals #f) (tests-hash (make-hash-table))) ;; first look up the key values from the run selected by run-id (db:delay-if-busy dbdat) (sqlite3:for-each-row @@ -3058,16 +3058,16 @@ (keyvals (let loop ((i 0) (res '())) (if (>= i numkeys) res (loop (+ i 1) - (append res (list (vector-ref vb (+ i 2)))))))) - (runname (vector-ref vb 1)) - (testname (vector-ref vb (+ 2 numkeys))) - (item-path (vector-ref vb (+ 3 numkeys))) - (final-log (vector-ref vb (+ 7 numkeys))) - (run-dir (vector-ref vb (+ 18 numkeys))) + (append res (list (safe-vector-ref vb (+ i 2)))))))) + (runname (safe-vector-ref vb 1)) + (testname (safe-vector-ref vb (+ 2 numkeys))) + (item-path (safe-vector-ref vb (+ 3 numkeys))) + (final-log (safe-vector-ref vb (+ 7 numkeys))) + (run-dir (safe-vector-ref vb (+ 18 numkeys))) (log-fpath (conc run-dir "/" final-log))) ;; (string-intersperse keyvals "/") "/" testname "/" item-path "/" (debug:print 4 "log: " log-fpath " exists: " (file-exists? log-fpath)) (vector-set! vb (+ 7 numkeys) (if (file-exists? log-fpath) (let ((newpath (conc pathmod "/" (string-intersperse keyvals "/") Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -13,26 +13,26 @@ ;; ;; ;; Accessors for a dbstruct ;; -(define-inline (dbr:dbstruct-get-main vec) (vector-ref vec 0)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-strdb vec) (vector-ref vec 1)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-path vec) (vector-ref vec 2)) -(define-inline (dbr:dbstruct-get-local vec) (vector-ref vec 3)) -(define-inline (dbr:dbstruct-get-rundb vec) (vector-ref vec 4)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-inmem vec) (vector-ref vec 5)) ;; ( db #f ) -(define-inline (dbr:dbstruct-get-mtime vec) (vector-ref vec 6)) -(define-inline (dbr:dbstruct-get-rtime vec) (vector-ref vec 7)) -(define-inline (dbr:dbstruct-get-stime vec) (vector-ref vec 8)) -(define-inline (dbr:dbstruct-get-inuse vec) (vector-ref vec 9)) -(define-inline (dbr:dbstruct-get-refdb vec) (vector-ref vec 10)) ;; ( db path ) -(define-inline (dbr:dbstruct-get-locdbs vec) (vector-ref vec 11)) -(define-inline (dbr:dbstruct-get-olddb vec) (vector-ref vec 12)) ;; ( db path ) -;; (define-inline (dbr:dbstruct-get-main-path vec) (vector-ref vec 13)) -;; (define-inline (dbr:dbstruct-get-rundb-path vec) (vector-ref vec 14)) -;; (define-inline (dbr:dbstruct-get-run-id vec) (vector-ref vec 13)) +(define-inline (dbr:dbstruct-get-main vec) (safe-vector-ref vec 0)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-strdb vec) (safe-vector-ref vec 1)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-path vec) (safe-vector-ref vec 2)) +(define-inline (dbr:dbstruct-get-local vec) (safe-vector-ref vec 3)) +(define-inline (dbr:dbstruct-get-rundb vec) (safe-vector-ref vec 4)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-inmem vec) (safe-vector-ref vec 5)) ;; ( db #f ) +(define-inline (dbr:dbstruct-get-mtime vec) (safe-vector-ref vec 6)) +(define-inline (dbr:dbstruct-get-rtime vec) (safe-vector-ref vec 7)) +(define-inline (dbr:dbstruct-get-stime vec) (safe-vector-ref vec 8)) +(define-inline (dbr:dbstruct-get-inuse vec) (safe-vector-ref vec 9)) +(define-inline (dbr:dbstruct-get-refdb vec) (safe-vector-ref vec 10)) ;; ( db path ) +(define-inline (dbr:dbstruct-get-locdbs vec) (safe-vector-ref vec 11)) +(define-inline (dbr:dbstruct-get-olddb vec) (safe-vector-ref vec 12)) ;; ( db path ) +;; (define-inline (dbr:dbstruct-get-main-path vec) (safe-vector-ref vec 13)) +;; (define-inline (dbr:dbstruct-get-rundb-path vec) (safe-vector-ref vec 14)) +;; (define-inline (dbr:dbstruct-get-run-id vec) (safe-vector-ref vec 13)) (define-inline (dbr:dbstruct-set-main! vec val)(vector-set! vec 0 val)) (define-inline (dbr:dbstruct-set-strdb! vec val)(vector-set! vec 1 val)) (define-inline (dbr:dbstruct-set-path! vec val)(vector-set! vec 2 val)) (define-inline (dbr:dbstruct-set-local! vec val)(vector-set! vec 3 val)) @@ -65,34 +65,34 @@ (define (dbr:dbstruct-set-localdb! v run-id db) (hash-table-set! (dbr:dbstruct-get-locdbs v) run-id db)) (define (make-db:test)(make-vector 20)) -(define-inline (db:test-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-get-run_id vec) (vector-ref vec 1)) -(define-inline (db:test-get-testname vec) (vector-ref vec 2)) -(define-inline (db:test-get-state vec) (vector-ref vec 3)) -(define-inline (db:test-get-status vec) (vector-ref vec 4)) -(define-inline (db:test-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:test-get-host vec) (vector-ref vec 6)) -(define-inline (db:test-get-cpuload vec) (vector-ref vec 7)) -(define-inline (db:test-get-diskfree vec) (vector-ref vec 8)) -(define-inline (db:test-get-uname vec) (vector-ref vec 9)) -;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (vector-ref vec 10))) -(define-inline (db:test-get-rundir vec) (vector-ref vec 10)) -(define-inline (db:test-get-item-path vec) (vector-ref vec 11)) -(define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) -(define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) -(define-inline (db:test-get-comment vec) (vector-ref vec 14)) -(define-inline (db:test-get-process_id vec) (vector-ref vec 16)) -;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) -;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) +(define-inline (db:test-get-id vec) (safe-vector-ref vec 0)) +(define-inline (db:test-get-run_id vec) (safe-vector-ref vec 1)) +(define-inline (db:test-get-testname vec) (safe-vector-ref vec 2)) +(define-inline (db:test-get-state vec) (safe-vector-ref vec 3)) +(define-inline (db:test-get-status vec) (safe-vector-ref vec 4)) +(define-inline (db:test-get-event_time vec) (safe-vector-ref vec 5)) +(define-inline (db:test-get-host vec) (safe-vector-ref vec 6)) +(define-inline (db:test-get-cpuload vec) (safe-vector-ref vec 7)) +(define-inline (db:test-get-diskfree vec) (safe-vector-ref vec 8)) +(define-inline (db:test-get-uname vec) (safe-vector-ref vec 9)) +;; (define-inline (db:test-get-rundir vec) (sdb:qry 'getstr (safe-vector-ref vec 10))) +(define-inline (db:test-get-rundir vec) (safe-vector-ref vec 10)) +(define-inline (db:test-get-item-path vec) (safe-vector-ref vec 11)) +(define-inline (db:test-get-run_duration vec) (safe-vector-ref vec 12)) +(define-inline (db:test-get-final_logf vec) (safe-vector-ref vec 13)) +(define-inline (db:test-get-comment vec) (safe-vector-ref vec 14)) +(define-inline (db:test-get-process_id vec) (safe-vector-ref vec 16)) +;; (define-inline (db:test-get-pass_count vec) (safe-vector-ref vec 15)) +;; (define-inline (db:test-get-fail_count vec) (safe-vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) -(define-inline (db:test-get-first_err vec) (printable (vector-ref vec 15))) -(define-inline (db:test-get-first_warn vec) (printable (vector-ref vec 16))) +(define-inline (db:test-get-first_err vec) (printable (safe-vector-ref vec 15))) +(define-inline (db:test-get-first_warn vec) (printable (safe-vector-ref vec 16))) (define-inline (db:test-set-cpuload! vec val)(vector-set! vec 7 val)) (define-inline (db:test-set-diskfree! vec val)(vector-set! vec 8 val)) (define-inline (db:test-set-testname! vec val)(vector-set! vec 2 val)) (define-inline (db:test-set-state! vec val)(vector-set! vec 3 val)) @@ -109,30 +109,30 @@ (equal? (db:test-get-uname vec) "n/a"))) ;; test has never been run ;; make-vector-record "" db mintest id run_id testname state status event_time item_path ;; (define (make-db:mintest)(make-vector 7)) -(define-inline (db:mintest-get-id vec) (vector-ref vec 0)) -(define-inline (db:mintest-get-run_id vec) (vector-ref vec 1)) -(define-inline (db:mintest-get-testname vec) (vector-ref vec 2)) -(define-inline (db:mintest-get-state vec) (vector-ref vec 3)) -(define-inline (db:mintest-get-status vec) (vector-ref vec 4)) -(define-inline (db:mintest-get-event_time vec) (vector-ref vec 5)) -(define-inline (db:mintest-get-item_path vec) (vector-ref vec 6)) +(define-inline (db:mintest-get-id vec) (safe-vector-ref vec 0)) +(define-inline (db:mintest-get-run_id vec) (safe-vector-ref vec 1)) +(define-inline (db:mintest-get-testname vec) (safe-vector-ref vec 2)) +(define-inline (db:mintest-get-state vec) (safe-vector-ref vec 3)) +(define-inline (db:mintest-get-status vec) (safe-vector-ref vec 4)) +(define-inline (db:mintest-get-event_time vec) (safe-vector-ref vec 5)) +(define-inline (db:mintest-get-item_path vec) (safe-vector-ref vec 6)) ;; make-vector-record db testmeta id testname author owner description reviewed iterated avg_runtime avg_disk (define (make-db:testmeta)(make-vector 10 "")) -(define-inline (db:testmeta-get-id vec) (vector-ref vec 0)) -(define-inline (db:testmeta-get-testname vec) (vector-ref vec 1)) -(define-inline (db:testmeta-get-author vec) (vector-ref vec 2)) -(define-inline (db:testmeta-get-owner vec) (vector-ref vec 3)) -(define-inline (db:testmeta-get-description vec) (vector-ref vec 4)) -(define-inline (db:testmeta-get-reviewed vec) (vector-ref vec 5)) -(define-inline (db:testmeta-get-iterated vec) (vector-ref vec 6)) -(define-inline (db:testmeta-get-avg_runtime vec) (vector-ref vec 7)) -(define-inline (db:testmeta-get-avg_disk vec) (vector-ref vec 8)) -(define-inline (db:testmeta-get-tags vec) (vector-ref vec 9)) +(define-inline (db:testmeta-get-id vec) (safe-vector-ref vec 0)) +(define-inline (db:testmeta-get-testname vec) (safe-vector-ref vec 1)) +(define-inline (db:testmeta-get-author vec) (safe-vector-ref vec 2)) +(define-inline (db:testmeta-get-owner vec) (safe-vector-ref vec 3)) +(define-inline (db:testmeta-get-description vec) (safe-vector-ref vec 4)) +(define-inline (db:testmeta-get-reviewed vec) (safe-vector-ref vec 5)) +(define-inline (db:testmeta-get-iterated vec) (safe-vector-ref vec 6)) +(define-inline (db:testmeta-get-avg_runtime vec) (safe-vector-ref vec 7)) +(define-inline (db:testmeta-get-avg_disk vec) (safe-vector-ref vec 8)) +(define-inline (db:testmeta-get-tags vec) (safe-vector-ref vec 9)) (define-inline (db:testmeta-set-id! vec val)(vector-set! vec 0 val)) (define-inline (db:testmeta-set-testname! vec val)(vector-set! vec 1 val)) (define-inline (db:testmeta-set-author! vec val)(vector-set! vec 2 val)) (define-inline (db:testmeta-set-owner! vec val)(vector-set! vec 3 val)) (define-inline (db:testmeta-set-description! vec val)(vector-set! vec 4 val)) @@ -143,21 +143,21 @@ ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (make-db:test-data)(make-vector 10)) -(define-inline (db:test-data-get-id vec) (vector-ref vec 0)) -(define-inline (db:test-data-get-test_id vec) (vector-ref vec 1)) -(define-inline (db:test-data-get-category vec) (vector-ref vec 2)) -(define-inline (db:test-data-get-variable vec) (vector-ref vec 3)) -(define-inline (db:test-data-get-value vec) (vector-ref vec 4)) -(define-inline (db:test-data-get-expected vec) (vector-ref vec 5)) -(define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) -(define-inline (db:test-data-get-units vec) (vector-ref vec 7)) -(define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) -(define-inline (db:test-data-get-status vec) (vector-ref vec 9)) -(define-inline (db:test-data-get-type vec) (vector-ref vec 10)) +(define-inline (db:test-data-get-id vec) (safe-vector-ref vec 0)) +(define-inline (db:test-data-get-test_id vec) (safe-vector-ref vec 1)) +(define-inline (db:test-data-get-category vec) (safe-vector-ref vec 2)) +(define-inline (db:test-data-get-variable vec) (safe-vector-ref vec 3)) +(define-inline (db:test-data-get-value vec) (safe-vector-ref vec 4)) +(define-inline (db:test-data-get-expected vec) (safe-vector-ref vec 5)) +(define-inline (db:test-data-get-tol vec) (safe-vector-ref vec 6)) +(define-inline (db:test-data-get-units vec) (safe-vector-ref vec 7)) +(define-inline (db:test-data-get-comment vec) (safe-vector-ref vec 8)) +(define-inline (db:test-data-get-status vec) (safe-vector-ref vec 9)) +(define-inline (db:test-data-get-type vec) (safe-vector-ref vec 10)) (define-inline (db:test-data-set-id! vec val)(vector-set! vec 0 val)) (define-inline (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (db:test-data-set-category! vec val)(vector-set! vec 2 val)) (define-inline (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) @@ -173,17 +173,17 @@ ;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time (define (make-db:step)(make-vector 7)) -(define-inline (tdb:step-get-id vec) (vector-ref vec 0)) -(define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) -(define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) -(define-inline (tdb:step-get-state vec) (vector-ref vec 3)) -(define-inline (tdb:step-get-status vec) (vector-ref vec 4)) -(define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) -(define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) +(define-inline (tdb:step-get-id vec) (safe-vector-ref vec 0)) +(define-inline (tdb:step-get-test_id vec) (safe-vector-ref vec 1)) +(define-inline (tdb:step-get-stepname vec) (safe-vector-ref vec 2)) +(define-inline (tdb:step-get-state vec) (safe-vector-ref vec 3)) +(define-inline (tdb:step-get-status vec) (safe-vector-ref vec 4)) +(define-inline (tdb:step-get-event_time vec) (safe-vector-ref vec 5)) +(define-inline (tdb:step-get-logfile vec) (safe-vector-ref vec 6)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) @@ -191,30 +191,30 @@ (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) -(define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) -(define-inline (tdb:steps-table-get-start vec) (vector-ref vec 1)) -(define-inline (tdb:steps-table-get-end vec) (vector-ref vec 2)) -(define-inline (tdb:steps-table-get-status vec) (vector-ref vec 3)) -(define-inline (tdb:steps-table-get-runtime vec) (vector-ref vec 4)) +(define-inline (tdb:steps-table-get-stepname vec) (safe-vector-ref vec 0)) +(define-inline (tdb:steps-table-get-start vec) (safe-vector-ref vec 1)) +(define-inline (tdb:steps-table-get-end vec) (safe-vector-ref vec 2)) +(define-inline (tdb:steps-table-get-status vec) (safe-vector-ref vec 3)) +(define-inline (tdb:steps-table-get-runtime vec) (safe-vector-ref vec 4)) (define-inline (tdb:step-stable-set-stepname! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-stable-set-start! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-stable-set-end! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-stable-set-status! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-stable-set-runtime! vec val)(vector-set! vec 4 val)) ;; The data structure for handing off requests via wire (define (make-cdb:packet)(make-vector 6)) -(define-inline (cdb:packet-get-client-sig vec) (vector-ref vec 0)) -(define-inline (cdb:packet-get-qtype vec) (vector-ref vec 1)) -(define-inline (cdb:packet-get-immediate vec) (vector-ref vec 2)) -(define-inline (cdb:packet-get-query-sig vec) (vector-ref vec 3)) -(define-inline (cdb:packet-get-params vec) (vector-ref vec 4)) -(define-inline (cdb:packet-get-qtime vec) (vector-ref vec 5)) +(define-inline (cdb:packet-get-client-sig vec) (safe-vector-ref vec 0)) +(define-inline (cdb:packet-get-qtype vec) (safe-vector-ref vec 1)) +(define-inline (cdb:packet-get-immediate vec) (safe-vector-ref vec 2)) +(define-inline (cdb:packet-get-query-sig vec) (safe-vector-ref vec 3)) +(define-inline (cdb:packet-get-params vec) (safe-vector-ref vec 4)) +(define-inline (cdb:packet-get-qtime vec) (safe-vector-ref vec 5)) (define-inline (cdb:packet-set-client-sig! vec val)(vector-set! vec 0 val)) (define-inline (cdb:packet-set-qtype! vec val)(vector-set! vec 1 val)) (define-inline (cdb:packet-set-immediate! vec val)(vector-set! vec 2 val)) (define-inline (cdb:packet-set-query-sig! vec val)(vector-set! vec 3 val)) (define-inline (cdb:packet-set-params! vec val)(vector-set! vec 4 val)) (define-inline (cdb:packet-set-qtime! vec val)(vector-set! vec 5 val)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -37,36 +37,36 @@ ;; A single data structure for all the data used in a dashboard. ;; Share this structure between newdashboard and dashboard with the ;; intent of converging on a single app. ;; (define *data* (make-vector 25 #f)) -(define (dboard:data-get-runs vec) (vector-ref vec 0)) -(define (dboard:data-get-tests vec) (vector-ref vec 1)) -(define (dboard:data-get-runs-matrix vec) (vector-ref vec 2)) -(define (dboard:data-get-tests-tree vec) (vector-ref vec 3)) -(define (dboard:data-get-run-keys vec) (vector-ref vec 4)) -(define (dboard:data-get-curr-test-ids vec) (vector-ref vec 5)) -;; (define (dboard:data-get-test-details vec) (vector-ref vec 6)) -(define (dboard:data-get-path-test-ids vec) (vector-ref vec 7)) -(define (dboard:data-get-updaters vec) (vector-ref vec 8)) -(define (dboard:data-get-path-run-ids vec) (vector-ref vec 9)) -(define (dboard:data-get-curr-run-id vec) (vector-ref vec 10)) -(define (dboard:data-get-runs-tree vec) (vector-ref vec 11)) +(define (dboard:data-get-runs vec) (safe-vector-ref vec 0)) +(define (dboard:data-get-tests vec) (safe-vector-ref vec 1)) +(define (dboard:data-get-runs-matrix vec) (safe-vector-ref vec 2)) +(define (dboard:data-get-tests-tree vec) (safe-vector-ref vec 3)) +(define (dboard:data-get-run-keys vec) (safe-vector-ref vec 4)) +(define (dboard:data-get-curr-test-ids vec) (safe-vector-ref vec 5)) +;; (define (dboard:data-get-test-details vec) (safe-vector-ref vec 6)) +(define (dboard:data-get-path-test-ids vec) (safe-vector-ref vec 7)) +(define (dboard:data-get-updaters vec) (safe-vector-ref vec 8)) +(define (dboard:data-get-path-run-ids vec) (safe-vector-ref vec 9)) +(define (dboard:data-get-curr-run-id vec) (safe-vector-ref vec 10)) +(define (dboard:data-get-runs-tree vec) (safe-vector-ref vec 11)) ;; For test-patts convert #f to "" (define (dboard:data-get-test-patts vec) - (let ((val (vector-ref vec 12)))(if val val ""))) -(define (dboard:data-get-states vec) (vector-ref vec 13)) -(define (dboard:data-get-statuses vec) (vector-ref vec 14)) -(define (dboard:data-get-logs-textbox vec val)(vector-ref vec 15)) -(define (dboard:data-get-command vec) (vector-ref vec 16)) -(define (dboard:data-get-command-tb vec) (vector-ref vec 17)) -(define (dboard:data-get-target vec) (vector-ref vec 18)) + (let ((val (safe-vector-ref vec 12)))(if val val ""))) +(define (dboard:data-get-states vec) (safe-vector-ref vec 13)) +(define (dboard:data-get-statuses vec) (safe-vector-ref vec 14)) +(define (dboard:data-get-logs-textbox vec val)(safe-vector-ref vec 15)) +(define (dboard:data-get-command vec) (safe-vector-ref vec 16)) +(define (dboard:data-get-command-tb vec) (safe-vector-ref vec 17)) +(define (dboard:data-get-target vec) (safe-vector-ref vec 18)) (define (dboard:data-get-target-string vec) (let ((targ (dboard:data-get-target vec))) (if (list? targ)(string-intersperse targ "/") "no-target-specified"))) -(define (dboard:data-get-run-name vec) (vector-ref vec 19)) -(define (dboard:data-get-runs-listbox vec) (vector-ref vec 20)) +(define (dboard:data-get-run-name vec) (safe-vector-ref vec 19)) +(define (dboard:data-get-runs-listbox vec) (safe-vector-ref vec 20)) (define (dboard:data-set-runs! vec val)(vector-set! vec 0 val)) (define (dboard:data-set-tests! vec val)(vector-set! vec 1 val)) (define (dboard:data-set-runs-matrix! vec val)(vector-set! vec 2 val)) (define (dboard:data-set-tests-tree! vec val)(vector-set! vec 3 val)) @@ -283,15 +283,15 @@ (if (null? tests-dat) '() (let loop ((hed (car tests-dat)) (tal (cdr tests-dat)) (res '())) - (let* ((test-id (vector-ref hed 0)) ;; look at the tests-dat spec for locations - (test-name (vector-ref hed 1)) - (item-path (vector-ref hed 2)) - (state (vector-ref hed 3)) - (status (vector-ref hed 4)) + (let* ((test-id (safe-vector-ref hed 0)) ;; look at the tests-dat spec for locations + (test-name (safe-vector-ref hed 1)) + (item-path (safe-vector-ref hed 2)) + (state (safe-vector-ref hed 3)) + (status (safe-vector-ref hed 4)) (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) @@ -468,23 +468,23 @@ ;; colnames) (set! rownum 1) (for-each (lambda (server) (set! colnum 0) - (let* ((vals (list (vector-ref server 0) ;; Id - (vector-ref server 9) ;; MT-Ver - (vector-ref server 1) ;; Pid - (vector-ref server 2) ;; Hostname - (conc (vector-ref server 3) ":" (vector-ref server 4)) ;; IP:Port - (seconds->hr-min-sec (- (current-seconds)(vector-ref server 6))) - ;; (vector-ref server 5) ;; Pubport - ;; (vector-ref server 10) ;; Last beat - ;; (vector-ref server 6) ;; Start time - ;; (vector-ref server 7) ;; Priority - ;; (vector-ref server 8) ;; State - (vector-ref server 8) ;; State - (vector-ref server 12) ;; RunId + (let* ((vals (list (safe-vector-ref server 0) ;; Id + (safe-vector-ref server 9) ;; MT-Ver + (safe-vector-ref server 1) ;; Pid + (safe-vector-ref server 2) ;; Hostname + (conc (safe-vector-ref server 3) ":" (safe-vector-ref server 4)) ;; IP:Port + (seconds->hr-min-sec (- (current-seconds)(safe-vector-ref server 6))) + ;; (safe-vector-ref server 5) ;; Pubport + ;; (safe-vector-ref server 10) ;; Last beat + ;; (safe-vector-ref server 6) ;; Start time + ;; (safe-vector-ref server 7) ;; Priority + ;; (safe-vector-ref server 8) ;; State + (safe-vector-ref server 8) ;; State + (safe-vector-ref server 12) ;; RunId ))) (for-each (lambda (val) (let* ((row-col (conc rownum ":" colnum)) (curr-val (iup:attribute servers-matrix row-col))) (if (not (equal? (conc val) curr-val)) @@ -666,21 +666,21 @@ "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (vector-set! record 3 (if (equal? (safe-vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (vector-set! record 4 (let ((startt (any->number (safe-vector-ref record 1))) + (endt (any->number (safe-vector-ref record 2)))) + (debug:print 4 "record[1]=" (safe-vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -710,28 +710,28 @@ (let* ((steps-data (db:get-steps-for-test dbstruct run-id test-id)) (comprsteps (dcommon:process-steps-table steps-data))) ;; (open-run-close db:get-steps-table #f test-id work-area: work-area))) (map (lambda (x) ;; take advantage of the \n on time->string (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta + (safe-vector-ref x 0) + (let ((s (safe-vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (safe-vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (safe-vector-ref x 3) ;; status + (safe-vector-ref x 4) + (safe-vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) + (let ((time-a (safe-vector-ref a 1)) + (time-b (safe-vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) - (string rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) + (let ((val (safe-vector-ref hed (- colnum 1))) (mtrx-rc (conc rownum ":" colnum))) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) (if (< colnum 6) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -54,11 +54,11 @@ (begin (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f) (runflag #f)) ;; flag used to skip steps when not starting at the beginning - (if (vector-ref exit-info 1) + (if (safe-vector-ref exit-info 1) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) @@ -96,19 +96,19 @@ (if (eq? pid-val 0) (begin (thread-sleep! 1) (processloop (+ i 1)))) )) - (let ((exinfo (vector-ref exit-info 2)) + (let ((exinfo (safe-vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond - ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) - ((eq? (vector-ref exit-info 2) 0) 'pass) + ((and (eq? (safe-vector-ref exit-info 2) 2) logpro-used) 'warn) + ((eq? (safe-vector-ref exit-info 2) 0) 'pass) (else 'fail))) (overall-status (cond ((eq? rollup-status 2) 'warn) ((eq? rollup-status 0) 'pass) (else 'fail))) @@ -115,11 +115,11 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail)))) - (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + (debug:print 4 "Exit value received: " (safe-vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) @@ -131,11 +131,11 @@ (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) - (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) + (if (and (steprun-good? logpro-used (safe-vector-ref exit-info 2)) (not (null? tal))) (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop (loop (car tal) (cdr tal) stepname runflag)))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))) @@ -143,16 +143,16 @@ ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) - (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (safe-vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond - ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run + ((not (safe-vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) ;; if the current status is AUTO the defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) Index: fdb_records.scm ================================================================== --- fdb_records.scm +++ fdb_records.scm @@ -1,19 +1,19 @@ ;; Single record for managing a filedb ;; make-vector-record "Filedb record" filedb fdb db dbpath pathcache idcache partcache ;; Filedb record (define (make-filedb:fdb)(make-vector 5)) -(define-inline (filedb:fdb-get-db vec) (vector-ref vec 0)) -(define-inline (filedb:fdb-get-dbpath vec) (vector-ref vec 1)) -(define-inline (filedb:fdb-get-pathcache vec) (vector-ref vec 2)) -(define-inline (filedb:fdb-get-idcache vec) (vector-ref vec 3)) -(define-inline (filedb:fdb-get-partcache vec) (vector-ref vec 4)) +(define-inline (filedb:fdb-get-db vec) (safe-vector-ref vec 0)) +(define-inline (filedb:fdb-get-dbpath vec) (safe-vector-ref vec 1)) +(define-inline (filedb:fdb-get-pathcache vec) (safe-vector-ref vec 2)) +(define-inline (filedb:fdb-get-idcache vec) (safe-vector-ref vec 3)) +(define-inline (filedb:fdb-get-partcache vec) (safe-vector-ref vec 4)) (define-inline (filedb:fdb-set-db! vec val)(vector-set! vec 0 val)) (define-inline (filedb:fdb-set-dbpath! vec val)(vector-set! vec 1 val)) (define-inline (filedb:fdb-set-pathcache! vec val)(vector-set! vec 2 val)) (define-inline (filedb:fdb-set-idcache! vec val)(vector-set! vec 3 val)) (define-inline (filedb:fdb-set-partcache! vec val)(vector-set! vec 4 val)) ;; children records, should have use something other than "child" -(define-inline (filedb:child-get-id vec) (vector-ref vec 0)) -(define-inline (filedb:child-get-path vec) (vector-ref vec 1)) -(define-inline (filedb:child-get-parent_id vec)(vector-ref vec 2)) +(define-inline (filedb:child-get-id vec) (safe-vector-ref vec 0)) +(define-inline (filedb:child-get-path vec) (safe-vector-ref vec 1)) +(define-inline (filedb:child-get-parent_id vec)(safe-vector-ref vec 2)) Index: filedb.scm ================================================================== --- filedb.scm +++ filedb.scm @@ -98,15 +98,15 @@ (define (filedb:add-path-stat db path parent statinfo) (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id,mode,uid,gid,size,mtime) VALUES (?,?,?,?,?,?,?);"))) (sqlite3:execute stmt path parent - (vector-ref statinfo 1) ;; mode - (vector-ref statinfo 3) ;; uid - (vector-ref statinfo 4) ;; gid - (vector-ref statinfo 5) ;; size - (vector-ref statinfo 8) ;; mtime + (safe-vector-ref statinfo 1) ;; mode + (safe-vector-ref statinfo 3) ;; uid + (safe-vector-ref statinfo 4) ;; gid + (safe-vector-ref statinfo 5) ;; size + (safe-vector-ref statinfo 8) ;; mtime ) (sqlite3:finalize! stmt))) ;; (filedb:get-current-time-string)))) (define (filedb:add-path db path parent) (let ((stmt (sqlite3:prepare db "INSERT INTO paths (path,parent_id) VALUES (?,?);"))) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -272,11 +272,11 @@ (set! success #f) (debug:print 0 "WARNING: failure in with-input-from-request to " fullurl ".") (debug:print 0 " message: " ((condition-property-accessor 'exn 'message) exn)) (hash-table-delete! *runremote* run-id) ;; Killing associated server to allow clean retry.") - (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? + ;; (tasks:kill-server-run-id run-id) ;; better to kill the server in the logic that called this routine? (mutex-unlock! *http-mutex*) (signal (make-composite-condition (make-property-condition 'commfail 'message "failed to connect to server"))) "communications failed") (with-input-from-request ;; was dat @@ -298,20 +298,20 @@ (thread-start! th1) (thread-start! th2) (thread-join! th1) (thread-terminate! th2) (debug:print-info 11 "got res=" res) - (if (vector? res) - (if (vector-ref res 0) + (if (and res (vector? res)) + (if (safe-vector-ref res 0) res (begin ;; note: this code also called in nmsg-transport - consider consolidating it - (debug:print 0 "ERROR: error occured at server, info=" (vector-ref res 2)) + (debug:print 0 "ERROR: error occured at server, info=" (safe-vector-ref res 2)) (debug:print 0 " client call chain:") (print-call-chain (current-error-port)) (debug:print 0 " server call chain:") - (pp (vector-ref res 1) (current-error-port)) - (signal (vector-ref result 0)))) + (pp (safe-vector-ref res 1) (current-error-port)) + (signal (safe-vector-ref result 0)))) (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server"))))))) @@ -325,17 +325,17 @@ #t) #f))) (define (make-http-transport:server-dat)(make-vector 6)) -(define (http-transport:server-dat-get-iface vec) (vector-ref vec 0)) -(define (http-transport:server-dat-get-port vec) (vector-ref vec 1)) -(define (http-transport:server-dat-get-api-uri vec) (vector-ref vec 2)) -(define (http-transport:server-dat-get-api-url vec) (vector-ref vec 3)) -(define (http-transport:server-dat-get-api-req vec) (vector-ref vec 4)) -(define (http-transport:server-dat-get-last-access vec) (vector-ref vec 5)) -(define (http-transport:server-dat-get-socket vec) (vector-ref vec 6)) +(define (http-transport:server-dat-get-iface vec) (safe-vector-ref vec 0)) +(define (http-transport:server-dat-get-port vec) (safe-vector-ref vec 1)) +(define (http-transport:server-dat-get-api-uri vec) (safe-vector-ref vec 2)) +(define (http-transport:server-dat-get-api-url vec) (safe-vector-ref vec 3)) +(define (http-transport:server-dat-get-api-req vec) (safe-vector-ref vec 4)) +(define (http-transport:server-dat-get-last-access vec) (safe-vector-ref vec 5)) +(define (http-transport:server-dat-get-socket vec) (safe-vector-ref vec 6)) (define (http-transport:server-dat-make-url vec) (if (and (http-transport:server-dat-get-iface vec) (http-transport:server-dat-get-port vec)) (conc "http://" @@ -437,10 +437,11 @@ (if (equal? new-server-id server-id) (begin (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "dbprep") (thread-sleep! 0.5) ;; give some margin for queries to complete before switching from file based access to server based access (set! *inmemdb* (db:setup run-id)) + (thread-sleep! 0.1) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "running")) (begin ;; gotta exit nicely (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "collision") (http-transport:server-shutdown server-id port)))))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -246,12 +246,12 @@ (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f)) - ;; check exit-info (vector-ref exit-info 1) - (if (vector-ref exit-info 1) + ;; check exit-info (safe-vector-ref exit-info 1) + (if (safe-vector-ref exit-info 1) (let* ((stepname (car ezstep)) ;; do stuff to run the step (stepinfo (cadr ezstep)) (stepparts (string-match (regexp "^(\\{([^\\}]*)\\}\\s*|)(.*)$") stepinfo)) (stepparms (list-ref stepparts 2)) ;; for future use, {VAR=1,2,3}, run step for each (stepcmd (list-ref stepparts 3)) @@ -287,19 +287,19 @@ (if (eq? pid-val 0) (begin (thread-sleep! 2) (processloop (+ i 1)))) )) - (let ((exinfo (vector-ref exit-info 2)) + (let ((exinfo (safe-vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used (rmt:test-set-log! run-id test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond - ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) - ((eq? (vector-ref exit-info 2) 0) 'pass) + ((and (eq? (safe-vector-ref exit-info 2) 2) logpro-used) 'warn) + ((eq? (safe-vector-ref exit-info 2) 0) 'pass) (else 'fail))) (overall-status (cond ((eq? rollup-status 2) 'warn) ((eq? rollup-status 0) 'pass) (else 'fail))) @@ -312,11 +312,11 @@ (cond ((null? tal) ;; more to run? "COMPLETED") (else "RUNNING"))) ) - (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used + (debug:print 4 "Exit value received: " (safe-vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) @@ -328,11 +328,11 @@ (tests:test-set-status! run-id test-id next-state "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" (tests:test-set-status! run-id test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) - (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) + (if (and (steprun-good? logpro-used (safe-vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) (monitorjob (lambda () (let* ((start-seconds (current-seconds)) @@ -361,11 +361,11 @@ (begin (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? - (let* ((pid1 (vector-ref exit-info 0)) + (let* ((pid1 (safe-vector-ref exit-info 0)) (pid2 (rmt:test-get-top-process-pid run-id test-id)) (pids (delete-duplicates (filter number? (list pid1 pid2))))) (if (not (null? pids)) (begin (for-each @@ -411,25 +411,25 @@ (let* ((item-path (item-list->path itemdat)) ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) - (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status + (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (safe-vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test ) (new-status (cond - ((not (vector-ref exit-info 1)) "FAIL") ;; job failed to run + ((not (safe-vector-ref exit-info 1)) "FAIL") ;; job failed to run ((eq? rollup-status 0) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? rollup-status 1) "FAIL") ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) - (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (vector-ref exit-info 1) " and rollup-status of " rollup-status) + (debug:print-info 1 "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (safe-vector-ref exit-info 1) " and rollup-status of " rollup-status) (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f) @@ -438,13 +438,13 @@ )) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f))) ;; don't force - just update if no (mutex-unlock! m) - (debug:print 2 "Output from running " fullrunscript ", pid " (vector-ref exit-info 0) " in work area " - work-area ":\n====\n exit code " (vector-ref exit-info 2) "\n" "====\n") - (if (not (vector-ref exit-info 1)) + (debug:print 2 "Output from running " fullrunscript ", pid " (safe-vector-ref exit-info 0) " in work area " + work-area ":\n====\n exit code " (safe-vector-ref exit-info 2) "\n" "====\n") + (if (not (safe-vector-ref exit-info 1)) (exit 4))))))) ;; set up the very basics needed for doing anything here. (define (launch:setup-for-run #!key (force #f)) ;; would set values for KEYS in the environment here for better support of env-override but Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -22,12 +22,12 @@ ;;====================================================================== ;; db record, ;;====================================================================== (define (make-lock-queue:db-dat)(make-vector 3)) -(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) -(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) +(define-inline (lock-queue:db-dat-get-db vec) (safe-vector-ref vec 0)) +(define-inline (lock-queue:db-dat-get-path vec) (safe-vector-ref vec 1)) (define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) (define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) (define (lock-queue:open-db fname #!key (count 10)) (let* ((actualfname (conc fname ".lockdb")) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -558,22 +558,22 @@ (sid (if killinfo (if (substring-index ":" killinfo) #f (string->number killinfo)) #f))) (format #t fmtstr "Id" "MTver" "Pid" "Host" "Interface:OutPort" "InPort" "LastBeat" "State" "Transport") (format #t fmtstr "==" "=====" "===" "====" "=================" "======" "========" "=====" "=========") (for-each (lambda (server) - (let* ((id (vector-ref server 0)) - (pid (vector-ref server 1)) - (hostname (vector-ref server 2)) - (interface (vector-ref server 3)) - (pullport (vector-ref server 4)) - (pubport (vector-ref server 5)) - (start-time (vector-ref server 6)) - (priority (vector-ref server 7)) - (state (vector-ref server 8)) - (mt-ver (vector-ref server 9)) - (last-update (vector-ref server 10)) - (transport (vector-ref server 11)) + (let* ((id (safe-vector-ref server 0)) + (pid (safe-vector-ref server 1)) + (hostname (safe-vector-ref server 2)) + (interface (safe-vector-ref server 3)) + (pullport (safe-vector-ref server 4)) + (pubport (safe-vector-ref server 5)) + (start-time (safe-vector-ref server 6)) + (priority (safe-vector-ref server 7)) + (state (safe-vector-ref server 8)) + (mt-ver (safe-vector-ref server 9)) + (last-update (safe-vector-ref server 10)) + (transport (safe-vector-ref server 11)) (killed #f) (status (< last-update 20))) ;; (zmq-sockets (if status (server:client-connect hostname port) #f))) ;; no need to login as status of #t indicates we are connecting to correct ;; server @@ -726,17 +726,17 @@ "set run status" (lambda (target runname keys keyvals) (let* ((runsdat (rmt:get-runs-by-patt keys runname (common:args-get-target) #f #f)) - (header (vector-ref runsdat 0)) - (rows (vector-ref runsdat 1))) + (header (safe-vector-ref runsdat 0)) + (rows (safe-vector-ref runsdat 1))) (if (null? rows) (begin (debug:print-info 0 "No matching run found.") (exit 1)) - (let* ((row (car (vector-ref runsdat 1))) + (let* ((row (car (safe-vector-ref runsdat 1))) (run-id (db:get-value-by-header row header "id"))) (if (args:get-arg "-set-run-status") (rmt:set-run-status run-id (args:get-arg "-set-run-status") msg: (args:get-arg "-m")) (print (rmt:get-run-status run-id)) ))))))) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -46,12 +46,12 @@ (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) - (let* ((header (vector-ref runsdat 0)) - (runslst (vector-ref runsdat 1)) + (let* ((header (safe-vector-ref runsdat 0)) + (runslst (safe-vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) @@ -85,16 +85,16 @@ full-list)))) (define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmap #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) - (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (useres (let ((last-time (if (vector? res) (safe-vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres - (let ((result (vector-ref res 1))) + (let ((result (safe-vector-ref res 1))) (debug:print 4 "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) ;; (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmap: itemmap))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) @@ -111,11 +111,11 @@ (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) (let loop ((testn (car tests)) (remt (cdr tests)) (res '())) (let* ((test-dat (hash-table-ref/default test-records testn (vector #f #f '()))) - (waitons (vector-ref test-dat 2))) + (waitons (safe-vector-ref test-dat 2))) ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) (if (null? remt) (let ((new-res (reverse res))) ;; (print " new-res: " new-res) new-res) Index: nmsg-transport.scm ================================================================== --- nmsg-transport.scm +++ nmsg-transport.scm @@ -182,11 +182,11 @@ (dat (vector "ping" our-key)) (result (condition-case (nmsg-transport:client-api-send-receive-raw req dat timeout: timeout) ((timeout)(set! success #f) #f))) (key (if success - (vector-ref result 1) + (safe-vector-ref result 1) #f))) (debug:print 0 "success=" success ", key=" key ", expected-key=" expected-key ", equal? " (equal? key expected-key)) (if (and success (or (not expected-key) ;; just getting a reply is good enough then (equal? key expected-key))) @@ -237,19 +237,19 @@ (thread-join! send-recv) (if success (thread-terminate! timeout))) ;; raise timeout error if timed out (if success (if (and (vector? result) - (vector-ref result 0)) ;; did it fail at the server? + (safe-vector-ref result 0)) ;; did it fail at the server? result ;; nope, all good (begin - (debug:print 0 "ERROR: error occured at server, info=" (vector-ref result 2)) + (debug:print 0 "ERROR: error occured at server, info=" (safe-vector-ref result 2)) (debug:print 0 " client call chain:") (print-call-chain (current-error-port)) (debug:print 0 " server call chain:") - (pp (vector-ref result 1) (current-error-port)) - (signal (vector-ref result 0)))) + (pp (safe-vector-ref result 1) (current-error-port)) + (signal (safe-vector-ref result 0)))) (signal (make-composite-condition (make-property-condition 'timeout 'message "nmsg-transport:client-api-send-receive-raw timed out talking to server")))))) ;; run nmsg-transport:keep-running in a parallel thread to monitor that the db is being ;; used and to shutdown after sometime if it is not. @@ -325,12 +325,12 @@ ;; tasks:kill-server-run-id when there is an exception (mutex-lock! *http-mutex*) (let* ((packet (vector cmd param)) (reqsoc (http-transport:server-dat-get-socket connection-info)) (res (nmsg-transport:client-api-send-receive-raw reqsoc packet))) -;; (status (vector-ref rawres 0)) -;; (result (vector-ref rawres 1))) +;; (status (safe-vector-ref rawres 0)) +;; (result (safe-vector-ref rawres 1))) (mutex-unlock! *http-mutex*) res)) ;; (vector status (if status (db:string->obj result transport: 'nmsg) result)))) ;;====================================================================== ;; J U N K Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -51,12 +51,12 @@ (let* ((tmprec (hash-table-ref/default *write-frequency* run-id #f)) (record (if tmprec tmprec (let ((v (vector (current-seconds) 0))) (hash-table-set! *write-frequency* run-id v) v))) - (count (+ 1 (vector-ref record 1))) - (start (vector-ref record 0)) + (count (+ 1 (safe-vector-ref record 1))) + (start (safe-vector-ref record 0)) (queries-per-second (/ (* count 1.0) (max (- (current-seconds) start) 1)))) (vector-set! record 1 count) (if (and (> count 10) (> queries-per-second 10)) @@ -63,19 +63,21 @@ (begin (debug:print-info 1 "db write rate too high, starting a server, count=" count " start=" start " run-id=" run-id " queries-per-second=" queries-per-second) #t) #f)))) -(define (rmt:get-connection-info run-id) - (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) - (if cinfo - cinfo - ;; NB// can cache the answer for server running for 10 seconds ... - ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) - (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) - (client:setup run-id) - #f)))) +;; (define (rmt:get-connection-info run-id) +;; (let ((cinfo (hash-table-ref/default *runremote* run-id #f))) +;; (if cinfo +;; cinfo +;; ;; NB// can cache the answer for server running for 10 seconds ... +;; ;; ;; (and (not (rmt:write-frequency-over-limit? cmd run-id)) +;; ;; (if (tasks:server-running-or-starting? (db:delay-if-busy (tasks:open-db)) run-id) +;; ;; (begin +;; ;; (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id) +;; (client:setup run-id)))) +;; ;; #f)))) (define *send-receive-mutex* (make-mutex)) ;; should have separate mutex per run-id (define (rmt:send-receive cmd rid params #!key (attemptnum 1)) ;; start attemptnum at 1 so the modulo below works as expected ;; clean out old connections (mutex-lock! *db-multi-sync-mutex*) @@ -94,64 +96,54 @@ (hash-table-delete! *runremote* run-id))))) (hash-table-keys *runremote*))) (mutex-unlock! *db-multi-sync-mutex*) ;; (mutex-lock! *send-receive-mutex*) (let* ((run-id (if rid rid 0)) - (connection-info (rmt:get-connection-info run-id))) + (connection-info (hash-table-ref/default *runremote* run-id #f))) ;; (rmt:get-connection-info run-id))) ;; the nmsg method does the encoding under the hood (the http method should be changed to do this also) (if connection-info ;; use the server if have connection info (let* ((dat (case *transport-type* ((http)(condition-case (http-transport:client-api-send-receive run-id connection-info cmd params) - ((commfail)(vector #f "communications fail")) - ((exn)(vector #f "other fail")))) + ((commfail) + (tasks:kill-server-run-id run-id) + (vector #f "communications fail")) + ((exn) + (tasks:kill-server-run-id run-id) + (vector #f "other fail")))) ((nmsg)(condition-case (nmsg-transport:client-api-send-receive run-id connection-info cmd params) ((timeout)(vector #f "timeout talking to server")))) (else (exit)))) - (success (if (vector? dat) (vector-ref dat 0) #f)) - (res (if (vector? dat) (vector-ref dat 1) #f))) - (if (vector? connection-info)(http-transport:server-dat-update-last-access connection-info)) + (success (if (vector? dat) (safe-vector-ref dat 0) #f)) + (res (if (vector? dat) (safe-vector-ref dat 1) #f))) + (if (and connection-info (vector? connection-info))(http-transport:server-dat-update-last-access connection-info)) (if success (begin ;; (mutex-unlock! *send-receive-mutex*) + ;; all is well, return the result! (case *transport-type* ((http) res) ;; (db:string->obj res)) - ((nmsg) res))) ;; (vector-ref res 1))) + ((nmsg) res))) ;; (safe-vector-ref res 1))) + ;; we had a connection but it is borked. clean up and reconnect (begin ;; let ((new-connection-info (client:setup run-id))) (debug:print 0 "WARNING: Communication failed, trying call to rmt:send-receive again.") ;; (case *transport-type* ;; ((nmsg)(nn-close (http-transport:server-dat-get-socket connection-info)))) (hash-table-delete! *runremote* run-id) ;; don't keep using the same connection - ;; NOTE: killing server causes this process to block forever. No idea why. Dec 2. - ;; (if (eq? (modulo attemptnum 5) 0) - ;; (tasks:kill-server-run-id run-id tag: "api-send-receive-failed")) - ;; (mutex-unlock! *send-receive-mutex*) ;; close the mutex here to allow other threads access to communications - (tasks:start-and-wait-for-server (tasks:open-db) run-id 15) - ;; (nmsg-transport:client-api-send-receive run-id connection-info cmd param remtries: (- remtries 1)))))) - - ;; no longer killing the server in http-transport:client-api-send-receive - ;; may kill it here but what are the criteria? - ;; start with three calls then kill server - ;; (if (eq? attemptnum 3)(tasks:kill-server-run-id run-id)) - ;; (thread-sleep! 2) (rmt:send-receive cmd run-id params attemptnum: (+ attemptnum 1))))) ;; no connection info? try to start a server (if (and (< attemptnum 15) (member cmd api:write-queries)) (begin (hash-table-delete! *runremote* run-id) ;; (mutex-unlock! *send-receive-mutex*) (tasks:start-and-wait-for-server (db:delay-if-busy (tasks:open-db)) run-id 10) - ;; (client:setup run-id) ;; client setup happens in rmt:get-connection-info - (thread-sleep! (random 5)) ;; give some time to settle and minimize collison? + (client:setup run-id) (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1))) (begin - ;; (debug:print 0 "ERROR: Communication failed!") - ;; (mutex-unlock! *send-receive-mutex*) - ;; (exit) (rmt:open-qry-close-locally cmd run-id params) ))))) (define (rmt:update-db-stats run-id rawcmd params duration) (mutex-lock! *db-stats-mutex*) @@ -166,26 +158,26 @@ (stat-vec (hash-table-ref/default *db-stats* cmd #f))) (if (not (vector? stat-vec)) (let ((newvec (vector 0 0))) (hash-table-set! *db-stats* cmd newvec) (set! stat-vec newvec))) - (vector-set! stat-vec 0 (+ (vector-ref stat-vec 0) 1)) - (vector-set! stat-vec 1 (+ (vector-ref stat-vec 1) duration)))) + (vector-set! stat-vec 0 (+ (safe-vector-ref stat-vec 0) 1)) + (vector-set! stat-vec 1 (+ (safe-vector-ref stat-vec 1) duration)))) (mutex-unlock! *db-stats-mutex*)) (define (rmt:print-db-stats) (let ((fmtstr "~40a~7-d~9-d~20,2-f")) ;; "~20,2-f" (debug:print 18 "DB Stats\n========") (debug:print 18 (format #f "~40a~8a~10a~10a" "Cmd" "Count" "TotTime" "Avg")) (for-each (lambda (cmd) (let ((cmd-dat (hash-table-ref *db-stats* cmd))) - (debug:print 18 (format #f fmtstr cmd (vector-ref cmd-dat 0) (vector-ref cmd-dat 1) (/ (vector-ref cmd-dat 1)(vector-ref cmd-dat 0)))))) + (debug:print 18 (format #f fmtstr cmd (safe-vector-ref cmd-dat 0) (safe-vector-ref cmd-dat 1) (/ (safe-vector-ref cmd-dat 1)(safe-vector-ref cmd-dat 0)))))) (sort (hash-table-keys *db-stats*) (lambda (a b) - (> (vector-ref (hash-table-ref *db-stats* a) 0) - (vector-ref (hash-table-ref *db-stats* b) 0))))))) + (> (safe-vector-ref (hash-table-ref *db-stats* a) 0) + (safe-vector-ref (hash-table-ref *db-stats* b) 0))))))) (define (rmt:get-max-query-average run-id) (mutex-lock! *db-stats-mutex*) (let* ((runkey (conc "run-id=" run-id " ")) (cmds (filter (lambda (x) @@ -196,12 +188,12 @@ (let loop ((cmd (car cmds)) (tal (cdr cmds)) (max-cmd (car cmds)) (res 0)) (let* ((cmd-dat (hash-table-ref *db-stats* cmd)) - (tot (vector-ref cmd-dat 0)) - (curravg (/ (vector-ref cmd-dat 1) (vector-ref cmd-dat 0))) ;; count is never zero by construction + (tot (safe-vector-ref cmd-dat 0)) + (curravg (/ (safe-vector-ref cmd-dat 1) (safe-vector-ref cmd-dat 0))) ;; count is never zero by construction (currmax (max res curravg)) (newmax-cmd (if (> curravg res) cmd max-cmd))) (if (null? tal) (if (> tot 10) (cons newmax-cmd currmax) @@ -219,11 +211,11 @@ db))) (db-file-path (db:dbfile-path 0))) ;; (read-only (not (file-read-access? db-file-path))) (let* ((start (current-milliseconds)) (resdat (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))) - (res (vector-ref resdat 1)) + (res (safe-vector-ref resdat 1)) (duration (- (current-milliseconds) start))) (rmt:update-db-stats run-id cmd params duration) ;; mark this run as dirty if this was a write (if (not (member cmd api:read-only-queries)) (let ((start-time (current-seconds))) @@ -240,14 +232,14 @@ (res (handle-exceptions exn #f (http-transport:client-api-send-receive run-id connection-info cmd params)))) ;; ((commfail) (vector #f "communications fail"))))) - (if (and res (vector-ref res 0)) + (if (and res (safe-vector-ref res 0)) res #f))) -;; (db:string->obj (vector-ref dat 1)) +;; (db:string->obj (safe-vector-ref dat 1)) ;; (begin ;; (debug:print 0 "ERROR: rmt:send-receive-no-auto-client-setup failed, attempting to continue. Got " dat) ;; dat)))) ;; Wrap json library for strings (why the ports crap in the first place?) Index: run_records.scm ================================================================== --- run_records.scm +++ run_records.scm @@ -8,30 +8,30 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (define-inline (runs:runrec-make-record) (make-vector 13)) -(define-inline (runs:runrec-get-target vec)(vector-ref vec 0)) ;; a/b/c -(define-inline (runs:runrec-get-runname vec)(vector-ref vec 1)) ;; string -(define-inline (runs:runrec-testpatt vec)(vector-ref vec 2)) ;; a,b/c,d% -(define-inline (runs:runrec-keys vec)(vector-ref vec 3)) ;; (key1 key2 ...) -(define-inline (runs:runrec-keyvals vec)(vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) -(define-inline (runs:runrec-environment vec)(vector-ref vec 5)) ;; environment, alist key val -(define-inline (runs:runrec-mconfig vec)(vector-ref vec 6)) ;; megatest.config -(define-inline (runs:runrec-runconfig vec)(vector-ref vec 7)) ;; runconfigs.config -(define-inline (runs:runrec-serverdat vec)(vector-ref vec 8)) ;; (host port) -(define-inline (runs:runrec-transport vec)(vector-ref vec 9)) ;; 'http -(define-inline (runs:runrec-db vec)(vector-ref vec 10)) ;; (if 'fs) -(define-inline (runs:runrec-top-path vec)(vector-ref vec 11)) ;; *toppath* -(define-inline (runs:runrec-run_id vec)(vector-ref vec 12)) ;; run-id - -(define-inline (test:get-id vec) (vector-ref vec 0)) -(define-inline (test:get-run_id vec) (vector-ref vec 1)) -(define-inline (test:get-test-name vec)(vector-ref vec 2)) -(define-inline (test:get-state vec) (vector-ref vec 3)) -(define-inline (test:get-status vec) (vector-ref vec 4)) -(define-inline (test:get-item-path vec)(vector-ref vec 5)) +(define-inline (runs:runrec-get-target vec)(safe-vector-ref vec 0)) ;; a/b/c +(define-inline (runs:runrec-get-runname vec)(safe-vector-ref vec 1)) ;; string +(define-inline (runs:runrec-testpatt vec)(safe-vector-ref vec 2)) ;; a,b/c,d% +(define-inline (runs:runrec-keys vec)(safe-vector-ref vec 3)) ;; (key1 key2 ...) +(define-inline (runs:runrec-keyvals vec)(safe-vector-ref vec 4)) ;; ((key1 val1)(key2 val2) ...) +(define-inline (runs:runrec-environment vec)(safe-vector-ref vec 5)) ;; environment, alist key val +(define-inline (runs:runrec-mconfig vec)(safe-vector-ref vec 6)) ;; megatest.config +(define-inline (runs:runrec-runconfig vec)(safe-vector-ref vec 7)) ;; runconfigs.config +(define-inline (runs:runrec-serverdat vec)(safe-vector-ref vec 8)) ;; (host port) +(define-inline (runs:runrec-transport vec)(safe-vector-ref vec 9)) ;; 'http +(define-inline (runs:runrec-db vec)(safe-vector-ref vec 10)) ;; (if 'fs) +(define-inline (runs:runrec-top-path vec)(safe-vector-ref vec 11)) ;; *toppath* +(define-inline (runs:runrec-run_id vec)(safe-vector-ref vec 12)) ;; run-id + +(define-inline (test:get-id vec) (safe-vector-ref vec 0)) +(define-inline (test:get-run_id vec) (safe-vector-ref vec 1)) +(define-inline (test:get-test-name vec)(safe-vector-ref vec 2)) +(define-inline (test:get-state vec) (safe-vector-ref vec 3)) +(define-inline (test:get-status vec) (safe-vector-ref vec 4)) +(define-inline (test:get-item-path vec)(safe-vector-ref vec 5)) (define-inline (test:test-get-fullname test) (conc (db:test-get-testname test) (if (equal? (db:test-get-item-path test) "") "" Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1422,12 +1422,12 @@ (common:clear-caches) ;; clear all caches (let* ((db #f) (tdbdat (tasks:open-db)) (keys (rmt:get-keys)) (rundat (mt:get-runs-by-patt keys runnamepatt target)) - (header (vector-ref rundat 0)) - (runs (vector-ref rundat 1)) + (header (safe-vector-ref rundat 0)) + (runs (safe-vector-ref rundat 1)) (states (if state (string-split state ",") '())) (statuses (if status (string-split status ",") '())) (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f)))) (debug:print-info 4 "runs:operate-on => Header: " header " action: " action " new-state-status: " new-state-status) (if (> 2 (length state-status)) @@ -1680,12 +1680,12 @@ ;;====================================================================== (define (runs:handle-locking target keys runname lock unlock user) (let* ((db #f) (rundat (mt:get-runs-by-patt keys runname target)) - (header (vector-ref rundat 0)) - (runs (vector-ref rundat 1))) + (header (safe-vector-ref rundat 0)) + (runs (safe-vector-ref rundat 1))) (for-each (lambda (run) (let ((run-id (db:get-value-by-header run header "id"))) (if (or lock (and unlock (begin @@ -1709,11 +1709,11 @@ (lambda (key) (let* ((idx (cadr key)) (fld (car key)) (val (config-lookup test-conf "test_meta" fld))) ;; (debug:print 5 "idx: " idx " fld: " fld " val: " val) - (if (and val (not (equal? (vector-ref currrecord idx) val))) + (if (and val (not (equal? (safe-vector-ref currrecord idx) val))) (begin (print "Updating " test-name " " fld " to " val) (rmt:testmeta-update-field test-name fld val))))) '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10))))) Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -90,11 +90,11 @@ ;; (send-message pubsock (case (server:get-transport) ((rpc) (db:obj->string (vector success/fail query-sig result))) ((http) (db:obj->string (vector success/fail query-sig result))) ((zmq) - (let ((pub-socket (vector-ref *runremote* 1))) + (let ((pub-socket (safe-vector-ref *runremote* 1))) (send-message pub-socket return-addr send-more: #t) (send-message pub-socket (db:obj->string (vector success/fail query-sig result))))) ((fs) result) (else (debug:print 0 "ERROR: unrecognised transport type: " *transport-type*) Index: synchash.scm ================================================================== --- synchash.scm +++ synchash.scm @@ -103,17 +103,17 @@ (print "ERROR: sync for hash " proc " not setup! Edits needed in synchash.scm") print)) db params)) (postdat #f) (make-indexed (lambda (x) - (list (vector-ref x keynum) x)))) + (list (safe-vector-ref x keynum) x)))) ;; Now process newdat based on the query type (set! postdat (case proc ((db:get-runs) ;; (debug:print-info 2 "Get runs call") - (let ((header (vector-ref newdat 0)) - (data (vector-ref newdat 1))) + (let ((header (safe-vector-ref newdat 0)) + (data (safe-vector-ref newdat 1))) ;; (debug:print-info 2 "header: " header ", data: " data) (cons (list "header" header) ;; add the header keyed by the word "header" (map make-indexed data)))) ;; add each element keyed by the keynum'th val (else ;; (debug:print-info 2 "Non-get runs call") Index: task_records.scm ================================================================== --- task_records.scm +++ task_records.scm @@ -9,28 +9,28 @@ ;; PURPOSE. ;;====================================================================== ;; make-vector-record tasks task id action owner state target name test item params creation_time execution_time (define (make-tasks:task)(make-vector 11)) -(define-inline (tasks:task-get-id vec) (vector-ref vec 0)) -(define-inline (tasks:task-get-action vec) (vector-ref vec 1)) -(define-inline (tasks:task-get-owner vec) (vector-ref vec 2)) -(define-inline (tasks:task-get-state vec) (vector-ref vec 3)) -(define-inline (tasks:task-get-target vec) (vector-ref vec 4)) -(define-inline (tasks:task-get-name vec) (vector-ref vec 5)) -(define-inline (tasks:task-get-test vec) (vector-ref vec 6)) -(define-inline (tasks:task-get-item vec) (vector-ref vec 7)) -(define-inline (tasks:task-get-params vec) (vector-ref vec 8)) -(define-inline (tasks:task-get-creation_time vec) (vector-ref vec 9)) -(define-inline (tasks:task-get-execution_time vec) (vector-ref vec 10)) +(define-inline (tasks:task-get-id vec) (safe-vector-ref vec 0)) +(define-inline (tasks:task-get-action vec) (safe-vector-ref vec 1)) +(define-inline (tasks:task-get-owner vec) (safe-vector-ref vec 2)) +(define-inline (tasks:task-get-state vec) (safe-vector-ref vec 3)) +(define-inline (tasks:task-get-target vec) (safe-vector-ref vec 4)) +(define-inline (tasks:task-get-name vec) (safe-vector-ref vec 5)) +(define-inline (tasks:task-get-test vec) (safe-vector-ref vec 6)) +(define-inline (tasks:task-get-item vec) (safe-vector-ref vec 7)) +(define-inline (tasks:task-get-params vec) (safe-vector-ref vec 8)) +(define-inline (tasks:task-get-creation_time vec) (safe-vector-ref vec 9)) +(define-inline (tasks:task-get-execution_time vec) (safe-vector-ref vec 10)) (define-inline (tasks:task-set-state! vec val)(vector-set! vec 3 val)) ;; make-vector-record tasks monitor id pid start_time last_update hostname username (define (make-tasks:monitor)(make-vector 5)) -(define-inline (tasks:monitor-get-id vec) (vector-ref vec 0)) -(define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1)) -(define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2)) -(define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3)) -(define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4)) -(define-inline (tasks:monitor-get-username vec) (vector-ref vec 5)) +(define-inline (tasks:monitor-get-id vec) (safe-vector-ref vec 0)) +(define-inline (tasks:monitor-get-pid vec) (safe-vector-ref vec 1)) +(define-inline (tasks:monitor-get-start_time vec) (safe-vector-ref vec 2)) +(define-inline (tasks:monitor-get-last_update vec) (safe-vector-ref vec 3)) +(define-inline (tasks:monitor-get-hostname vec) (safe-vector-ref vec 4)) +(define-inline (tasks:monitor-get-username vec) (safe-vector-ref vec 5)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -157,17 +157,17 @@ ;;====================================================================== ;; Server and client management ;;====================================================================== ;; make-vector-record tasks hostinfo id interface port pubport transport pid hostname -(define (tasks:hostinfo-get-id vec) (vector-ref vec 0)) -(define (tasks:hostinfo-get-interface vec) (vector-ref vec 1)) -(define (tasks:hostinfo-get-port vec) (vector-ref vec 2)) -(define (tasks:hostinfo-get-pubport vec) (vector-ref vec 3)) -(define (tasks:hostinfo-get-transport vec) (vector-ref vec 4)) -(define (tasks:hostinfo-get-pid vec) (vector-ref vec 5)) -(define (tasks:hostinfo-get-hostname vec) (vector-ref vec 6)) +(define (tasks:hostinfo-get-id vec) (safe-vector-ref vec 0)) +(define (tasks:hostinfo-get-interface vec) (safe-vector-ref vec 1)) +(define (tasks:hostinfo-get-port vec) (safe-vector-ref vec 2)) +(define (tasks:hostinfo-get-pubport vec) (safe-vector-ref vec 3)) +(define (tasks:hostinfo-get-transport vec) (safe-vector-ref vec 4)) +(define (tasks:hostinfo-get-pid vec) (safe-vector-ref vec 5)) +(define (tasks:hostinfo-get-hostname vec) (safe-vector-ref vec 6)) (define (tasks:server-lock-slot mdb run-id) (tasks:server-clean-out-old-records-for-run-id mdb run-id " tasks:server-lock-slot") (if (< (tasks:num-in-available-state mdb run-id) 4) (begin @@ -380,21 +380,21 @@ ;; try to start a server and wait for it to be available ;; (define (tasks:start-and-wait-for-server tdbdat run-id delay-max-tries) ;; ensure a server is running for this run - (let loop ((server-dat (tasks:get-server (db:delay-if-busy tdbdat) run-id)) + (let loop ((server-running (tasks:server-running? (db:delay-if-busy tdbdat) run-id)) (delay-time 0)) - (if (and (not server-dat) + (if (and (not server-running) (< delay-time delay-max-tries)) (begin (if (common:low-noise-print 60 "tasks:start-and-wait-for-server" run-id) (debug:print 0 "Try starting server for run-id " run-id)) (thread-sleep! (/ (random 2000) 1000)) (server:kind-run run-id) (thread-sleep! (min delay-time 1)) - (loop (tasks:get-server (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) + (loop (tasks:server-running? (db:delay-if-busy tdbdat) run-id)(+ delay-time 1)))))) (define (tasks:get-all-servers mdb) (let ((res '())) (sqlite3:for-each-row (lambda (id pid hostname interface port pubport start-time priority state mt-version last-update transport run-id) @@ -418,13 +418,13 @@ ;; (define (tasks:kill-server-run-id run-id #!key (tag "default")) (let* ((tdbdat (tasks:open-db)) (sdat (tasks:get-server (db:delay-if-busy tdbdat) run-id))) (if sdat - (let ((hostname (vector-ref sdat 6)) - (pid (vector-ref sdat 5)) - (server-id (vector-ref sdat 0))) + (let ((hostname (safe-vector-ref sdat 6)) + (pid (safe-vector-ref sdat 5)) + (server-id (safe-vector-ref sdat 0))) (tasks:server-set-state! (db:delay-if-busy tdbdat) server-id "killed") (debug:print-info 0 "Killing server " server-id " for run-id " run-id " on host " hostname " with pid " pid) (tasks:kill-server hostname pid) (tasks:server-delete-record (db:delay-if-busy tdbdat) server-id tag) ) (debug:print-info 0 "No server found for run-id " run-id ", nothing to kill")) @@ -546,14 +546,14 @@ runname testpatt (if params params ""))))) (define (keys:key-vals-hash->target keys key-params) - (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) + (let ((tmp (hash-table-ref/default key-params (safe-vector-ref (car keys) 0) ""))) (if (> (length keys) 1) (for-each (lambda (key) - (set! tmp (conc tmp "/" (hash-table-ref/default key-params (vector-ref key 0) "")))) + (set! tmp (conc tmp "/" (hash-table-ref/default key-params (safe-vector-ref key 0) "")))) (cdr keys))) tmp)) ;; for use from the gui, not ported ;; Index: tdb.scm ================================================================== --- tdb.scm +++ tdb.scm @@ -231,21 +231,21 @@ "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (vector-set! record 3 (if (equal? (safe-vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (vector-set! record 4 (let ((startt (any->number (safe-vector-ref record 1))) + (endt (any->number (safe-vector-ref record 2)))) + (debug:print 4 "record[1]=" (safe-vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -292,21 +292,21 @@ "\nstate: " (tdb:step-get-state step) "\nstatus: " (tdb:step-get-status step) "\ntime: " (tdb:step-get-event_time step)) (case (string->symbol (tdb:step-get-state step)) ((start)(vector-set! record 1 (tdb:step-get-event_time step)) - (vector-set! record 3 (if (equal? (vector-ref record 3) "") + (vector-set! record 3 (if (equal? (safe-vector-ref record 3) "") (tdb:step-get-status step))) (if (> (string-length (tdb:step-get-logfile step)) 0) (vector-set! record 5 (tdb:step-get-logfile step)))) ((end) (vector-set! record 2 (any->number (tdb:step-get-event_time step))) (vector-set! record 3 (tdb:step-get-status step)) - (vector-set! record 4 (let ((startt (any->number (vector-ref record 1))) - (endt (any->number (vector-ref record 2)))) - (debug:print 4 "record[1]=" (vector-ref record 1) + (vector-set! record 4 (let ((startt (any->number (safe-vector-ref record 1))) + (endt (any->number (safe-vector-ref record 2)))) + (debug:print 4 "record[1]=" (safe-vector-ref record 1) ", startt=" startt ", endt=" endt ", get-status: " (tdb:step-get-status step)) (if (and (number? startt)(number? endt)) (seconds->hr-min-sec (- endt startt)) "-1"))) (if (> (string-length (tdb:step-get-logfile step)) @@ -337,28 +337,28 @@ ;; (define (tdb:get-compressed-steps comprsteps) ;; from tdb:get-steps-table (map (lambda (x) ;; take advantage of the \n on time->string (vector - (vector-ref x 0) - (let ((s (vector-ref x 1))) - (if (number? s)(seconds->time-string s) s)) - (let ((s (vector-ref x 2))) - (if (number? s)(seconds->time-string s) s)) - (vector-ref x 3) ;; status - (vector-ref x 4) - (vector-ref x 5))) ;; time delta + (safe-vector-ref x 0) + (let ((s (safe-vector-ref x 1))) + (if (number? s)(seconds->time-string s) s)) + (let ((s (safe-vector-ref x 2))) + (if (number? s)(seconds->time-string s) s)) + (safe-vector-ref x 3) ;; status + (safe-vector-ref x 4) + (safe-vector-ref x 5))) ;; time delta (sort (hash-table-values comprsteps) (lambda (a b) - (let ((time-a (vector-ref a 1)) - (time-b (vector-ref b 1))) + (let ((time-a (safe-vector-ref a 1)) + (time-b (safe-vector-ref b 1))) (if (and (number? time-a)(number? time-b)) (if (< time-a time-b) #t (if (eq? time-a time-b) - (stringSummary: " test-name "

Summary for " test-name "

")) (for-each (lambda (testrecord) - (let ((id (vector-ref testrecord 0)) - (itempath (vector-ref testrecord 1)) - (state (vector-ref testrecord 2)) - (status (vector-ref testrecord 3)) - (run_duration (vector-ref testrecord 4)) - (logf (vector-ref testrecord 5)) - (comment (vector-ref testrecord 6))) + (let ((id (safe-vector-ref testrecord 0)) + (itempath (safe-vector-ref testrecord 1)) + (state (safe-vector-ref testrecord 2)) + (status (safe-vector-ref testrecord 3)) + (run_duration (safe-vector-ref testrecord 4)) + (logf (safe-vector-ref testrecord 5)) + (comment (safe-vector-ref testrecord 6))) (hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0))) (hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0))) (set! outtxt (conc outtxt "" " " itempath "" "" state "" Index: zmq-transport.scm ================================================================== --- zmq-transport.scm +++ zmq-transport.scm @@ -61,12 +61,12 @@ ;;====================================================================== ;; S E R V E R ;;====================================================================== -(define-inline (zmqsock:get-pub dat)(vector-ref dat 0)) -(define-inline (zmqsock:get-pull dat)(vector-ref dat 1)) +(define-inline (zmqsock:get-pub dat)(safe-vector-ref dat 0)) +(define-inline (zmqsock:get-pull dat)(safe-vector-ref dat 1)) (define-inline (zmqsock:set-pub! dat s)(vector-set! dat s 0)) (define-inline (zmqsock:set-pull! dat s)(vector-set! dat s 0)) (define (zmq-transport:run hostn) (debug:print 2 "Attempting to start the server ...")