Megatest

Check-in [52c2bf27f4]
Login
Overview
Comment:Added rmt:get-servers-info, removed remote logging, misc other tweaks.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v2.0001
Files: files | file ages | folders
SHA1: 52c2bf27f4620c1b56fbc97d64fd58402f457243
User & Date: matt on 2022-01-30 20:12:23
Other Links: branch diff | manifest | tags
Context
2022-02-01
15:28
added (mytarget targ) parameter setting when we have a target argument check-in: 14210eec84 user: mmgraham tags: v2.0001
2022-01-30
20:12
Added rmt:get-servers-info, removed remote logging, misc other tweaks. check-in: 52c2bf27f4 user: matt tags: v2.0001
2022-01-27
18:46
Removed debug message check-in: 5c0b2c5dd4 user: mrwellan tags: v2.0001
Changes

Modified dashboard.scm from [eeb859c6bf] to [78bde266eb].

3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257


3258
3259
3260
3261
3262
3263
3264
			 (zeroth-point   (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
		     (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
				      (reverse
				       (sqlite3:fold-row
					(lambda (res t var val)
					  (cons (vector t var val) res))
					'() db all-dat-qrystr)))
		     (let ((zeropt (handle-exceptions
				    exn
				    #f
				    (sqlite3:first-row db all-dat-qrystr))))


		       (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
			   (hash-table-set! res-ht
					    fieldname
					    (cons
					     (apply vector tstart (cdr zeropt))						    
					     (hash-table-ref/default res-ht fieldname '())))))))
		 fields)







|
<
<
|
>
>







3247
3248
3249
3250
3251
3252
3253
3254


3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
			 (zeroth-point   (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1")))
		     (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr)))))
				      (reverse
				       (sqlite3:fold-row
					(lambda (res t var val)
					  (cons (vector t var val) res))
					'() db all-dat-qrystr)))
		     (let ((zeropt (condition-case 


				       (sqlite3:first-row db all-dat-qrystr)
				     (exn (busy)(db:generic-error-printout exn "ERROR: database " dbdef
                                     " is locked. Try copying to another location, remove original and copy back.")))))
		       (if zeropt ;; NOTE: Add zeropt to the beginning of the list as the list was reversed above.
			   (hash-table-set! res-ht
					    fieldname
					    (cons
					     (apply vector tstart (cdr zeropt))						    
					     (hash-table-ref/default res-ht fieldname '())))))))
		 fields)

Modified dbmod.scm from [351701514f] to [8c09a0af38].

1053
1054
1055
1056
1057
1058
1059

1060



1061
1062
1063
1064
1065
1066
1067
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))
	(tot-count   0))

    (for-each ;; table
     (lambda (tabledat)

       (db:sync-one-table fromdb todb tabledat last-update numrecs))



     tbls)

    (let* ((runtime      (- (current-milliseconds) start-time))
	   (should-print (or (debug:debug-mode 12)
			     (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
      (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
      (for-each 







>
|
>
>
>







1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))
	(tot-count   0))

    (for-each ;; table
     (lambda (tabledat)
       (condition-case
	   (db:sync-one-table fromdb todb tabledat last-update numrecs)
	 ;; if db is busy, take a break and try one more time
	 (exn (busy)(thread-sleep! 0.5)
	      (db:sync-one-table fromdb todb tabledat last-update numrecs))))
     tbls)

    (let* ((runtime      (- (current-milliseconds) start-time))
	   (should-print (or (debug:debug-mode 12)
			     (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate.
      (if should-print (debug:print 3 *default-log-port* "INFO: db sync, total run time " runtime " ms"))
      (for-each 
2412
2413
2414
2415
2416
2417
2418
2419
2420

2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (or (null? header) (not row))
      #f
      (let loop ((hed (car header))
                 (tal (cdr header))
                 (n   0))
        (if (equal? hed field)
            (handle-exceptions

             exn
             (begin
               (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
			    row " header=" header " field=" field ", exn=" exn)
               #f)
             (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))








|
|
>
|
<
|
|
|
<







2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426

2427
2428
2429

2430
2431
2432
2433
2434
2435
2436
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (or (null? header) (not row))
      #f
      (let loop ((hed (car header))
                 (tal (cdr header))
                 (n   0))
        (if (equal? hed field);;(condition-case (vector-ref #(1 2 3) 3)(exn (bounds)(print "out of bounds")))
            (condition-case
		(vector-ref row n)
	      (exn (bounds)

		   (debug:print 0 *default-log-port* "WARNING: attempt to read non-existant field, row="
				row " header=" header " field=" field ", exn=" exn)
		   #f))

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

4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
			    (begin
                              (handle-exceptions
                               exn
                               (begin
                                  (debug:print 0 *default-log-port*
                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
                                 res)
                              (string-substitute patt repl res))


                              )
			    (begin
                              (debug:print 0 *default-log-port*
                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
			      res))))
	    (if (null? tal)
		newr
		(loop (car tal)(cdr tal) newr)))))))







|
<
<
<







4848
4849
4850
4851
4852
4853
4854
4855



4856
4857
4858
4859
4860
4861
4862
			    (begin
                              (handle-exceptions
                               exn
                               (begin
                                  (debug:print 0 *default-log-port*
                                  "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl ", exn=" exn)
                                 res)
                              (string-substitute patt repl res)))



			    (begin
                              (debug:print 0 *default-log-port*
                               "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl)
			      res))))
	    (if (null? tal)
		newr
		(loop (car tal)(cdr tal) newr)))))))

Modified debugprint.scm from [d12dfb8eae] to [03faa79da0].

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
  (define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print (debug:timestamp) params)
	  (debug:handle-remote-logging params)
	  )))
  #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
  )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  (debug:handle-remote-logging (cons "ERROR: " params))
	  )))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res)
	  (debug:handle-remote-logging (cons "INFO: " params))
	  ))))

(define (debug:print-warn n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
	  (debug:handle-remote-logging (cons "WARN: " params))
	  ))))
)







|










|













|







|


124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
  (define (debug:print n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (or e (current-error-port))
	(lambda ()
	  ;; (if *logging*
	      ;; (db:log-event (apply conc params))
	  (apply print (debug:timestamp) params)
	  ;; (debug:handle-remote-logging params)
	  )))
  #t ;; only here to make remote stuff happy. It'd be nice to fix that ...
  )

(define (debug:print-error n e . params)
  ;; normal print
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  ;; (debug:handle-remote-logging (cons "ERROR: " params))
	  )))
  ;; pass important messages to stderr
  (if (and (eq? n 0)(not (eq? e (current-error-port)))) 
      (with-output-to-port (current-error-port)
	(lambda ()
	  (apply print "ERROR: " (debug:timestamp) params)
	  ))))

(define (debug:print-info n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "INFO: (" n ") "(debug:timestamp) params) ;; res)
	  ;; (debug:handle-remote-logging (cons "INFO: " params))
	  ))))

(define (debug:print-warn n e . params)
  (if (debug:debug-mode n)
      (with-output-to-port (if (port? e) e (current-error-port))
	(lambda ()
	  (apply print "WARN: (" n ") " (debug:timestamp) params) ;; res)
	  ;; (debug:handle-remote-logging (cons "WARN: " params))
	  ))))
)

Modified rmtmod.scm from [1b0587b637] to [6232f78f49].

1257
1258
1259
1260
1261
1262
1263



1264
1265
1266
1267
1268
1269
1270
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

;;======================================================================
;; S E R V E R
;; ======================================================================




;; (define (http-get-function fnkey)
;;   (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))

;;======================================================================
;; C L I E N T S
;;======================================================================








>
>
>







1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
      #f
      (conc "http://" (car hostport) ":" (cadr hostport))))

;;======================================================================
;; S E R V E R
;; ======================================================================

(define (rmt:get-servers-info apath)
  (rmt:send-receive 'get-servers-info #f `(,apath)))

;; (define (http-get-function fnkey)
;;   (hash-table-ref/default *http-functions* fnkey (lambda () "nothing here yet")))

;;======================================================================
;; C L I E N T S
;;======================================================================