Index: Makefile
==================================================================
--- Makefile
+++ Makefile
@@ -165,5 +165,11 @@
deploytarg/dboard : $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
mv deploytarg/deploytarg deploytarg/dboard
+DATASHAREO=configf.o common.o process.o
+datashare-testing/datashare : datashare.scm $(DATASHAREO)
+ csc datashare.scm $(DATASHAREO) -o datashare-testing/datashare
+
+datashare : datashare-testing/datashare
+ ./datashare-testing/datashare
Index: common.scm
==================================================================
--- common.scm
+++ common.scm
@@ -366,21 +366,58 @@
(set! freespc newval))))))
(car df-results))
freespc))
(define (get-cpu-load)
- (let* ((load-res (cmd-run->list "uptime"))
- (load-rx (regexp "load average:\\s+(\\d+)"))
- (cpu-load #f))
- (for-each (lambda (l)
- (let ((match (string-search load-rx l)))
- (if match
- (let ((newval (string->number (cadr match))))
- (if (number? newval)
- (set! cpu-load newval))))))
- (car load-res))
- cpu-load))
+ (car (common:get-cpu-load)))
+;; (let* ((load-res (cmd-run->list "uptime"))
+;; (load-rx (regexp "load average:\\s+(\\d+)"))
+;; (cpu-load #f))
+;; (for-each (lambda (l)
+;; (let ((match (string-search load-rx l)))
+;; (if match
+;; (let ((newval (string->number (cadr match))))
+;; (if (number? newval)
+;; (set! cpu-load newval))))))
+;; (car load-res))
+;; cpu-load))
+
+;; get cpu load by reading from /proc/loadavg, return all three values
+;;
+(define (common:get-cpu-load)
+ (with-input-from-file "/proc/loadavg"
+ (lambda ()(list (read)(read)(read)))))
+
+(define (common:wait-for-cpuload maxload numcpus waitdelay #!key (count 1000))
+ (let* ((loadavg (common:get-cpu-load))
+ (first (car loadavg))
+ (next (cadr loadavg))
+ (adjload (* maxload numcpus))
+ (loadjmp (- first next)))
+ (cond
+ ((and (> first adjload)
+ (> count 0))
+ (debug:print-info 0 "waiting " waitdelay " seconds due to load " first " exceeding max of " adjload)
+ (thread-sleep! waitdelay)
+ (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1)))
+ ((and (> loadjmp numcpus)
+ (> count 0))
+ (debug:print-info 0 "waiting " waitdelay " seconds due to load jump " loadjmp " > numcpus " numcpus)
+ (thread-sleep! waitdelay)
+ (common:wait-for-cpuload maxload numcpus waitdelay count: (- count 1))))))
+
+(define (common:get-num-cpus)
+ (with-input-from-file "/proc/cpuinfo"
+ (lambda ()
+ (let loop ((numcpu 0)
+ (inl (read-line)))
+ (if (eof-object? inl)
+ numcpu
+ (loop (if (string-match "^processor\\s+:\\s+\\d+$" inl)
+ (+ numcpu 1)
+ numcpu)
+ (read-line)))))))
(define (get-uname . params)
(let* ((uname-res (cmd-run->list (conc "uname " (if (null? params) "-a" (car params)))))
(uname #f))
(if (null? (car uname-res))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -16,11 +16,10 @@
(use canvas-draw)
(import canvas-draw-iup)
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
-(use trace)
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
ADDED datashare-testing/.datashare.config
Index: datashare-testing/.datashare.config
==================================================================
--- /dev/null
+++ datashare-testing/.datashare.config
@@ -0,0 +1,19 @@
+# Read in the users vars first (so the offical data cannot be overridden
+[include datastore.config]
+
+[storagegroups]
+1 eng /tmp/datastore/eng
+
+[areas]
+synthesis asic/synthesis
+verilog asic/verilog
+oalibs custom/oalibs
+
+[target]
+basepath #{getenv BASEPATH}
+
+[quality]
+0 untested
+1 lightly tested
+2 tested
+3 full QA
ADDED datashare.scm
Index: datashare.scm
==================================================================
--- /dev/null
+++ datashare.scm
@@ -0,0 +1,219 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+(use ssax)
+(use sxml-serializer)
+(use sxml-modifications)
+(use regex)
+(use srfi-69)
+(use regex-case)
+(use posix)
+(use json)
+(use csv)
+(use srfi-18)
+(use format)
+
+(require-library iup)
+(import (prefix iup iup:))
+(require-library ini-file)
+(import (prefix ini-file ini:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import (prefix sqlite3 sqlite3:))
+
+(declare (uses configf))
+
+(include "megatest-fossil-hash.scm")
+
+;;
+;; GLOBALS
+;;
+(define *datashare:current-tab-number* 0)
+(define datashare:help (conc "Usage: datashare [action [params ...]]
+
+Note: run datashare without parameters to start the gui.
+
+ publish <area> <key> [group] : Publish data to share, use group to protect (i)
+ get <area> <key> [destpath] : Get a link to data, put the link in destpath (ii)
+ update <area> <key> : Update the link to data to the latest iteration.
+
+(i) Uses group ownership of files to be published for group if not specified
+(ii) Uses local path or looks up script to find path in configs
+
+Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+(define (datashare:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (sqlite3:execute db qry))
+ (list
+ "CREATE TABLE pkgs
+ (id INTEGER PRIMARY KEY,
+ area TEXT,
+ key TEXT,
+ iteration INTEGER,
+ submitter TEXT,
+ datetime TEXT,
+ storegrp TEXT,
+ datavol INTEGER,
+ quality TEXT,
+ disk_id INTEGER,
+ comment TEXT);"
+ "CREATE TABLE refs
+ (id INTEGER PRIMARY KEY,
+ pkg_id INTEGER,
+ destlink TEXT);"
+ "CREATE TABLE disks
+ (id INTEGER PRIMARY KEY,
+ storegrp TEXT,
+ path TEXT);")))
+
+;; Create the sqlite db
+(define (datashare:open-db path)
+ (if (and path
+ (directory? path)
+ (file-read-access? path))
+ (let* ((dbpath (conc path "/datashare.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath))
+ (handler (make-busy-timeout 136000)))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit))
+ (set! db (sqlite3:open-database dbpath)))
+ (if *db-write-access* (sqlite3:set-busy-handler! db handler))
+ (if (not dbexists)
+ (begin
+ (datashare:initialize-db db)))
+ db)))
+
+;;======================================================================
+;; GUI
+;;======================================================================
+
+;; The main menu
+(define (datashare:main-menu)
+ (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+ (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
+ (iup:menu-item "Open" action: (lambda (obj)
+ (iup:show (iup:file-dialog))
+ (print "File->open " obj)))
+ (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
+ (iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
+ (iup:menu-item "Tools" (iup:menu
+ (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+ ;; (iup:menu-item "Show dialog" #:action (lambda (obj)
+ ;; (show message-window
+ ;; #:modal? #t
+ ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+ ;; ;; #:x 'mouse
+ ;; ;; #:y 'mouse
+ ;; )
+ ))))
+
+(define (datashare:publish-view configdat)
+ (let* ((label-size "50x")
+ (areas-sel (iup:listbox #:expand "YES" #:dropdown "YES"))
+ (version-val (iup:textbox #:expand "YES" #:size "50x"))
+ (iteration (iup:textbox #:expand "YES" #:size "20x"))
+ (comment (iup:textbox #:expand "YES"))
+ (source-path (iup:textbox #:expand "YES"))
+ (browse-btn (iup:button "Browse"
+ #:size "40x"
+ #:action (lambda (obj)
+ (let* ((fd (iup:file-dialog #:dialogtype "DIR"))
+ (top (iup:show fd #:modal? "YES")))
+ (iup:attribute-set! source-path "VALUE"
+ (iup:attribute fd "VALUE"))
+ (iup:destroy! fd))))))
+ (iup:vbox
+ (iup:hbox (iup:label "Area:" #:size label-size) areas-sel)
+ (iup:hbox (iup:label "Version:" #:size label-size) version-val
+ (iup:label "Iteration:") iteration)
+ (iup:hbox (iup:label "Comment:" #:size label-size) comment)
+ (iup:hbox (iup:label "Source path:" #:size label-size) source-path browse-btn))))
+
+(define (datashare:get-view configdat)
+ (iup:vbox
+ (iup:hbox
+ (iup:button "Pushme"
+ #:expand "YES"
+ ))))
+
+(define (datashare:manage-view configdat)
+ (iup:vbox
+ (iup:hbox
+ (iup:button "Pushme"
+ #:expand "YES"
+ ))))
+
+(define (datashare:gui configdat)
+ (iup:show
+ (iup:dialog
+ #:title (conc "DataShare dashboard " (current-user-name) ":" (current-directory))
+ #:menu (datashare:main-menu)
+ (let* ((tabs (iup:tabs
+ #:tabchangepos-cb (lambda (obj curr prev)
+ (set! *datashare:current-tab-number* curr))
+ (datashare:publish-view configdat)
+ (datashare:get-view configdat)
+ (datashare:manage-view configdat)
+ )))
+ ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
+ (iup:attribute-set! tabs "TABTITLE0" "Publish")
+ (iup:attribute-set! tabs "TABTITLE1" "Get")
+ (iup:attribute-set! tabs "TABTITLE2" "Manage")
+ ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
+ tabs)))
+ (iup:main-loop))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (datashare:load-config path)
+ (let ((fname (conc path "/.datashare.config")))
+ (ini:property-separator-patt " * *")
+ (ini:property-separator #\space)
+ (if (file-exists? fname)
+ ;; (ini:read-ini fname)
+ (read-config fname #f #t)
+ (make-hash-table))))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (configdat (datashare:load-config (pathname-directory prog))))
+ (cond
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((help -h -help --h --help)
+ (print datashare:help))
+ (else
+ (print "ERROR: Unrecognised command. Try \"datashare help\""))))
+ ((null? rema)(datashare:gui configdat))
+ ((>= (length rema) 2)
+ (apply process-action (car rema)(cdr rema)))
+ (else (print "ERROR: Unrecognised command. Try \"datashare help\"")))))
+
+(main)
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -154,11 +154,11 @@
"INSERT OR IGNORE INTO tests (id,run_id,testname,event_time,item_path,state,status) VALUES (?,?,'bogustest',strftime('%s','now'),'nowherepath','DELETED','n/a');"
(* run-id 30000) ;; allow for up to 30k tests per run
run-id)
)) ;; add strings db to rundb, not in use yet
(sqlite3:set-busy-handler! db handler)
- (sqlite3:execute db "PRAGMA synchronous = 1;"))) ;; was 0 but 0 is a gamble
+ (sqlite3:execute db "PRAGMA synchronous = 0;"))) ;; was 0 but 0 is a gamble, changed back to 0
(dbr:dbstruct-set-rundb! dbstruct db)
(dbr:dbstruct-set-inuse! dbstruct #t)
(dbr:dbstruct-set-olddb! dbstruct olddb)
;; (dbr:dbstruct-set-run-id! dbstruct run-id)
(if local
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -199,11 +199,11 @@
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
-(define (runs:run-tests target runname test-patts user flags) ;; test-names
+(define (runs:run-tests target runname test-patts user flags #!key (run-count 3)) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
(keyvals (keys:target->keyval keys target))
(run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name)))
(deferred '()) ;; delay running these since they have a waiton clause
(runconfigf (conc *toppath* "/runconfigs.config"))
@@ -340,13 +340,23 @@
(debug:print-info 1 "Adding " required-tests " to the run queue"))
;; NOTE: these are all parent tests, items are not expanded yet.
(debug:print-info 4 "test-records=" (hash-table->alist test-records))
(let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
(if (> (length (hash-table-keys test-records)) 0)
- (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)
+ (begin
+ (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)
+ ;; if run-count > 0 call, set -preclean and -rerun STUCK/DEAD
+ (if (> run-count 0)
+ (begin
+ (if (not (hash-table-ref/default flags "-preclean" #f))
+ (hash-table-set! flags "-preclean" #t))
+ (if (not (hash-table-ref/default flags "-rerun" #f))
+ (hash-table-set! flags "-rerun" "STUCK/DEAD,n/a,ZERO_ITEMS"))
+ (runs:run-tests target runname test-patts user flags run-count: (- run-count 1)))))
(debug:print-info 0 "No tests to run")))
- (debug:print-info 4 "All done by here")))
+ (debug:print-info 4 "All done by here")
+ ))
;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
@@ -577,11 +587,15 @@
(job-group-limit (list-ref run-limits-info 4))
(prereqs-not-met (rmt:get-prereqs-not-met run-id waitons item-path testmode itemmap: itemmap))
;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap))
(fails (runs:calc-fails prereqs-not-met))
(non-completed (runs:calc-not-completed prereqs-not-met))
- (loop-list (list hed tal reg reruns)))
+ (loop-list (list hed tal reg reruns))
+ ;; configure the load runner
+ (numcpus (common:get-num-cpus))
+ (maxload (string->number (or (configf:lookup *configdat* "jobtools" "maxload") "3")))
+ (waitdelay (string->number (or (configf:lookup *configdat* "jobtools" "waitdelay") "60"))))
(debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: ("
(string-intersperse
(map (lambda (t)
(if (vector? t)
(conc (db:test-get-state t) "/" (db:test-get-status t))
@@ -676,10 +690,14 @@
(null? non-completed))))
;; (hash-table-delete! *max-tries-hash* (runs:make-full-test-name test-name item-path))
;; we are going to reset all the counters for test retries by setting a new hash table
;; this means they will increment only when nothing can be run
(set! *max-tries-hash* (make-hash-table))
+ ;; well, first lets see if cpu load throttling is enabled. If so wait around until the
+ ;; average cpu load is under the threshold before continuing
+ (if (configf:lookup *configdat* "jobtools" "maxload") ;; only gate if maxload is specified
+ (common:wait-for-cpuload maxload numcpus waitdelay))
(run:test run-id run-info keyvals runname test-record flags #f test-registry all-tests-registry)
(hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running)
(runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
;; (thread-sleep! *global-delta*)
(if (or (not (null? tal))(not (null? reg)))
@@ -1034,28 +1052,33 @@
((not (null? reg)) ;; could we get here with leftovers?
(debug:print-info 0 "Have leftovers!")
(loop (car reg)(cdr reg) '() reruns))
(else
(debug:print-info 4 "Exiting loop with...\n hed=" hed "\n tal=" tal "\n reruns=" reruns))
- ))
- ;; now *if* -run-wait we wait for all tests to be done
- (let loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
- (prev-num-running 0))
- (if (and (args:get-arg "-run-wait")
- (> num-running 0))
- (begin
- ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
- (if (> (current-seconds)(+ last-time-incomplete 900))
- (begin
- (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
- (set! last-time-incomplete (current-seconds))
- (cdb:remote-run db:find-and-mark-incomplete #f)))
- (if (not (eq? num-running prev-num-running))
- (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
- (thread-sleep! 15)
- (loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
- ) ;; LET* ((test-record
+ )))
+ ;; now *if* -run-wait we wait for all tests to be done
+ ;; Now wait for any RUNNING tests to complete (if in run-wait mode)
+ (let wait-loop ((num-running (rmt:get-count-tests-running-for-run-id run-id))
+ (prev-num-running 0))
+ ;; (debug:print 0 "num-running=" num-running ", prev-num-running=" prev-num-running)
+ (if (and (or (args:get-arg "-run-wait")
+ (equal? (configf:lookup *configdat* "setup" "run-wait") "yes"))
+ (> num-running 0))
+ (begin
+ ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes
+ ;; (debug:print 0 "Got here eh! num-running=" num-running " (> num-running 0) " (> num-running 0))
+ (if (> (current-seconds)(+ last-time-incomplete 900))
+ (begin
+ (debug:print-info 0 "Marking stuck tests as INCOMPLETE while waiting for run " run-id ". Running as pid " (current-process-id) " on " (get-host-name))
+ (set! last-time-incomplete (current-seconds))
+ (cdb:remote-run db:find-and-mark-incomplete #f)))
+ (if (not (eq? num-running prev-num-running))
+ (debug:print-info 0 "run-wait specified, waiting on " num-running " tests in RUNNING, REMOTEHOSTSTART or LAUNCHED state at " (time->string (seconds->local-time (current-seconds)))))
+ (thread-sleep! 15)
+ ;; (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
+ (wait-loop (rmt:get-count-tests-running-for-run-id run-id) num-running))))
+ ;; LET* ((test-record
;; we get here on "drop through". All done!
(debug:print-info 1 "All tests launched")))
(define (runs:calc-fails prereqs-not-met)
(filter (lambda (test)
@@ -1115,10 +1138,11 @@
(itemdat (tests:testqueue-get-itemdat test-record))
(test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
(force (hash-table-ref/default flags "-force" #f))
(rerun (hash-table-ref/default flags "-rerun" #f))
(keepgoing (hash-table-ref/default flags "-keepgoing" #f))
+ (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x")))
(item-path "")
(db #f)
(full-test-name #f))
;; setting itemdat to a list if it is #f
@@ -1262,11 +1286,12 @@
(debug:print 1 "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.")
(hash-table-set! test-registry (runs:make-full-test-name test-name test-path) 'DONOTRUN)) ;; KILLED))
((LAUNCHED REMOTEHOSTSTART RUNNING)
(if (> (- (current-seconds)(+ (db:test-get-event_time testdat)
(db:test-get-run_duration testdat)))
- 600) ;; i.e. no update for more than 600 seconds
+ (or incomplete-timeout
+ 6000)) ;; i.e. no update for more than 6000 seconds
(begin
(debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD")
(tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f))
(debug:print 2 "NOTE: " test-name " is already running")))
Index: tests/fullrun/config/mt_include_1.config
==================================================================
--- tests/fullrun/config/mt_include_1.config
+++ tests/fullrun/config/mt_include_1.config
@@ -13,11 +13,17 @@
# launcher nbfake
launcher loadrunner
# launcher echo
# launcher nbfind
# launcher nodanggood
-# launcher nbload
+# launcher loadrunner
+launcher nbfake
+# maxload *per cpu*
+maxload 4
+# default waitdelay is 60 seconds
+waitdelay 15
+
## use "xterm -e csi -- " as a launcher to examine the launch environment.
## exit with (exit)
## get a shell with (system "bash")
# launcher xterm -e csi --
Index: tests/fullrun/megatest.config
==================================================================
--- tests/fullrun/megatest.config
+++ tests/fullrun/megatest.config
@@ -25,10 +25,15 @@
[setup]
# Set launchwait to no to use the more agressive code that does not wait for the launch to complete before proceeding
# this may save a few milliseconds on launching tests
# launchwait no
waivercommentpatt ^WW\d+ [a-z].*
+incomplete-timeout 1
+
+# yes, anything else is no
+run-wait yes
+
# Use http instead of direct filesystem access
# transport http
# transport fs
Index: utils/Makefile_latest.installall
==================================================================
--- utils/Makefile_latest.installall
+++ utils/Makefile_latest.installall
@@ -43,11 +43,11 @@
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications sql-de-lite \
- srfi-19 refdb
+ srfi-19 refdb ini-file
#
# Derived variables
#
ADDED utils/loadrunner.scm.notfinished
Index: utils/loadrunner.scm.notfinished
==================================================================
--- /dev/null
+++ utils/loadrunner.scm.notfinished
@@ -0,0 +1,192 @@
+
+;; Copyright 2006-2013, Matthew Welland.
+;;
+;; This program is made available under the GNU GPL version 2.0 or
+;; greater. See the accompanying file COPYING for details.
+;;
+;; This program is distributed WITHOUT ANY WARRANTY; without even the
+;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE.
+
+(use ssax)
+(use sxml-serializer)
+(use sxml-modifications)
+(use regex)
+(use srfi-69)
+(use regex-case)
+(use posix)
+(use json)
+(use csv)
+(use srfi-18)
+(use format)
+
+(require-library iup)
+(import (prefix iup iup:))
+(require-library ini-file)
+(import (prefix ini-file ini:))
+
+(use canvas-draw)
+(import canvas-draw-iup)
+
+(use sqlite3 srfi-1 posix regex regex-case srfi-69)
+(import (prefix sqlite3 sqlite3:))
+
+(include "megatest-fossil-hash.scm")
+
+;;
+;; GLOBALS
+;;
+(define *loadrunner:current-tab-number* 0)
+(define loadrunner:unrecognised-command "ERROR: Unrecognised command or missing params. Try \"loadrunner help\"")
+(define loadrunner:help (conc "Usage: loadrunner [action [params ...]]
+
+Note: run loadrunner without parameters to start the gui.
+
+ run cmd [params ..] : Run cmd params ... when system load drops
+ process : Process the queue
+
+Part of the Megatest tool suite. Learn more at http://www.kiatoa.com/fossils/megatest
+
+Version: " megatest-fossil-hash)) ;; "
+
+;;======================================================================
+;; DB
+;;======================================================================
+
+(define (loadrunner:initialize-db db)
+ (for-each
+ (lambda (qry)
+ (sqlite3:execute db qry))
+ (list
+ "CREATE TABLE pkgs
+ (id INTEGER PRIMARY KEY,
+ cmd TEXT,
+ datetime TEXT);")))
+
+;; Create the sqlite db
+(define (loadrunner:open-db path)
+ (if (and path
+ (directory? path)
+ (file-read-access? path))
+ (let* ((dbpath (conc path "/loadrunner.db"))
+ (writeable (file-write-access? dbpath))
+ (dbexists (file-exists? dbpath))
+ (handler (make-busy-timeout 136000)))
+ (handle-exceptions
+ exn
+ (begin
+ (debug:print 2 "ERROR: problem accessing db " dbpath
+ ((condition-property-accessor 'exn 'message) exn))
+ (exit))
+ (set! db (sqlite3:open-database dbpath)))
+ (if *db-write-access* (sqlite3:set-busy-handler! db handler))
+ (if (not dbexists)
+ (begin
+ (loadrunner:initialize-db db)))
+ db)))
+
+;;======================================================================
+;; GUI
+;;======================================================================
+
+;; The main menu
+(define (loadrunner:main-menu)
+ (iup:menu ;; a menu is a special attribute to a dialog (think Gnome putting the menu at screen top)
+ (iup:menu-item "Files" (iup:menu ;; Note that you can use either #:action or action: for options
+ (iup:menu-item "Open" action: (lambda (obj)
+ (iup:show (iup:file-dialog))
+ (print "File->open " obj)))
+ (iup:menu-item "Save" #:action (lambda (obj)(print "File->save " obj)))
+ (iup:menu-item "Exit" #:action (lambda (obj)(exit)))))
+ (iup:menu-item "Tools" (iup:menu
+ (iup:menu-item "Create new blah" #:action (lambda (obj)(print "Tools->new blah")))
+ ;; (iup:menu-item "Show dialog" #:action (lambda (obj)
+ ;; (show message-window
+ ;; #:modal? #t
+ ;; ;; set positon using coordinates or center, start, top, left, end, bottom, right, parent-center, current
+ ;; ;; #:x 'mouse
+ ;; ;; #:y 'mouse
+ ;; )
+ ))))
+
+(define (loadrunner:publish-view)
+ (iup:vbox
+ (iup:hbox
+ (iup:button "Pushme"
+ #:expand "YES"
+ ))))
+
+(define (loadrunner:get-view)
+ (iup:vbox
+ (iup:hbox
+ (iup:button "Pushme"
+ #:expand "YES"
+ ))))
+
+(define (loadrunner:manage-view)
+ (iup:vbox
+ (iup:hbox
+ (iup:button "Pushme"
+ #:expand "YES"
+ ))))
+
+(define (loadrunner:gui)
+ (iup:show
+ (iup:dialog
+ #:title (conc "Loadrunner dashboard " (current-user-name) ":" (current-directory))
+ #:menu (loadrunner:main-menu)
+ (let* ((tabs (iup:tabs
+ #:tabchangepos-cb (lambda (obj curr prev)
+ (set! *loadrunner:current-tab-number* curr))
+ (loadrunner:publish-view)
+ (loadrunner:get-view)
+ (loadrunner:manage-view)
+ )))
+ ;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
+ (iup:attribute-set! tabs "TABTITLE0" "Publish")
+ (iup:attribute-set! tabs "TABTITLE1" "Get")
+ (iup:attribute-set! tabs "TABTITLE2" "Manage")
+ ;; (iup:attribute-set! tabs "BGCOLOR" "190 190 190")
+ tabs)))
+ (iup:main-loop))
+
+;;======================================================================
+;; MAIN
+;;======================================================================
+
+(define (loadrunner:load-config path)
+ (let ((fname (conc path "/.loadrunner.config")))
+ (ini:property-separator-patt " * *")
+ (ini:property-separator #\space)
+ (if (file-exists? fname)
+ (ini:read fname)
+ '())))
+
+(define (main)
+ (let* ((args (argv))
+ (prog (car args))
+ (rema (cdr args))
+ (conf (loadrunner:load-config (pathname-directory prog))))
+ ;; ( ?????
+ (cond
+ ((eq? (length rema) 1)
+ (case (string->symbol (car rema))
+ ((process)(loadrunner:process-queue))
+ ((pause)
+ (loadrunner:pause-queue (cdr rema)))
+ ((help -h -help --h --help)
+ (print loadrunner:help))
+ (else
+ (print loadrunner:unrecognised-command))))
+ ((null? rema)(loadrunner:gui))
+ ((>= (length rema) 2)
+ (case (string->symbol (car rema))
+ ((run)
+ (loadrunner:process-cmd (cdr rema)))
+ ((remove)
+ (loadrunner:remove-cmds (cdr rema)))
+ (else
+ (print loadrunner:unrecognised-command))))
+ (else (print loadrunner:unrecognised-command)))))
+
+(main)
Index: utils/nbfake
==================================================================
--- utils/nbfake
+++ utils/nbfake
@@ -9,9 +9,12 @@
echo "# NBFAKE Running command:"
echo "# \"$*\""
echo "#======================================================================"
if [[ $TARGETHOST == "" ]]; then
- sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &"
+ unset TARGETHOST
+ TARGETHOST_LOGF_TEMP=$TARGETHOST_LOGF
+ unset TARGETHOST_LOGF
+ sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF_TEMP 2>&1 &"
else
ssh -n -f $TARGETHOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* > $TARGETHOST_LOGF 2>&1 &\""
fi