Changes In Branch v1.90-fix-modes Excluding Merge-Ins
This is equivalent to a diff from 62a9a80b8c to cee15a9d94
|
2024-02-11
| ||
| 19:49 | convert to use proper interface lists check-in: bbac9c3682 user: matt tags: v1.90-proper-interface-lists | |
| 18:19 | Adding uses of .import files back Leaf check-in: cee15a9d94 user: matt tags: v1.90-fix-modes | |
| 16:41 | Moved remainder of configf into configfmod check-in: c2d750aad9 user: matt tags: v1.90-fix-modes | |
|
2024-02-09
| ||
| 19:26 | get nfs, /tmp modes working check-in: ddfaeac922 user: matt tags: v1.90-fix-modes | |
| 16:06 | put back (declare (uses runsmod.import)), enhanced assert message for mismatched server/runid check-in: 332b8fc90d user: mmgraham tags: v1.90 | |
|
2024-02-08
| ||
| 20:39 | Move test_records.scm into commonmod.scm. Disabled uses of runsmod.import in megatest.scm. check-in: 62a9a80b8c user: matt tags: v1.90 | |
| 19:47 | Load db and key _records from commonmod only check-in: b5319490ec user: matt tags: v1.90 | |
Modified Makefile from [a99dba9744] to [28690e5571].
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm common.o : mofiles/commonmod.o | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) : megatest-fossil-hash.scm mofiles/commonmod.o : mofiles/debugprint.o megatest-fossil-hash.scm common.o : mofiles/commonmod.o mofiles/configfmod.o : mofiles/commonmod.o configf-guts.scm # mofiles/dbmod.o : mofiles/configfmod.o # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm tests.o db.o launch.o runs.o dashboard-tests.o \ dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o \ |
| ︙ | ︙ |
Modified commonmod.scm from [f881f6b04a] to [5100c657f0].
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 2740 2741 |
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
)
| > > | 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 |
(conc megatest-version "-" (substring megatest-fossil-hash 0 4)))
(define (common:get-fields cfgdat)
(let ((fields (hash-table-ref/default cfgdat "fields" '())))
(map car fields)))
(define keys:config-get-fields common:get-fields)
)
|
Added configf-guts.scm version [b19d28d0fb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 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 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
;;======================================================================
;; Copyright 2006-2012, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;;======================================================================
;; Config file handling
;;======================================================================
;; (use regex regex-case matchable) ;; directory-utils)
;; (declare (unit configf))
;; (declare (uses process))
;; (declare (uses env))
;; (declare (uses keys))
;; (declare (uses debugprint))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))
;; (declare (uses common))
;; (declare (uses commonmod))
;; (declare (uses commonmod.import))
;; (declare (uses processmod))
;; (declare (uses processmod.import))
;; (declare (uses configfmod))
;; (declare (uses configfmod.import))
;; (declare (uses dbfile))
;; (declare (uses dbfile.import))
;; (declare (uses dbmod))
;; (declare (uses dbmod.import))
;; (declare (uses mtmod))
;; (declare (uses mtmod.import))
;; (declare (uses megatestmod))
;; (declare (uses megatestmod.import))
;;
;; (import commonmod
;; configfmod
;; processmod
;; (prefix mtargs args:)
;; debugprint
;; mtmod
;; )
;;
;; (include "common_records.scm")
(define configf:imports "(import commonmod configfmod processmod (prefix mtargs args:))")
(define (configf:process-line l ht allow-system #!key (linenum #f))
(let loop ((res l))
(if (string? res)
(let ((matchdat (string-search configf:var-expand-regex res)))
(if matchdat
(let* ((prestr (list-ref matchdat 1))
(cmdtype (list-ref matchdat 2)) ;; eval, system, shell, getenv
(cmd (list-ref matchdat 3))
(poststr (list-ref matchdat 4))
(result #f)
(start-time (current-seconds))
(cmdsym (string->symbol cmdtype))
(fullcmd (case cmdsym
((scheme scm) (conc "(lambda (ht)(begin " configf:imports cmd "))"))
((system) (conc "(lambda (ht)(configf:system ht \"" cmd "\"))"))
((shell sh) (conc "(lambda (ht)(string-translate (shell \"" cmd "\") \"\n\" \" \"))"))
((realpath rp)(conc "(lambda (ht)(common:nice-path \"" cmd "\"))"))
((getenv gv) (conc "(lambda (ht)(get-environment-variable \"" cmd "\"))"))
((mtrah) (conc "(lambda (ht)"
" (let ((extra \"" cmd "\"))"
" (conc (or *toppath* (get-environment-variable \"MT_RUN_AREA_HOME\"))"
" (if (string-null? extra) \"\" \"/\")"
" extra)))"))
((get g)
(match (string-split cmd)
((sect var)(conc "(lambda (ht)(configf:lookup ht \"" sect "\" \"" var "\"))"))
(else
(debug:print-error 0 *default-log-port* "#{get ...} used with only one parameter, \"" cmd "\", two needed.")
"(lambda (ht) #f)")))
((runconfigs-get rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
;; ((rget) (conc "(lambda (ht)(runconfigs-get ht \"" cmd "\"))"))
(else "(lambda (ht)(print \"ERROR\") \"ERROR\")"))))
;; (print "fullcmd=" fullcmd)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: failed to process config input \"" l "\", exn=" exn)
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
;; (print "exn=" (condition->list exn))
(set! result (conc "#{( " cmdtype ") " cmd "}, full expansion: " fullcmd)))
(if (or allow-system
(not (member cmdtype '("system" "shell" "sh"))))
(with-input-from-string fullcmd
(lambda ()
(set! result ((eval (read)) ht))))
(set! result (conc "#{(" cmdtype ") " cmd "}"))))
(case cmdsym
((system shell scheme)
(let ((delta (- (current-seconds) start-time)))
(if (> delta 2)
(debug:print-info 2 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)
(debug:print-info 9 *default-log-port* "for line \"" l "\"\n command: " cmd " took " delta " seconds to run with output:\n " result)))))
(loop (conc prestr result poststr)))
res))
res)))
;; this was inline but I'm pretty sure that is a hold over from when it was *very* simple ...
;;
(define (configf:read-line p ht allow-processing settings)
(let loop ((inl (read-line p)))
(let ((cont-line (and (string? inl)
(not (string-null? inl))
(equal? "\\" (string-take-right inl 1)))))
(if cont-line ;; last character is \
(let ((nextl (read-line p)))
(if (not (eof-object? nextl))
(loop (string-append (if cont-line
(string-take inl (- (string-length inl) 1))
inl)
nextl))))
(let ((res (case allow-processing ;; if (and allow-processing
;; (not (eq? allow-processing 'return-string)))
((#t #f)
(configf:process-line inl ht allow-processing))
((return-string)
inl)
(else
(configf:process-line inl ht allow-processing)))))
(if (and (string? res) ;; must set to "no" to force NOT trimming trailing spaces
(not (equal? (hash-table-ref/default settings "trim-trailing-spaces" "yes") "no")))
(string-substitute "\\s+$" "" res)
res))))))
;; read a config file, returns hash table of alists
;; read a config file, returns hash table of alists
;; adds to ht if given (must be #f otherwise)
;; allow-system:
;; #f - do not evaluate [system
;; #t - immediately evaluate [system and store result as string
;; 'return-procs -- return a proc taking ht as an argument that may be evaulated at some future time
;; 'return-string -- return a string representing a proc taking ht as an argument that may be evaulated at some future time
;; envion-patt is a regex spec that identifies sections that will be eval'd
;; in the environment on the fly
;; sections: #f => get all, else list of sections to gather
;; post-section-procs alist of section-pattern => proc, where: (proc section-name next-section-name ht curr-path)
;; apply-wildcards: #t/#f - apply vars from targets with % wildcards to all matching sections
;;
(define (read-config path ht allow-system #!key (environ-patt #f) (curr-section #f)
(sections #f) (settings (make-hash-table)) (keep-filenames #f)
(post-section-procs '()) (apply-wildcards #t) )
(debug:print 9 *default-log-port* "START: " path)
;; (if *configdat*
;; (common:save-pkt `((action . read-config)
;; (f . ,(cond ((string? path) path)
;; ((port? path) "port")
;; (else (conc path))))
;; (T . configf))
;; *configdat* #t add-only: #t))
(if (and (not (port? path))
(not (common:file-exists? path))) ;; for case where we are handed a port
(begin
(debug:print-info 1 *default-log-port* "read-config - file not found " path " current path: " (current-directory))
;; WARNING: This is a risky change but really, we should not return an empty hash table if no file read?
#f) ;; (if (not ht)(make-hash-table) ht))
(let ((inp (if (string? path)
(open-input-file path)
path)) ;; we can be handed a port
(res (if (not ht)(make-hash-table) ht))
(metapath (if (or (debug:debug-mode 9)
keep-filenames)
path #f))
(process-wildcards (lambda (res curr-section-name)
(if (and apply-wildcards
(or (string-contains curr-section-name "%") ;; wildcard
(string-match "/.*/" curr-section-name))) ;; regex
(begin
(configf:apply-wildcards res curr-section-name)
(hash-table-delete! res curr-section-name)))))) ;; NOTE: if the section is a wild card it will be REMOVED from res
(let loop ((inl (configf:read-line inp res (calc-allow-system allow-system curr-section sections) settings)) ;; (read-line inp))
(curr-section-name (if curr-section curr-section "default"))
(var-flag #f);; turn on for key-var-pr and cont-ln-rx, turn off elsewhere
(lead #f))
(debug:print-info 8 *default-log-port* "curr-section-name: " curr-section-name " var-flag: " var-flag "\n inl: \"" inl "\"")
(if (eof-object? inl)
(begin
;; process last section for wildcards
(process-wildcards res curr-section-name)
(if (string? path) ;; we received a path, not a port, thus we are responsible for closing it.
(close-input-port inp))
(if (list? sections) ;; delete all sections except given when sections is provided
(for-each
(lambda (section)
(if (not (member section sections))
(hash-table-delete! res section))) ;; we are using "" as a dumping ground and must remove it before returning the ht
(hash-table-keys res)))
(debug:print 9 *default-log-port* "END: " path)
res
) ;; retval
(regex-case
inl
(configf:comment-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f))
(configf:blank-l-rx _ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f))
(configf:settings ( x setting val )
(begin
(hash-table-set! settings setting val)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f)))
(configf:include-rx ( x include-file )
(let* ((curr-conf-dir (pathname-directory path))
(full-conf (if (and (absolute-pathname? include-file) (file-exists? include-file))
include-file
(common:nice-path
(conc (if curr-conf-dir
curr-conf-dir
".")
"/" include-file)))))
(let ((all-matches (sort (handle-exceptions exn
(begin
(debug:print '(2 9) *default-log-port* "glob of " full-conf " gave no match. , exn=" exn)
(list))
(glob full-conf)) string<=?)))
(if (null? all-matches)
(begin
(debug:print '(2 9) #f "INFO: include file(s) matching " include-file " not found (called from " path ")")
(debug:print 2 *default-log-port* " " full-conf))
(for-each
(lambda (fpath)
;; (push-directory conf-dir)
(debug:print 9 *default-log-port* "Including: " full-conf)
(read-config fpath res allow-system environ-patt: environ-patt
curr-section: curr-section-name sections: sections settings: settings
keep-filenames: keep-filenames))
all-matches))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name #f #f))))
(configf:script-rx ( x include-script params);; handle-exceptions
;; exn
;; (begin
;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.")
;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(if (and (common:file-exists? include-script)(file-execute-access? include-script))
(let* ((local-allow-system (calc-allow-system allow-system curr-section-name sections))
(env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
(new-inp-port
(common:with-env-vars
env-delta
(lambda ()
(open-input-pipe (conc include-script " " params))))))
(debug:print '(2 9) *default-log-port* "Including from script output: " include-script)
;; (print "We got here, calling read-config next. Port is: " new-inp-port)
(read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames)
(close-input-port new-inp-port)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(begin
(debug:print 0 *default-log-port* "Script not found or not exectutable: " include-script)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)))
) ;; )
(configf:section-rx ( x section-name )
(begin
;; call post-section-procs
(for-each
(lambda (dat)
(let ((patt (car dat))
(proc (cdr dat)))
(if (string-match patt curr-section-name)
(proc curr-section-name section-name res path))))
post-section-procs)
;; after gathering the vars for a section and if apply-wildcards is true and if there is a wildcard in the section name process wildcards
;; NOTE: we are processing the curr-section-name, NOT section-name.
(process-wildcards res curr-section-name)
(if (not (hash-table-ref/default res section-name #f))(hash-table-set! res section-name '())) ;; ensure that mere mention of a section is not lost
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings)
;; if we have the sections list then force all settings into "" and delete it later?
;; (if (or (not sections)
;; (member section-name sections))
;; section-name "") ;; stick everything into "". NOPE: We need new strategy. Put stuff in correct sections and then delete all sections later.
section-name
#f #f)))
(configf:key-sys-pr ( x key cmd )
(if (calc-allow-system allow-system curr-section-name sections)
(let ((alist (hash-table-ref/default res curr-section-name '()))
(val-proc (lambda ()
(let* ((start-time (current-seconds))
(local-allow-system (calc-allow-system allow-system curr-section-name sections))
(env-delta (configf:cfgdat->env-alist curr-section-name res local-allow-system))
(cmdres (process:cmd-run->list cmd delta-env-alist-or-hash-table: env-delta)) ;; BB: here is where [system is exec'd. needs to have env from other vars!
(delta (- (current-seconds) start-time))
(status (cadr cmdres))
(res (car cmdres)))
(debug:print-info 4 *default-log-port* "" inl "\n => " (string-intersperse res "\n"))
(if (not (eq? status 0))
(begin
(debug:print-error 0 *default-log-port* "problem with " inl ", return code " status
" output: " cmdres)))
(if (> delta 2)
(debug:print-info 0 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res)
(debug:print-info 9 *default-log-port* "for line \"" inl "\"\n command: " cmd " took " delta " seconds to run with output:\n " res))
(if (null? res)
""
(string-intersperse res " "))))))
(hash-table-set! res curr-section-name
(configf:assoc-safe-add alist
key
(case (calc-allow-system allow-system curr-section-name sections)
((return-procs) val-proc)
((return-string) cmd)
(else (val-proc)))
metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))
(loop (configf:read-line inp res
(calc-allow-system allow-system curr-section-name sections)
settings)
curr-section-name #f #f)))
(configf:key-no-val ( x key val)
(let* ((alist (hash-table-ref/default res curr-section-name '()))
(fval (or (if (string? val) val #f) ""))) ;; fval should be either "" or " " (one or more spaces)
(debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = #t")
(safe-setenv key fval)
(hash-table-set! res curr-section-name
(configf:assoc-safe-add alist key fval metadata: metapath))
(loop (configf:read-line inp res
(calc-allow-system allow-system curr-section-name sections)
settings)
curr-section-name key #f)))
(configf:key-val-pr ( x key unk1 val unk2 )
(let* ((alist (hash-table-ref/default res curr-section-name '()))
(envar (and environ-patt
(string-search (regexp environ-patt) curr-section-name) ;; does the section match the envionpatt?
(and (not (string-null? key))
(not (equal? "!" (substring key 0 1)))) ;; ! as leading character is a signature to NOT export to the environment
;; (string-match "^.*:.*:.*$" key) ;; ;; something:something:something reserved for triggers in runconfigs
))
(realval (if envar
(configf:eval-string-in-environment val)
val)))
(debug:print-info 6 *default-log-port* "read-config env setting, envar: " envar " realval: " realval " val: " val " key: " key " curr-section-name: " curr-section-name)
(if envar (safe-setenv key realval))
(debug:print 10 *default-log-port* " setting: [" curr-section-name "] " key " = " val)
(hash-table-set! res curr-section-name
(configf:assoc-safe-add alist key realval metadata: metapath))
(loop (configf:read-line inp res
(calc-allow-system allow-system curr-section-name sections) settings)
curr-section-name key #f)))
;; if a continued line
(configf:cont-ln-rx ( x whsp val )
(let ((alist (hash-table-ref/default res curr-section-name '())))
(if var-flag ;; if set to a string then we have a continued var
(let ((newval (conc
(configf:lookup res curr-section-name var-flag) "\n"
;; trim lead from the incoming whsp to support some indenting.
(if lead
(string-substitute (regexp lead) "" whsp)
"")
val)))
;; (print "val: " val "\nnewval: \"" newval "\"\nvarflag: " var-flag)
(hash-table-set! res curr-section-name
(configf:assoc-safe-add alist var-flag newval metadata: metapath))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name var-flag (if lead lead whsp)))
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
(else (debug:print-error 0 *default-log-port* "problem parsing " path ",\n \"" inl "\"")
(set! var-flag #f)
(loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))
) ;; end loop
)))
(define (setup)
(let* ((configf (find-config "megatest.config"))
(config (if configf (read-config configf #f #t) #f)))
(if config
(setenv "RUN_AREA_HOME" (pathname-directory configf)))
config))
;;======================================================================
;; refdb
;;======================================================================
;; reads a refdb into an assoc array of assoc arrays
;; returns (list dat msg)
(define (configf:read-refdb refdb-path)
(let ((sheets-file (conc refdb-path "/sheet-names.cfg")))
(if (not (common:file-exists? sheets-file))
(list #f (conc "ERROR: no refdb found at " refdb-path))
(if (not (file-read-access? sheets-file))
(list #f (conc "ERROR: refdb file not readable at " refdb-path))
(let* ((sheets (with-input-from-file sheets-file
(lambda ()
(let loop ((inl (read-line))
(res '()))
(if (eof-object? inl)
(reverse res)
(loop (read-line)(cons inl res)))))))
(data '()))
(for-each
(lambda (sheet-name)
(let* ((dat-path (conc refdb-path "/" sheet-name ".dat"))
(ref-dat (configf:read-file dat-path #f #t))
(ref-assoc (map (lambda (key)
(list key (hash-table-ref ref-dat key)))
(hash-table-keys ref-dat))))
;; (hash-table->alist ref-dat)))
;; (set! data (append data (list (list sheet-name ref-assoc))))))
(set! data (cons (list sheet-name ref-assoc) data))))
sheets)
(list data "NO ERRORS"))))))
;; redefines
(define config-lookup configf:lookup)
(define configf:read-file read-config)
|
Modified configf.scm from [dd2b198b96] to [59af4a3967].
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | (declare (uses configfmod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) (declare (uses mtmod)) (declare (uses mtmod.import)) | | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | (declare (uses configfmod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) (declare (uses dbmod.import)) (declare (uses mtmod)) (declare (uses mtmod.import)) (declare (uses megatestmod)) (declare (uses megatestmod.import)) ;; (include "configf-guts.scm") ;; (define shell configfmod#shell) ;; (print (runconfigs-get *configdat* "testing")) |
Modified configfmod.scm from [0fff6fff93] to [8c4c9bcd5b].
| ︙ | ︙ | |||
471 472 473 474 475 476 477 478 479 480 |
(if toppath (change-directory toppath))
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
)
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
(if toppath (change-directory toppath))
(if (and toppath pathenvvar)(setenv pathenvvar toppath))
(let ((configdat (if configfile
(read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
(if toppath (change-directory curr-dir))
(list configdat toppath configfile fname))))
;;======================================================================
;; Lookup a value in runconfigs based on -reqtarg or -target
;;
(define (runconfigs-get config var)
(let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET"))))
(if targ
(or (configf:lookup config targ var)
(configf:lookup config "default" var))
(configf:lookup config "default" var))))
(define (common:args-get-target #!key (split #f)(exit-if-bad #f))
(let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '()))
(numkeys (length keys))
(target (or (args:get-arg "-reqtarg")
(args:get-arg "-target")
(getenv "MT_TARGET")))
(tlist (if target (string-split target "/" #t) '()))
(valid (if target
(or (null? keys) ;; probably don't know our keys yet
(and (not (null? tlist))
(eq? numkeys (length tlist))
(null? (filter string-null? tlist))))
#f)))
(if valid
(if split
tlist
target)
(if target
(begin
(debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements")
(if exit-if-bad (exit 1))
#f)
#f))))
(include "configf-guts.scm")
)
|
Modified configure from [08e182d3ee] to [442cd4def2].
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Megatest. If not, see <http://www.gnu.org/licenses/>.
# # Configure the build
#
# if [[ "$1"x == "x" ]];then
# PREFIX=$PWD
# else
# PREFIX=$1
# fi
#
#
# #======================================================================
# # Configure stuff needed for eggs
# #======================================================================
#
# function configure_dependencies () {
#
# #======================================================================
# # libnanomsg
# #======================================================================
#
# if [[ ! $(ls /usr/lib/*/libnanomsg*) ]];then
# echo "libnanomsg build needed."
# echo "BUILD_NANOMSG=yes" >> makefile.inc
# fi
#
# #======================================================================
# # postgresql libraries
# #======================================================================
#
# if [[ ! $(ls /usr/lib/*/libpq.*) ]];then
# echo "Postgresql build needed."
# echo "BUILD_POSTGRES=yes" >> makefile.inc
# fi
#
# if [[ ! $(ls /usr/lib/*/libsqlite3.*) ]];then
# echo "Sqlite3 build needed."
# echo "BUILD_SQLITE3=yes" >> makefile.inc
# fi
#
# }
#
# #======================================================================
# # Initialize makefile.inc
# #======================================================================
#
# echo "" > makefile.inc
#
# #======================================================================
# # Do we need Chicken?
# #======================================================================
#
# if [[ -e /usr/bin/sw_vers ]]; then
# ARCHSTR=$(/usr/bin/sw_vers -productVersion)
# else
# ARCHSTR=$(lsb_release -sr)
# fi
#
# echo "CHICKEN_PREFIX=$PREFIX/.$ARCHSTR" >> makefile.inc
# CHICKEN_PREFIX=$PREFIX/bin/.$ARCHSTR
#
# if [[ ! $(type csi) ]];then
# echo "Chicken build needed."
# echo "BUILD_CHICKEN=yes" >> makefile.inc
# configure_dependencies
# echo "include chicken.makefile" >> makefile.inc
# else
# echo "CSIPATH=$(which csi)" >> makefile.inc
# CSIPATH=$(which csi)
# echo "CKPATH=$(dirname $(dirname $CSIPATH))" >> makefile.inc
# fi
#
# # Make setup scripts
# echo "#!/bin/bash" > setup.sh
# echo "export PATH=$CHICKEN_PREFIX/bin:\$PATH" >> setup.sh
# echo "export LD_LIBRARY_PATH=$CHICKEN_PREFIX/lib" >> setup.sh
# echo 'exec "$@"' >> setup.sh
# chmod a+x setup.sh
#
# echo "setenv PATH $CHICKEN_PREFIX/bin:\$PATH" > setup.csh
# echo "setenv LD_LIBRARY_PATH $CHICKEN_PREFIX/lib" >> setup.csh
#
# echo "All done creating makefile.inc, feel free to edit it!"
# echo "run \"setup.sh bash\" or source setup.csh to get PATH and LD_LIBRARY_PATH adjusted"
#
|
Modified dashboard-transport-mode.scm from [2cfd93429c] to [d999443292].
1 2 3 4 5 6 7 8 9 10 11 12 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp or 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp or cachedb | > > > | | | | | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp or 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; 'auto ;; read-only query and no servers started - mrah/ ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp or cachedb (dbfile:sync-method 'none) (dbfile:cache-method 'none) (rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp and cachedb ;; (dbfile:sync-method 'none) ;; original was causing crash on start. ;; (dbfile:cache-method 'none) ;; (rmt:transport-mode 'tcp) |
Modified megatest.scm from [32535e1bcd] to [faeb3396e2].
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) ;; (declare (uses margs)) (declare (uses mtargs)) | | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (declare (uses common)) ;; (declare (uses megatest-version)) ;; (declare (uses margs)) (declare (uses mtargs)) ;; (declare (uses mtargs.import)) (declare (uses debugprint)) (declare (uses debugprint.import)) (declare (uses cookie)) (declare (uses cookie.import)) (declare (uses stml2)) (declare (uses stml2.import)) (declare (uses commonmod)) (declare (uses commonmod.import)) (declare (uses processmod)) (declare (uses processmod.import)) (declare (uses configfmod)) (declare (uses configfmod.import)) (declare (uses pgdb)) ;; (declare (uses pgdb.import)) (declare (uses mtmod)) (declare (uses mtmod.import)) (declare (uses servermod)) (declare (uses servermod.import)) (declare (uses dbfile)) (declare (uses dbfile.import)) (declare (uses dbmod)) |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | (declare (uses megatestmod)) (declare (uses megatestmod.import)) (declare (uses apimod)) (declare (uses apimod.import)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) (declare (uses tasksmod)) | | | | | | > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | (declare (uses megatestmod)) (declare (uses megatestmod.import)) (declare (uses apimod)) (declare (uses apimod.import)) (declare (uses rmtmod)) (declare (uses rmtmod.import)) (declare (uses tasksmod)) ;; (declare (uses tasksmod.import)) (declare (uses testsmod)) ;; (declare (uses testsmod.import)) (declare (uses subrunmod)) ;; (declare (uses subrunmod.import)) (declare (uses archivemod)) ;; (declare (uses archivemod.import)) (declare (uses runsmod)) ;; (declare (uses runsmod.import)) (declare (uses cpumod)) ;; (declare (uses cpumod.import)) (declare (uses runsmod)) (declare (uses ezstepsmod)) (declare (uses launchmod)) (declare (uses tdb)) (declare (uses mt)) (declare (uses api)) (declare (uses env)) (declare (uses diff-report)) (declare (uses runs)) (declare (uses launch)) (declare (uses server)) (declare (uses genexample)) ;; (include "debugmode.scm") ;; (declare (uses daemon)) ;; (declare (uses dcommon)) ;; (declare (uses debugprint)) ;; (declare (uses debugprint.import)) |
| ︙ | ︙ | |||
1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 |
(api:queue-processor)
(thread-start! (make-thread api:print-db-stats "print-db-stats"))
(if dbfname
(tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
(begin
(debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
(exit 1)))))
(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
(set! *didsomething* #t)))
;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
| > | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
(api:queue-processor)
(thread-start! (make-thread api:print-db-stats "print-db-stats"))
(if dbfname
(tt:start-server tl #f dbfname api:tcp-dispatch-request-make-handler keys)
(begin
(debug:print 0 *default-log-port* "ERROR: transport mode is tcp - -db is required.")
(exit 1)))))
((nfs)(debug:print 0 *default-log-port* "WARNING: server start called in nfs mode '"(rmt:transport-mode)))
(else (debug:print 0 *default-log-port* "ERROR: rmt:transport-mode value not recognised "(rmt:transport-mode))))
(set! *didsomething* #t)))
;; The adjutant is a bit different, it does NOT run (launch:setup) as it is not necessarily tied to
;; a specific Megatest area. Detail are being hashed out and this may change.
;;
(if (args:get-arg "-adjutant")
|
| ︙ | ︙ |
Modified megatestmod.scm from [62734f55ba] to [a70a654362].
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
| < < < < < < < < < < < < < < < < < < < < < < < < | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
(define (common:args-get-runname)
(let ((res (or (args:get-arg "-runname")
(args:get-arg ":runname")
(getenv "MT_RUNNAME"))))
;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ...
res))
;;======================================================================
;; looking only (at least for now) at the MT_ variables craft the full testname
;;
(define (common:get-full-test-name)
(if (getenv "MT_TEST_NAME")
(if (and (getenv "MT_ITEMPATH")
(not (equal? (getenv "MT_ITEMPATH") "")))
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 |
(if (not (file-exists? pktsdir))
(create-directory pktsdir #t))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))))))))
| < < < < < < < < < < | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
(if (not (file-exists? pktsdir))
(create-directory pktsdir #t))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))))))))
;;======================================================================
;; R U N S
;;======================================================================
;; set tests with state currstate and status currstatus to newstate and newstatus
;; use currstate = #f and or currstatus = #f to apply to any state or status respectively
;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below
|
| ︙ | ︙ |
Modified rmtmod.scm from [08616bdb4f] to [f16c2416fe].
| ︙ | ︙ | |||
948 949 950 951 952 953 954 | (begin (debug:print-info 0 *default-log-port* "hh-dat="hh-dat) #f))) #f))) ;; not true strickly speaking, might be runremote was not yet initialized. (define (make-and-init-remote areapath) (case (rmt:transport-mode) | < | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 |
(begin
(debug:print-info 0 *default-log-port* "hh-dat="hh-dat)
#f)))
#f))) ;; not true strickly speaking, might be runremote was not yet initialized.
(define (make-and-init-remote areapath)
(case (rmt:transport-mode)
((tcp) (tt:make-remote areapath))
(else #f)))
;; how to make area-dat
(define (rmt:set-ttdat areapath ttdat)
(if ttdat
ttdat
|
| ︙ | ︙ |
Modified runsmod.scm from [98c156694e] to [251bedfaeb].
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 | (lambda () ;; jobtools maxload is useful for where the full Megatest run is done on one machine (if (and (not (rmt:on-homehost?)) maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized (common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f)) ;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues | | | > | > | 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 |
(lambda ()
;; jobtools maxload is useful for where the full Megatest run is done on one machine
(if (and (not (rmt:on-homehost?))
maxload) ;; only gate if maxload is specified, NOTE: maxload is normalized, i.e. load=1 means all cpus fully utilized
(common:wait-for-normalized-load maxload "Waiting for load to drop before starting more tests" #f))
;; jobtools maxhomehostload is intended to prevent overloading on the homehost which can cause database corruption issues
;; (if maxhomehostload
;; (common:wait-for-homehost-load
;; maxhomehostload
;; (conc "Waiting for homehost load to drop below normalized value of " maxhomehostload)))
)))
(if (and (not (null? prereqs-not-met))
(runs:lownoise (conc "waiting on tests " prereqs-not-met hed) 60))
(debug:print-info 2 *default-log-port* "waiting on tests; " (string-intersperse (runs:mixed-list-testname-and-testrec->list-of-strings prereqs-not-met) ", ")))
|
| ︙ | ︙ |
Modified servermod.scm from [cbd4da6b54] to [5384b281b4].
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | ;; check the .servinfo directory, are there other servers running on this ;; or another host? ;; ;; returns #t => ok to start another server ;; #f => not ok to start another server ;; | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | < < > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
;; check the .servinfo directory, are there other servers running on this
;; or another host?
;;
;; returns #t => ok to start another server
;; #f => not ok to start another server
;;
;; (define (server:minimal-check areapath)
;; (server:clean-up-old areapath)
;; (let* ((srvdir (server:get-servinfo-dir areapath)) ;; (conc areapath"/.servinfo"))
;; (servrs (glob (conc srvdir"/*")))
;; (thishostip (server:get-best-guess-address (get-host-name)))
;; (thisservrs (glob (conc srvdir"/"thishostip":*")))
;; (homehostinf (server:choose-server areapath 'homehost))
;; (havehome (car homehostinf))
;; (wearehome (cdr homehostinf)))
;; (debug:print-info 0 *default-log-port* thishostip", have homehost: "havehome", we are homehost: "wearehome
;; ", numservers: "(length thisservrs))
;; (cond
;; ((not havehome) #t) ;; no homehost yet, go for it
;; ((and havehome wearehome (< (length thisservrs) 20)) #t) ;; we are home and less than 20 servers, ok to start another
;; ((and havehome (not wearehome)) #f) ;; we are not the home host
;; ((and havehome wearehome (>= (length thisservrs) 20)) #f) ;; have enough running
;; (else
;; (debug:print 0 *default-log-port* "WARNING: Unrecognised scenario, servrs="servrs", thishostip="thishostip", thisservrs="thisservrs)
;; #t))))
(define server-last-start 0)
;; oldest server alive determines host then choose random of youngest
;; five servers on that host
;;
;; mode:
;; best - get best server (random of newest five)
;; home - get home host based on oldest server
;; info - print info
;; (define (server:choose-server areapath #!optional (mode 'best))
;; ;; age is current-starttime
;; ;; find oldest alive
;; ;; 1. sort by age ascending and ping until good
;; ;; find alive rand from youngest
;; ;; 1. sort by age descending
;; ;; 2. take five
;; ;; 3. check alive, discard if not and repeat
;; ;; first we clean up old server files
;; (assert (eq? (rmt:transport-mode) 'http) "FATAL: server:run called with rmt:transport-mode="(rmt:transport-mode))
;; (server:clean-up-old areapath)
;; (let* ((since-last (- (current-seconds) server-last-start))
;; (server-start-delay 10))
;; (if ( < (- (current-seconds) server-last-start) 10 )
;; (begin
;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; (debug:print 2 *default-log-port* "server:choose-server: last server start less than " server-start-delay " seconds ago. Sleeping " server-start-delay " seconds")
;; (thread-sleep! server-start-delay)
;; )
;; (debug:print 2 *default-log-port* "server:choose-server: seconds since last server start: " (- (current-seconds) server-last-start))
;; )
;; )
;; (let* ((serversdat (server:get-servers-info areapath))
;; (servkeys (hash-table-keys serversdat))
;; (by-time-asc (if (not (null? servkeys)) ;; NOTE: Oldest is last
;; (sort servkeys ;; list of "host:port"
;; (lambda (a b)
;; (>= (list-ref (hash-table-ref serversdat a) 2)
;; (list-ref (hash-table-ref serversdat b) 2))))
;; '())))
;; (debug:print 2 *default-log-port* "server:choose-server: serversdat: " serversdat)
;; (debug:print 2 *default-log-port* "server:choose-server: servkeys: " servkeys)
;; (if (not (null? by-time-asc))
;; (let* ((oldest (last by-time-asc))
;; (oldest-dat (hash-table-ref serversdat oldest))
;; (host (list-ref oldest-dat 0))
;; (all-valid (filter (lambda (x)
;; (equal? host (list-ref (hash-table-ref serversdat x) 0)))
;; by-time-asc))
;; (best-ten (lambda ()
;; (if (> (length all-valid) 11)
;; (take (drop-right all-valid 1) 10) ;; remove the oldest from consideration so it can age out
;; (if (> (length all-valid) 8)
;; (drop-right all-valid 1)
;; all-valid))))
;; (names->dats (lambda (names)
;; (map (lambda (x)
;; (hash-table-ref serversdat x))
;; names)))
;; (am-home? (lambda ()
;; (let* ((currhost (get-host-name))
;; (bestadrs (server:get-best-guess-address currhost)))
;; (or (equal? host currhost)
;; (equal? host bestadrs))))))
;; (case mode
;; ((info)
;; (debug:print 0 *default-log-port* "oldest: "oldest-dat", selected host: "host", all-valid: "all-valid)
;; (debug:print 0 *default-log-port* "youngest: "(hash-table-ref serversdat (car all-valid))))
;; ((home) host)
;; ((homehost) (cons host (am-home?))) ;; shut up old code
;; ((home?) (am-home?))
;; ((best-ten)(names->dats (best-ten)))
;; ((all-valid)(names->dats all-valid))
;; ((best) (let* ((best-ten (best-ten))
;; (len (length best-ten)))
;; (hash-table-ref serversdat (list-ref best-ten (random len)))))
;; ((count)(length all-valid))
;; (else
;; (debug:print 0 *default-log-port* "ERROR: invalid command "mode)
;; #f)))
;; (begin
;; (server:run areapath)
;; (set! server-last-start (current-seconds))
;; ;; (thread-sleep! 3)
;; (case mode
;; ((homehost) (cons #f #f))
;; (else #f))))))
(define (server:get-servinfo-dir areapath)
(let* ((spath (conc areapath"/.servinfo")))
(if (not (file-exists? spath))
(create-directory spath #t))
spath))
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | ;; (defstruct remote ;; transport to be used ;; http - use http-transport ;; http-read-cached - use http-transport for writes but in-mem cached for reads (rmode 'http) | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 | ;; (defstruct remote ;; transport to be used ;; http - use http-transport ;; http-read-cached - use http-transport for writes but in-mem cached for reads (rmode 'http) (hh-dat (let ((res (or ;; (server:choose-server *toppath* 'homehost) (cons #f #f)))) (assert (pair? res)(conc "FATAL: hh-dat should be a pair, got "res)) res)) (server-url #f) ;; (server:check-if-running *toppath*) #f)) (server-id #f) (server-info #f) ;; (if *toppath* (server:check-if-running *toppath*) #f)) (last-server-check 0) ;; last time we checked to see if the server was alive |
| ︙ | ︙ |
Modified tasksmod.scm from [11086d3914] to [381a26e6c2].
| ︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 |
(debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
(exit 1)))))))
;;======================================================================
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
;; (exit 1))))
| | | | | | | | | | | | | | | | | | | 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 |
(debug:print 0 *default-log-port* " to switch versions you can run: \"megatest -cleanup-db\"")
(exit 1)))))))
;;======================================================================
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: cannot migrate version unless on homehost. Exiting.")
;; (exit 1))))
;; (define (common:wait-for-homehost-load maxnormload msg)
;; (let loop ((start-time (current-seconds))) ;; we saw some instances of this being called before *toppath* was set. This might be an early setup race. This delay should help but it is impossible to test...
;; (if (not *toppath*)
;; (begin
;; (debug:print 0 *default-log-port* "ERROR: common:wait-for-homehost-load called before *toppath* set.")
;; (thread-sleep! 30)
;; (if (< (- (current-seconds) start-time) 300)
;; (loop start-time)))))
;; (case (rmt:transport-mode)
;; ((http)
;; (let* ((hh-dat (if (rmt:on-homehost?) ;; if we are on the homehost then pass in #f so the calls are local.
;; #f
;; (server:choose-server *toppath* 'homehost)))
;; (hh (if hh-dat (car hh-dat) #f)))
;; (common:wait-for-normalized-load maxnormload msg hh)))
;; (else
;; (common:wait-for-normalized-load maxnormload msg (get-host-name)))))
(define (configf:write-alist cdat fname)
(if (not (common:faux-lock fname))
(debug:print 0 *default-log-port* "INFO: Could not get lock on " fname))
(let* ((dat (configf:config->alist cdat))
(res
|
| ︙ | ︙ |
Modified transport-mode.scm from [9dbf69644d] to [8c66537e82].
1 2 3 4 5 6 7 8 9 10 11 12 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;;====================================================================== ;; set up transport, db cache and sync methods ;; ;; sync-method: 'original, 'attach or 'none ;; cache-method: 'tmp 'none ;; rmt:transport-mode: 'http, 'tcp, 'nfs ;; ;; NOTE: NOT ALL COMBINATIONS WORK ;; ;;====================================================================== ;; uncomment this block to test without tcp (dbfile:sync-method 'none) (dbfile:cache-method 'none) (rmt:transport-mode 'nfs) ;; uncomment this block to test with tcp ;; (dbfile:sync-method 'attach) ;; attach) ;; original ;; (dbfile:cache-method 'tmp) ;; (rmt:transport-mode 'tcp) |