@@ -19,344 +19,6 @@ ;;====================================================================== ;; (use trace) (use typed-records) -;; globals - modules that include this need these here -(define *logging* #f) -(define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!! -;; (define *toppath* #f) -(define *transport-type* 'http) - -#;(define (exec-fn fn . params) - (if (hash-table-exists? *functions* fn) - (apply (hash-table-ref *functions* fn) params) - (begin - (debug:print-error 0 "exec-fn " fn " not found") - #f))) - -#;(define (set-fn fn-name fn) - (hash-table-set! *functions* fn-name fn)) - -(include "altdb.scm") - - -;; Pulled from http-transport.scm - -(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-make-url vec) - (if (and (http-transport:server-dat-get-iface vec) - (http-transport:server-dat-get-port vec)) - (conc "http://" - (http-transport:server-dat-get-iface vec) - ":" - (http-transport:server-dat-get-port vec)) - #f)) - -(define (http-transport:server-dat-update-last-access vec) - (if (vector? vec) - (vector-set! vec 5 (current-seconds)) - (begin - (print-call-chain (current-error-port)) - (debug:print-error 0 (current-error-port) "call to http-transport:server-dat-update-last-access with non-vector!!")))) - -;;====================================================================== -;; -;;====================================================================== - - -;; allow these queries through without starting a server -;; -(define api:read-only-queries - '(get-key-val-pairs - get-var - get-keys - get-key-vals - test-toplevel-num-items - get-test-info-by-id - get-steps-info-by-id - get-data-info-by-id - test-get-rundir-from-test-id - get-count-tests-running-for-testname - get-count-tests-running - get-count-tests-running-in-jobgroup - get-previous-test-run-record - get-matching-previous-test-run-records - test-get-logfile-info - test-get-records-for-index-file - get-testinfo-state-status - test-get-top-process-pid - test-get-paths-matching-keynames-target-new - get-prereqs-not-met - get-count-tests-running-for-run-id - get-run-info - get-run-status - get-run-state - get-run-stats - get-run-times - get-targets - get-target - ;; register-run - get-tests-tags - get-test-times - get-tests-for-run - get-test-id - get-tests-for-runs-mindata - get-tests-for-run-mindata - get-run-name-from-id - get-runs - simple-get-runs - get-num-runs - get-runs-cnt-by-patt - get-all-run-ids - get-prev-run-ids - get-run-ids-matching-target - get-runs-by-patt - get-steps-data - get-steps-for-test - read-test-data - read-test-data* - login - tasks-get-last - testmeta-get-record - have-incompletes? - synchash-get - get-changed-record-ids - get-run-record-ids - get-not-completed-cnt)) - -(define api:write-queries - '( - get-keys-write ;; dummy "write" query to force server start - - ;; SERVERS - start-server - kill-server - - ;; TESTS - test-set-state-status-by-id - delete-test-records - delete-old-deleted-test-records - test-set-state-status - test-set-top-process-pid - set-state-status-and-roll-up-items - - update-pass-fail-counts - top-test-set-per-pf-counts ;; (db:top-test-set-per-pf-counts (db:get-db *db* 5) 5 "runfirst") - - ;; RUNS - register-run - set-tests-state-status - delete-run - lock/unlock-run - update-run-event_time - mark-incomplete - set-state-status-and-roll-up-run - ;; STEPS - teststep-set-status! - delete-steps-for-test - ;; TEST DATA - test-data-rollup - csv->test-data - - ;; MISC - sync-inmem->db - - ;; TESTMETA - testmeta-add-record - testmeta-update-field - - ;; TASKS - tasks-add - tasks-set-state-given-param-key - )) - -;;====================================================================== -;; ALLDATA -;;====================================================================== -;; -;; attempt to consolidate a bunch of global information into one struct to toss around -(defstruct alldat - ;; misc - (denoise (make-hash-table)) - (areapath #f) ;; i.e. toppath - (mtconfig #f) - (log-port #f) - (areadat #f) ;; i.e. runremote - (rmt-mutex (make-mutex)) - (db-sync-mutex (make-mutex)) - (db-with-db-mutex (make-mutex)) - (read-only-queries api:read-only-queries) - (write-queries api:write-queries) - (max-api-process-requests 0) - (api-process-request-count 0) - (db-keys #f) - (megatest-version "1.6536") - (megatest-fossil-hash #f) - - ;; database related - (tmppath #f) ;; tmp path for dbs - - ;; runremote fields - (hh-dat #f) ;; (exec-fn 'common:get-homehost)) ;; homehost record ( addr . hhflag ) - (server-url #f) ;; (if *toppath* (exec-fn 'server:check-if-running *toppath*))) ;; (server:check-if-running *toppath*) #f)) - (last-server-check 0) ;; last time we checked to see if the server was alive - (conndat #f) - (transport *transport-type*) - (server-timeout #f) ;; (exec-fn 'server:expiration-timeout)) - (force-server #f) - (ro-mode #f) - (ro-mode-checked #f) ;; flag that indicates we have checked for ro-mode - (ulex:conn #f) ;; ulex db conn is not exactly a db connector, more like a network connector - - ;; dbstruct - (tmpdb #f) - (dbstack #f) ;; stack for tmp db handles, do not initialize with a stack - (mtdb #f) - (refndb #f) - (homehost #f) ;; not used yet - (on-homehost #f) ;; not used yet - (read-only #f) - - ) - -(define *alldat* (make-alldat)) - -;; Some of these routines use: -;; -;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html -;; -;; Syntax for defining macros in a simple style similar to function definiton, -;; when there is a single pattern for the argument list and there are no keywords. -;; -;; (define-simple-syntax (name arg ...) body ...) -;; - -(define-syntax define-simple-syntax - (syntax-rules () - ((_ (name arg ...) body ...) - (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-syntax common:debug-handle-exceptions - (syntax-rules () - ((_ debug exn errstmt body ...) - (if debug - (begin body ...) - (handle-exceptions exn errstmt body ...))))) - -(define-syntax common:handle-exceptions - (syntax-rules () - ((_ exn errstmt body ...) - (begin body ...)))) - -;; (define handle-exceptions common:handle-exceptions) - -;; iup callbacks are not dumping the stack, this is a work-around -;; -(define-simple-syntax (debug:catch-and-dump proc procname) - (handle-exceptions - exn - (begin - (print-call-chain (current-error-port)) - (with-output-to-port (current-error-port) - (lambda () - (print ((condition-property-accessor 'exn 'message) exn)) - (print "Callback error in " procname) - (print "Full condition info:\n" (condition->list exn))))) - (proc))) - -;; Need a mutex protected way to get and set values -;; or use (define-simple-syntax ?? -;; -(define-inline (with-mutex mtx accessor record . val) - (mutex-lock! mtx) - (let ((res (apply accessor record val))) - (mutex-unlock! mtx) - res)) - -;; Brandon's debug printer shortcut (indulge me :) -;; (define *BB-process-starttime* (current-milliseconds)) -#;(define (BB> . in-args) - (let* ((stack (get-call-chain)) - (location "??")) - (for-each - (lambda (frame) - (let* ((this-loc (vector-ref frame 0)) - (temp (string-split (->string this-loc) " ")) - (this-func (if (and (list? temp) (> (length temp) 1)) (cadr temp) "???"))) - (if (equal? this-func "BB>") - (set! location this-loc)))) - stack) - (let* ((color-on "\x1b[1m") - (color-off "\x1b[0m") - (dp-args - (append - (list 0 *default-log-port* - (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) - in-args))) - (apply debug:print dp-args)))) - -;; (define *BBpp_custom_expanders_list* (make-hash-table)) - - - -;; register hash tables with BBpp. -#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: - (cons hash-table? hash-table->alist)) - -;; test name converter -#;(define (BBpp_custom_converter arg) - (let ((res #f)) - (for-each - (lambda (custom-type-name) - (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) - (custom-type-test (car custom-type-info)) - (custom-type-converter (cdr custom-type-info))) - (when (and (not res) (custom-type-test arg)) - (set! res (custom-type-converter arg))))) - (hash-table-keys *BBpp_custom_expanders_list*)) - (if res (BBpp_ res) arg))) - -#;(define (BBpp_ arg) - (cond - ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) - ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) - ((hash-table? arg) - (let ((al (hash-table->alist arg))) - (BBpp_ (cons HASH_TABLE: al)))) - ((null? arg) '()) - ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) - ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) - (else (BBpp_custom_converter arg)))) - -;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp -#;(define (BBpp arg) - (pp (BBpp_ arg))) - -;(use define-macro) -#;(define-syntax inspect - (syntax-rules () - [(_ x) - ;; (with-output-to-port (current-error-port) - (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) - ;; ) - ] - [(_ x y ...) (begin (inspect x) (inspect y ...))])) - - -;; if a value is printable (i.e. string or number) return the value -;; else return an empty string -(define-inline (printable val) - (if (or (number? val)(string? val)) val "")) - +;; moved to commonmod