Index: api-inc.scm ================================================================== --- api-inc.scm +++ api-inc.scm @@ -16,16 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use srfi-69 posix) - -(declare (unit api)) -(declare (uses rmt)) -(declare (uses db)) -(declare (uses tasks)) ;; allow these queries through without starting a server ;; (define api:read-only-queries '(get-key-val-pairs Index: archive-inc.scm ================================================================== --- archive-inc.scm +++ archive-inc.scm @@ -16,19 +16,10 @@ ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) - -(declare (unit archive)) -(declare (uses db)) -(declare (uses common)) - -(include "common_records.scm") -(include "db_records.scm") - ;;====================================================================== ;; ;;====================================================================== ;; NOT CURRENTLY USED Index: client-inc.scm ================================================================== --- client-inc.scm +++ client-inc.scm @@ -18,23 +18,10 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 - message-digest matchable spiffy uri-common intarweb http-client - spiffy-request-vars uri-common intarweb directory-utils) - -(declare (unit client)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. - -(include "common_records.scm") -(include "db_records.scm") - ;; client:get-signature (define (client:get-signature) (if *my-client-signature* *my-client-signature* (let ((sig (conc (get-host-name) " " (current-process-id)))) (set! *my-client-signature* sig) Index: common-inc.scm ================================================================== --- common-inc.scm +++ common-inc.scm @@ -16,28 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 udp ;; sql-de-lite - hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix (srfi 18) extras ;; tcp - (prefix nanomsg nmsg:) - (prefix sqlite3 sqlite3:) - pkts (prefix dbi dbi:) - ) - -(declare (unit common)) -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") - - -;; (require-library margs) -;; (include "margs.scm") ;; (define old-exit exit) ;; ;; (define (exit . code) ;; (if (null? code) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -39,440 +39,440 @@ (include "common_records.scm") (include "megatest-fossil-hash.scm") (include "megatest-version.scm") -(define (common:low-noise-print alldat waitval . keys) - (let* ((key (string-intersperse (map conc keys) "-" )) - (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0)) - (currtime (current-seconds))) - (if (> (- currtime lasttime) waitval) - (begin - (hash-table-set! (alldat-denoise alldat) key currtime) - #t) - #f))) - -(define (common:version-signature alldat) - (conc (alldat-megatest-version alldat) - "-" (substring (alldat-megatest-fossil-hash alldat) 0 4))) - -(define (common:get-fields cfgdat) - (let ((fields (hash-table-ref/default cfgdat "fields" '()))) - (map car fields))) - -;;====================================================================== -;; T I M E A N D D A T E -;;====================================================================== - -;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 -(define (common:hms-string->seconds tstr) - (let ((parts (string-split-fields "\\w+" tstr)) - (time-secs 0) - ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks - (trx (regexp "(\\d+)([smhdMyw])"))) - (for-each (lambda (part) - (let ((match (string-match trx part))) - (if match - (let ((val (string->number (cadr match))) - (unt (caddr match))) - (if val - (set! time-secs (+ time-secs (* val - (case (string->symbol unt) - ((s) 1) - ((m) 60) ;; minutes - ((h) 3600) - ((d) 86400) - ((w) 604800) - ((M) 2628000) ;; aproximately one month - ((y) 31536000) - (else #f)))))))))) - parts) - time-secs)) - -(define (seconds->hr-min-sec secs) - (let* ((hrs (quotient secs 3600)) - (min (quotient (- secs (* hrs 3600)) 60)) - (sec (- secs (* hrs 3600)(* min 60)))) - (conc (if (> hrs 0)(conc hrs "hr ") "") - (if (> min 0)(conc min "m ") "") - sec "s"))) - -(define (seconds->time-string sec) - (time->string - (seconds->local-time sec) "%H:%M:%S")) - -(define (seconds->work-week/day-time sec) - (time->string - (seconds->local-time sec) "ww%V.%u %H:%M")) - -(define (seconds->work-week/day sec) - (time->string - (seconds->local-time sec) "ww%V.%u")) - -(define (seconds->year-work-week/day sec) - (time->string - (seconds->local-time sec) "%yww%V.%w")) - -(define (seconds->year-work-week/day-time sec) - (time->string - (seconds->local-time sec) "%Yww%V.%w %H:%M")) - -(define (seconds->year-week/day-time sec) - (time->string - (seconds->local-time sec) "%Yw%V.%w %H:%M")) - -(define (seconds->quarter sec) - (case (string->number - (time->string - (seconds->local-time sec) - "%m")) - ((1 2 3) 1) - ((4 5 6) 2) - ((7 8 9) 3) - ((10 11 12) 4) - (else #f))) - -;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch -;; -(define (common:date-time->seconds datetime) - (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) - -;; given span of seconds tstart to tend -;; find start time to mark and mark delta -;; -(define (common:find-start-mark-and-mark-delta tstart tend) - (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... - (result #f) - (min 60) - (hr (* 60 60)) - (day (* 24 hr)) - (yr (* 365 day)) ;; year - (mo (/ yr 12)) - (wk (* day 7))) - (for-each - (lambda (max-blks) - (for-each - (lambda (span) ;; 5 2 1 - (if (not result) - (for-each - (lambda (timeunit timesym) ;; year month day hr min sec - (if (not result) - (let* ((time-blk (* span timeunit)) - (num-blks (quotient deltat time-blk))) - (if (and (> num-blks 4)(< num-blks max-blks)) - (let ((first (* (quotient tstart time-blk) time-blk))) - (set! result (list span timeunit time-blk first timesym)) - ))))) - (list yr mo wk day hr min 1) - '( y mo w d h m s)))) - (list 8 6 5 2 1))) - '(5 10 15 20 30 40 50 500)) - (if values - (apply values result) - (values 0 day 1 0 'd)))) - -;; given x y lim return the cron expansion -;; -(define (common:expand-cron-slash x y lim) - (let loop ((curr x) - (res `())) - (if (< curr lim) - (loop (+ curr y) (cons curr res)) - (reverse res)))) - -;; expand a complex cron string to a list of cron strings -;; -;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c -;; -;; NOTE: with flatten a lot of the crud below can be factored down. -;; -(define (common:cron-expand cron-str) - (if (list? cron-str) - (flatten - (fold (lambda (x res) - (if (list? x) - (let ((newres (map common:cron-expand x))) - (append x newres)) - (cons x res))) - '() - cron-str)) ;; (map common:cron-expand cron-str)) - (let ((cron-items (string-split cron-str)) - (slash-rx (regexp "(\\d+)/(\\d+)")) - (comma-rx (regexp ".*,.*")) - (max-vals '((min . 60) - (hour . 24) - (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations - (month . 12) - (dayofweek . 7)))) - (if (< (length cron-items) 5) ;; bad spec - cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it - (let loop ((hed (car cron-items)) - (tal (cdr cron-items)) - (type 'min) - (type-tal '(hour dayofmonth month dayofweek)) - (res '())) - (regex-case - hed - (slash-rx ( _ base incr ) (let* ((basen (string->number base)) - (incrn (string->number incr)) - (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) - (new-list-crons (fold (lambda (x myres) - (cons (conc (if (null? res) - "" - (conc (string-intersperse res " ") " ")) - x " " (string-intersperse tal " ")) - myres)) - '() expanded-vals))) - ;; (print "new-list-crons: " new-list-crons) - ;; (fold (lambda (x res) - ;; (if (list? x) - ;; (let ((newres (map common:cron-expand x))) - ;; (append x newres)) - ;; (cons x res))) - ;; '() - (flatten (map common:cron-expand new-list-crons)))) - ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) - (else (if (null? tal) - cron-str - (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) - - -;; given a cron string and the last time event was processed return #t to run or #f to not run -;; -;; min hour dayofmonth month dayofweek -;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 -;; -;; #t => yes, run the job -;; #f => no, do not run the job -;; -(define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. - (let* ((cron-items (map string->number (string-split cron-str))) - (now-seconds (or now-seconds-in (current-seconds))) - (now-time (seconds->local-time now-seconds)) - (last-done-time (seconds->local-time last-done)) - (all-times (make-hash-table))) - ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) - (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings - #f - (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) - cron-items) - ;; 0 1 2 3 4 5 6 - ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) - (vector->list now-time)) - ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) - (vector->list last-done-time))) - ;; create all possible time slots - ;; remove invalid slots due to (for example) day of week - ;; get the start and end entries for the ref-seconds (current) time - ;; if last-done > ref-seconds => this is an ERROR! - ;; does the last-done time fall in the legit region? - ;; yes => #f do not run again this command - ;; no => #t ok to run the command - (for-each ;; month - (lambda (month) - (for-each ;; dayofmonth - (lambda (dom) - (for-each - (lambda (hr) ;; hour - (for-each - (lambda (minute) ;; minute - (let ((copy-now (apply vector (vector->list now-time)))) - (vector-set! copy-now 0 0) ;; force seconds to zero - (vector-set! copy-now 1 minute) - (vector-set! copy-now 2 hr) - (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced - (vector-set! copy-now 4 month) - (let* ((copy-now-secs (local-time->seconds copy-now)) - (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector - (if (or (not cdayofweek) - (equal? (vector-ref new-copy 6) - cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified - (if (or (not cdayofmonth) - (equal? (vector-ref new-copy 3) - (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified - (hash-table-set! all-times copy-now-secs new-copy)))))) - (if cmin - `(,cmin) ;; if given cmin, have to use it - (list (- nmin 1) nmin (+ nmin 1))))) ;; minute - (if chour - `(,chour) - (list (- nhour 1) nhour (+ nhour 1))))) ;; hour - (if cdayofmonth - `(,cdayofmonth) - (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) - (if cmonth - `(,cmonth) - (list (- nmonth 1) nmonth (+ nmonth 1)))) - (let ((before #f) - (is-in #f)) - (for-each - (lambda (moment) - (if (and before - (<= before now-seconds) - (>= moment now-seconds)) - (begin - ;; (print) - ;; (print "Before: " (time->string (seconds->local-time before))) - ;; (print "Now: " (time->string (seconds->local-time now-seconds))) - ;; (print "After: " (time->string (seconds->local-time moment))) - ;; (print "Last: " (time->string (seconds->local-time last-done))) - (if (< last-done before) - (set! is-in before)) - )) - (set! before moment)) - (sort (hash-table-keys all-times) <)) - is-in))))) - -(define (common:extended-cron cron-str now-seconds-in last-done) - (let ((expanded-cron (common:cron-expand cron-str))) - (if (string? expanded-cron) - (common:cron-event expanded-cron now-seconds-in last-done) - (let loop ((hed (car expanded-cron)) - (tal (cdr expanded-cron))) - (if (common:cron-event hed now-seconds-in last-done) - #t - (if (null? tal) - #f - (loop (car tal)(cdr tal)))))))) - -;;====================================================================== -;; C O L O R S -;;====================================================================== - -(define (common:name->iup-color name) - (case (string->symbol (string-downcase name)) - ((red) "223 33 49") - ((grey) "192 192 192") - ((orange) "255 172 13") - ((purple) "This is unfinished ..."))) - -;; (define (common:get-color-for-state-status state status) -;; (case (string->symbol state) -;; ((COMPLETED) -;; (case (string->symbol status) -;; ((PASS) "70 249 73") -;; ((WARN WAIVED) "255 172 13") -;; ((SKIP) "230 230 0") -;; (else "223 33 49"))) -;; ((LAUNCHED) "101 123 142") -;; ((CHECK) "255 100 50") -;; ((REMOTEHOSTSTART) "50 130 195") -;; ((RUNNING) "9 131 232") -;; ((KILLREQ) "39 82 206") -;; ((KILLED) "234 101 17") -;; ((NOT_STARTED) "240 240 240") -;; (else "192 192 192"))) - -(define (common:iup-color->rgb-hex instr) - (string-intersperse - (map (lambda (x) - (number->string x 16)) - (map string->number - (string-split instr))) - "/")) - -;; dot-locking egg seems not to work, using this for now -;; if lock is older than expire-time then remove it and try again -;; to get the lock -;; -(define (common:simple-file-lock fname #!key (expire-time 300)) - (if (file-exists? fname) - (if (> (- (current-seconds)(file-modification-time fname)) expire-time) - (begin - (handle-exceptions exn #f (delete-file* fname)) - (common:simple-file-lock fname expire-time: expire-time)) - #f) - (let ((key-string (conc (get-host-name) "-" (current-process-id)))) - (with-output-to-file fname - (lambda () - (print key-string))) - (thread-sleep! 0.25) - (if (file-exists? fname) - (handle-exceptions exn - #f - (with-input-from-file fname - (lambda () - (equal? key-string (read-line))))) - #f)))) - -(define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) - (let ((end-time (+ expire-time (current-seconds)))) - (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) - (if got-lock - #t - (if (> end-time (current-seconds)) - (begin - (thread-sleep! 3) - (loop (common:simple-file-lock fname expire-time: expire-time))) - #f))))) - -(define (common:simple-file-release-lock fname) - (handle-exceptions - exn - #f ;; I don't really care why this failed (at least for now) - (delete-file* fname))) - -;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 -;; -(define (common:lazy-modification-time fpath) - (handle-exceptions - exn - 0 - (file-modification-time fpath))) - -;; find timestamp of newest file associated with a sqlite db file -(define (common:lazy-sqlite-db-modification-time fpath) - (let* ((glob-list (handle-exceptions - exn - `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))) - (glob (conc fpath "*")))) - (file-list (if (eq? 0 (length glob-list)) - '("/no/such/file") - glob-list))) - (apply max - (map - common:lazy-modification-time - file-list)))) - - -;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . -;; arguments - thunk, message -(define (common:fail-safe thunk warning-message-on-exception) - (handle-exceptions - exn - (begin - (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception) - (debug:print-info 0 *default-log-port* - (string-substitute "\n?Error:" "nonfatal condition:" - (with-output-to-string - (lambda () - (print-error-message exn) )))) - (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...") - #f) - (thunk))) - -(define getenv get-environment-variable) -(define (safe-setenv key val) - (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables. - (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") - (if (and (string? val) - (string? key)) - (handle-exceptions - exn - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) - (setenv key val)) - (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) - -(define home (getenv "HOME")) -(define user (getenv "USER")) - - -;; returns list of fd count, socket count -(define (get-file-descriptor-count #!key (pid (current-process-id ))) - (list - (length (glob (conc "/proc/" pid "/fd/*"))) - (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) - ) -) - +;; (define (common:low-noise-print alldat waitval . keys) +;; (let* ((key (string-intersperse (map conc keys) "-" )) +;; (lasttime (hash-table-ref/default (alldat-denoise alldat) key 0)) +;; (currtime (current-seconds))) +;; (if (> (- currtime lasttime) waitval) +;; (begin +;; (hash-table-set! (alldat-denoise alldat) key currtime) +;; #t) +;; #f))) +;; +;; (define (common:version-signature alldat) +;; (conc (alldat-megatest-version alldat) +;; "-" (substring (alldat-megatest-fossil-hash alldat) 0 4))) +;; +;; (define (common:get-fields cfgdat) +;; (let ((fields (hash-table-ref/default cfgdat "fields" '()))) +;; (map car fields))) +;; +;; ;;====================================================================== +;; ;; T I M E A N D D A T E +;; ;;====================================================================== +;; +;; ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 +;; (define (common:hms-string->seconds tstr) +;; (let ((parts (string-split-fields "\\w+" tstr)) +;; (time-secs 0) +;; ;; s=seconds, m=minutes, h=hours, d=days, M=months, y=years, w=weeks +;; (trx (regexp "(\\d+)([smhdMyw])"))) +;; (for-each (lambda (part) +;; (let ((match (string-match trx part))) +;; (if match +;; (let ((val (string->number (cadr match))) +;; (unt (caddr match))) +;; (if val +;; (set! time-secs (+ time-secs (* val +;; (case (string->symbol unt) +;; ((s) 1) +;; ((m) 60) ;; minutes +;; ((h) 3600) +;; ((d) 86400) +;; ((w) 604800) +;; ((M) 2628000) ;; aproximately one month +;; ((y) 31536000) +;; (else #f)))))))))) +;; parts) +;; time-secs)) +;; +;; (define (seconds->hr-min-sec secs) +;; (let* ((hrs (quotient secs 3600)) +;; (min (quotient (- secs (* hrs 3600)) 60)) +;; (sec (- secs (* hrs 3600)(* min 60)))) +;; (conc (if (> hrs 0)(conc hrs "hr ") "") +;; (if (> min 0)(conc min "m ") "") +;; sec "s"))) +;; +;; (define (seconds->time-string sec) +;; (time->string +;; (seconds->local-time sec) "%H:%M:%S")) +;; +;; (define (seconds->work-week/day-time sec) +;; (time->string +;; (seconds->local-time sec) "ww%V.%u %H:%M")) +;; +;; (define (seconds->work-week/day sec) +;; (time->string +;; (seconds->local-time sec) "ww%V.%u")) +;; +;; (define (seconds->year-work-week/day sec) +;; (time->string +;; (seconds->local-time sec) "%yww%V.%w")) +;; +;; (define (seconds->year-work-week/day-time sec) +;; (time->string +;; (seconds->local-time sec) "%Yww%V.%w %H:%M")) +;; +;; (define (seconds->year-week/day-time sec) +;; (time->string +;; (seconds->local-time sec) "%Yw%V.%w %H:%M")) +;; +;; (define (seconds->quarter sec) +;; (case (string->number +;; (time->string +;; (seconds->local-time sec) +;; "%m")) +;; ((1 2 3) 1) +;; ((4 5 6) 2) +;; ((7 8 9) 3) +;; ((10 11 12) 4) +;; (else #f))) +;; +;; ;; basic ISO8601 format (e.g. "2017-02-28 06:02:54") date time => Unix epoch +;; ;; +;; (define (common:date-time->seconds datetime) +;; (local-time->seconds (string->time datetime "%Y-%m-%d %H:%M:%S"))) +;; +;; ;; given span of seconds tstart to tend +;; ;; find start time to mark and mark delta +;; ;; +;; (define (common:find-start-mark-and-mark-delta tstart tend) +;; (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... +;; (result #f) +;; (min 60) +;; (hr (* 60 60)) +;; (day (* 24 hr)) +;; (yr (* 365 day)) ;; year +;; (mo (/ yr 12)) +;; (wk (* day 7))) +;; (for-each +;; (lambda (max-blks) +;; (for-each +;; (lambda (span) ;; 5 2 1 +;; (if (not result) +;; (for-each +;; (lambda (timeunit timesym) ;; year month day hr min sec +;; (if (not result) +;; (let* ((time-blk (* span timeunit)) +;; (num-blks (quotient deltat time-blk))) +;; (if (and (> num-blks 4)(< num-blks max-blks)) +;; (let ((first (* (quotient tstart time-blk) time-blk))) +;; (set! result (list span timeunit time-blk first timesym)) +;; ))))) +;; (list yr mo wk day hr min 1) +;; '( y mo w d h m s)))) +;; (list 8 6 5 2 1))) +;; '(5 10 15 20 30 40 50 500)) +;; (if values +;; (apply values result) +;; (values 0 day 1 0 'd)))) +;; +;; ;; given x y lim return the cron expansion +;; ;; +;; (define (common:expand-cron-slash x y lim) +;; (let loop ((curr x) +;; (res `())) +;; (if (< curr lim) +;; (loop (+ curr y) (cons curr res)) +;; (reverse res)))) +;; +;; ;; expand a complex cron string to a list of cron strings +;; ;; +;; ;; x/y => x, x+y, x+2y, x+3y while x+Ny a, b ,c +;; ;; +;; ;; NOTE: with flatten a lot of the crud below can be factored down. +;; ;; +;; (define (common:cron-expand cron-str) +;; (if (list? cron-str) +;; (flatten +;; (fold (lambda (x res) +;; (if (list? x) +;; (let ((newres (map common:cron-expand x))) +;; (append x newres)) +;; (cons x res))) +;; '() +;; cron-str)) ;; (map common:cron-expand cron-str)) +;; (let ((cron-items (string-split cron-str)) +;; (slash-rx (regexp "(\\d+)/(\\d+)")) +;; (comma-rx (regexp ".*,.*")) +;; (max-vals '((min . 60) +;; (hour . 24) +;; (dayofmonth . 28) ;;; BUG!!!! This will be a bug for some combinations +;; (month . 12) +;; (dayofweek . 7)))) +;; (if (< (length cron-items) 5) ;; bad spec +;; cron-str ;; `(,cron-str) ;; just return the string, something downstream will fix it +;; (let loop ((hed (car cron-items)) +;; (tal (cdr cron-items)) +;; (type 'min) +;; (type-tal '(hour dayofmonth month dayofweek)) +;; (res '())) +;; (regex-case +;; hed +;; (slash-rx ( _ base incr ) (let* ((basen (string->number base)) +;; (incrn (string->number incr)) +;; (expanded-vals (common:expand-cron-slash basen incrn (alist-ref type max-vals))) +;; (new-list-crons (fold (lambda (x myres) +;; (cons (conc (if (null? res) +;; "" +;; (conc (string-intersperse res " ") " ")) +;; x " " (string-intersperse tal " ")) +;; myres)) +;; '() expanded-vals))) +;; ;; (print "new-list-crons: " new-list-crons) +;; ;; (fold (lambda (x res) +;; ;; (if (list? x) +;; ;; (let ((newres (map common:cron-expand x))) +;; ;; (append x newres)) +;; ;; (cons x res))) +;; ;; '() +;; (flatten (map common:cron-expand new-list-crons)))) +;; ;; (map common:cron-expand (map common:cron-expand new-list-crons)))) +;; (else (if (null? tal) +;; cron-str +;; (loop (car tal)(cdr tal)(car type-tal)(cdr type-tal)(append res (list hed))))))))))) +;; +;; +;; ;; given a cron string and the last time event was processed return #t to run or #f to not run +;; ;; +;; ;; min hour dayofmonth month dayofweek +;; ;; 0-59 0-23 1-31 1-12 0-6 ### NOTE: dayofweek does not include 7 +;; ;; +;; ;; #t => yes, run the job +;; ;; #f => no, do not run the job +;; ;; +;; (define (common:cron-event cron-str now-seconds-in last-done) ;; ref-seconds = #f is NOW. +;; (let* ((cron-items (map string->number (string-split cron-str))) +;; (now-seconds (or now-seconds-in (current-seconds))) +;; (now-time (seconds->local-time now-seconds)) +;; (last-done-time (seconds->local-time last-done)) +;; (all-times (make-hash-table))) +;; ;; (print "cron-items: " cron-items "(length cron-items): " (length cron-items)) +;; (if (not (eq? (length cron-items) 5)) ;; don't even try to figure out junk strings +;; #f +;; (match-let ((( cmin chour cdayofmonth cmonth cdayofweek) +;; cron-items) +;; ;; 0 1 2 3 4 5 6 +;; ((nsec nmin nhour ndayofmonth nmonth nyr ndayofweek n7 n8 n9) +;; (vector->list now-time)) +;; ((lsec lmin lhour ldayofmonth lmonth lyr ldayofweek l7 l8 l9) +;; (vector->list last-done-time))) +;; ;; create all possible time slots +;; ;; remove invalid slots due to (for example) day of week +;; ;; get the start and end entries for the ref-seconds (current) time +;; ;; if last-done > ref-seconds => this is an ERROR! +;; ;; does the last-done time fall in the legit region? +;; ;; yes => #f do not run again this command +;; ;; no => #t ok to run the command +;; (for-each ;; month +;; (lambda (month) +;; (for-each ;; dayofmonth +;; (lambda (dom) +;; (for-each +;; (lambda (hr) ;; hour +;; (for-each +;; (lambda (minute) ;; minute +;; (let ((copy-now (apply vector (vector->list now-time)))) +;; (vector-set! copy-now 0 0) ;; force seconds to zero +;; (vector-set! copy-now 1 minute) +;; (vector-set! copy-now 2 hr) +;; (vector-set! copy-now 3 dom) ;; dom is already corrected for zero referenced +;; (vector-set! copy-now 4 month) +;; (let* ((copy-now-secs (local-time->seconds copy-now)) +;; (new-copy (seconds->local-time copy-now-secs))) ;; remake the time vector +;; (if (or (not cdayofweek) +;; (equal? (vector-ref new-copy 6) +;; cdayofweek)) ;; if the day is specified and a match OR if the day is NOT specified +;; (if (or (not cdayofmonth) +;; (equal? (vector-ref new-copy 3) +;; (+ 1 cdayofmonth))) ;; if the month is specified and a match OR if the month is NOT specified +;; (hash-table-set! all-times copy-now-secs new-copy)))))) +;; (if cmin +;; `(,cmin) ;; if given cmin, have to use it +;; (list (- nmin 1) nmin (+ nmin 1))))) ;; minute +;; (if chour +;; `(,chour) +;; (list (- nhour 1) nhour (+ nhour 1))))) ;; hour +;; (if cdayofmonth +;; `(,cdayofmonth) +;; (list (- ndayofmonth 1) ndayofmonth (+ ndayofmonth 1))))) +;; (if cmonth +;; `(,cmonth) +;; (list (- nmonth 1) nmonth (+ nmonth 1)))) +;; (let ((before #f) +;; (is-in #f)) +;; (for-each +;; (lambda (moment) +;; (if (and before +;; (<= before now-seconds) +;; (>= moment now-seconds)) +;; (begin +;; ;; (print) +;; ;; (print "Before: " (time->string (seconds->local-time before))) +;; ;; (print "Now: " (time->string (seconds->local-time now-seconds))) +;; ;; (print "After: " (time->string (seconds->local-time moment))) +;; ;; (print "Last: " (time->string (seconds->local-time last-done))) +;; (if (< last-done before) +;; (set! is-in before)) +;; )) +;; (set! before moment)) +;; (sort (hash-table-keys all-times) <)) +;; is-in))))) +;; +;; (define (common:extended-cron cron-str now-seconds-in last-done) +;; (let ((expanded-cron (common:cron-expand cron-str))) +;; (if (string? expanded-cron) +;; (common:cron-event expanded-cron now-seconds-in last-done) +;; (let loop ((hed (car expanded-cron)) +;; (tal (cdr expanded-cron))) +;; (if (common:cron-event hed now-seconds-in last-done) +;; #t +;; (if (null? tal) +;; #f +;; (loop (car tal)(cdr tal)))))))) +;; +;; ;;====================================================================== +;; ;; C O L O R S +;; ;;====================================================================== +;; +;; (define (common:name->iup-color name) +;; (case (string->symbol (string-downcase name)) +;; ((red) "223 33 49") +;; ((grey) "192 192 192") +;; ((orange) "255 172 13") +;; ((purple) "This is unfinished ..."))) +;; +;; ;; (define (common:get-color-for-state-status state status) +;; ;; (case (string->symbol state) +;; ;; ((COMPLETED) +;; ;; (case (string->symbol status) +;; ;; ((PASS) "70 249 73") +;; ;; ((WARN WAIVED) "255 172 13") +;; ;; ((SKIP) "230 230 0") +;; ;; (else "223 33 49"))) +;; ;; ((LAUNCHED) "101 123 142") +;; ;; ((CHECK) "255 100 50") +;; ;; ((REMOTEHOSTSTART) "50 130 195") +;; ;; ((RUNNING) "9 131 232") +;; ;; ((KILLREQ) "39 82 206") +;; ;; ((KILLED) "234 101 17") +;; ;; ((NOT_STARTED) "240 240 240") +;; ;; (else "192 192 192"))) +;; +;; (define (common:iup-color->rgb-hex instr) +;; (string-intersperse +;; (map (lambda (x) +;; (number->string x 16)) +;; (map string->number +;; (string-split instr))) +;; "/")) +;; +;; ;; dot-locking egg seems not to work, using this for now +;; ;; if lock is older than expire-time then remove it and try again +;; ;; to get the lock +;; ;; +;; (define (common:simple-file-lock fname #!key (expire-time 300)) +;; (if (file-exists? fname) +;; (if (> (- (current-seconds)(file-modification-time fname)) expire-time) +;; (begin +;; (handle-exceptions exn #f (delete-file* fname)) +;; (common:simple-file-lock fname expire-time: expire-time)) +;; #f) +;; (let ((key-string (conc (get-host-name) "-" (current-process-id)))) +;; (with-output-to-file fname +;; (lambda () +;; (print key-string))) +;; (thread-sleep! 0.25) +;; (if (file-exists? fname) +;; (handle-exceptions exn +;; #f +;; (with-input-from-file fname +;; (lambda () +;; (equal? key-string (read-line))))) +;; #f)))) +;; +;; (define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) +;; (let ((end-time (+ expire-time (current-seconds)))) +;; (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) +;; (if got-lock +;; #t +;; (if (> end-time (current-seconds)) +;; (begin +;; (thread-sleep! 3) +;; (loop (common:simple-file-lock fname expire-time: expire-time))) +;; #f))))) +;; +;; (define (common:simple-file-release-lock fname) +;; (handle-exceptions +;; exn +;; #f ;; I don't really care why this failed (at least for now) +;; (delete-file* fname))) +;; +;; ;; lazy-safe get file mod time. on any error (file not existing etc.) return 0 +;; ;; +;; (define (common:lazy-modification-time fpath) +;; (handle-exceptions +;; exn +;; 0 +;; (file-modification-time fpath))) +;; +;; ;; find timestamp of newest file associated with a sqlite db file +;; (define (common:lazy-sqlite-db-modification-time fpath) +;; (let* ((glob-list (handle-exceptions +;; exn +;; `(,(conc "/no/such/file, message: " ((condition-property-accessor 'exn 'message) exn))) +;; (glob (conc fpath "*")))) +;; (file-list (if (eq? 0 (length glob-list)) +;; '("/no/such/file") +;; glob-list))) +;; (apply max +;; (map +;; common:lazy-modification-time +;; file-list)))) +;; +;; +;; ;; execute thunk, return value. If exception thrown, trap exception, return #f, and emit nonfatal condition note to *default-log-port* . +;; ;; arguments - thunk, message +;; (define (common:fail-safe thunk warning-message-on-exception) +;; (handle-exceptions +;; exn +;; (begin +;; (debug:print-info 0 *default-log-port* "notable but nonfatal condition - "warning-message-on-exception) +;; (debug:print-info 0 *default-log-port* +;; (string-substitute "\n?Error:" "nonfatal condition:" +;; (with-output-to-string +;; (lambda () +;; (print-error-message exn) )))) +;; (debug:print-info 0 *default-log-port* " -- continuing after nonfatal condition...") +;; #f) +;; (thunk))) +;; +;; (define getenv get-environment-variable) +;; (define (safe-setenv key val) +;; (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables. +;; (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") +;; (if (and (string? val) +;; (string? key)) +;; (handle-exceptions +;; exn +;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) +;; (setenv key val)) +;; (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) +;; +;; (define home (getenv "HOME")) +;; (define user (getenv "USER")) +;; +;; +;; ;; returns list of fd count, socket count +;; (define (get-file-descriptor-count #!key (pid (current-process-id ))) +;; (list +;; (length (glob (conc "/proc/" pid "/fd/*"))) +;; (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) +;; ) +;; ) +;; ) Index: configf-inc.scm ================================================================== --- configf-inc.scm +++ configf-inc.scm @@ -20,18 +20,10 @@ ;;====================================================================== ;; Config file handling ;;====================================================================== -(use regex regex-case) ;; directory-utils) -(declare (unit configf)) -(declare (uses process)) -(declare (uses env)) -(declare (uses keys)) - -(include "common_records.scm") - ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) (if toppath (let ((cfname (conc toppath "/" configname))) (if (common:file-exists? cfname) Index: configfmod.scm ================================================================== --- configfmod.scm +++ configfmod.scm @@ -30,35 +30,35 @@ ;; (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") -(define (configf:lookup cfgdat section var) - (if (hash-table? cfgdat) - (let ((sectdat (hash-table-ref/default cfgdat section '()))) - (if (null? sectdat) - #f - (let ((match (assoc var sectdat))) - (if match ;; (and match (list? match)(> (length match) 1)) - (cadr match) - #f)) - )) - #f)) - -(define (configf:get-section cfgdat section) - (hash-table-ref/default cfgdat section '())) - -;; safely look up a value that is expected to be a number, return -;; a default (#f unless provided) -;; -(define (configf:lookup-number cfgdat section varname #!key (default #f)) - (let* ((val (configf:lookup cfgdat section varname)) - (res (if val - (string->number (string-substitute "\\s+" "" val #t)) - #f))) - (cond - (res res) - (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) - (else default)))) - - +;; (define (configf:lookup cfgdat section var) +;; (if (hash-table? cfgdat) +;; (let ((sectdat (hash-table-ref/default cfgdat section '()))) +;; (if (null? sectdat) +;; #f +;; (let ((match (assoc var sectdat))) +;; (if match ;; (and match (list? match)(> (length match) 1)) +;; (cadr match) +;; #f)) +;; )) +;; #f)) +;; +;; (define (configf:get-section cfgdat section) +;; (hash-table-ref/default cfgdat section '())) +;; +;; ;; safely look up a value that is expected to be a number, return +;; ;; a default (#f unless provided) +;; ;; +;; (define (configf:lookup-number cfgdat section varname #!key (default #f)) +;; (let* ((val (configf:lookup cfgdat section varname)) +;; (res (if val +;; (string->number (string-substitute "\\s+" "" val #t)) +;; #f))) +;; (cond +;; (res res) +;; (val (debug:print 0 *default-log-port* "ERROR: no number found for [" section "], " varname ", got: " val)) +;; (else default)))) +;; +;; ) Index: db-inc.scm ================================================================== --- db-inc.scm +++ db-inc.scm @@ -22,27 +22,10 @@ ;; Database access ;;====================================================================== ;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit db)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") - (define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's (define *number-of-writes* 0) (define *number-non-write-queries* 0) ;;====================================================================== Index: dcommon-inc.scm ================================================================== --- dcommon-inc.scm +++ dcommon-inc.scm @@ -16,29 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use format) -(require-library iup) -(import (prefix iup iup:)) -(use canvas-draw) -(import canvas-draw-iup) -(use regex typed-records matchable) - -(declare (unit dcommon)) - -(declare (uses megatest-version)) -(declare (uses gutils)) -(declare (uses db)) -;; (declare (uses synchash)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") - ;; yes, this is non-ideal (define dashboard:update-summary-tab #f) (define dashboard:update-servers-table #f) ;;====================================================================== Index: env-inc.scm ================================================================== --- env-inc.scm +++ env-inc.scm @@ -16,14 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;;====================================================================== -(declare (unit env)) - -(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables) - (define (env:open-db fname) (let* ((db-exists (common:file-exists? fname)) (db (open-database fname))) (if (not db-exists) (begin Index: ezsteps-inc.scm ================================================================== --- ezsteps-inc.scm +++ ezsteps-inc.scm @@ -16,30 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(use srfi-1 posix regex srfi-69 directory-utils) - -(declare (unit ezsteps)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -;; (declare (uses sdb)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") - - -;;(rmt:get-test-info-by-id run-id test-id) -> testdat - - (define (ezsteps:run-from testdat start-step-name run-one) ;;# TODO - recapture item variables, debug repeated step eval; regen logpro from test (let* ((do-update-test-state-status #f) (test-run-dir ;; (filedb:get-path *fdb* Index: items-inc.scm ================================================================== --- items-inc.scm +++ items-inc.scm @@ -19,14 +19,10 @@ ;; (define itemdat '((ripeness "green ripe overripe") ;; (temperature "cool medium hot") ;; (season "summer winter fall spring"))) -(declare (unit items)) -(declare (uses common)) - -(include "common_records.scm") ;; Puts out all combinations (define (process-itemlist hierdepth curritemkey itemlist) (let ((res '())) (if (not hierdepth) Index: keys-inc.scm ================================================================== --- keys-inc.scm +++ keys-inc.scm @@ -19,19 +19,10 @@ ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== -(use sqlite3 srfi-1 posix regex regex-case srfi-69) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit keys)) -(declare (uses common)) - -(include "key_records.scm") -(include "common_records.scm") - (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse keys ",")) (define (args:usage . a) #f) Index: launch-inc.scm ================================================================== --- launch-inc.scm +++ launch-inc.scm @@ -19,25 +19,10 @@ ;;====================================================================== ;; launch a task - this runs on the originating host, tests themselves ;; ;;====================================================================== -(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3 call-with-environment-variables csv) -(use typed-records pathname-expand matchable) - -(import (prefix base64 base64:)) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit launch)) -(declare (uses subrun)) -(declare (uses common)) -(declare (uses configf)) -(declare (uses db)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") ;;====================================================================== ;; ezsteps ;;====================================================================== Index: megamod.scm ================================================================== --- megamod.scm +++ megamod.scm @@ -49,32 +49,50 @@ (module rmtmod * (import scheme chicken data-structures extras) (import + (prefix base64 base64:) + (prefix dbi dbi:) + (prefix nanomsg nmsg:) (prefix sqlite3 sqlite3:) call-with-environment-variables + canvas-draw csv + csv-xml + data-structures + directory-utils + dot-locking + extras format + hostinfo http-client intarweb irregex + (prefix iup iup:) matchable + md5 + message-digest + pathname-expand ports posix regex + regex-case s11n spiffy spiffy-directory-listing spiffy-request-vars + sql-de-lite srfi-1 srfi-13 srfi-18 srfi-69 stack stml2 + tcp typed-records + udp uri-common z3 ) ;; (import apimod) @@ -103,18 +121,42 @@ (use (prefix ulex ulex:)) (include "common_records.scm") (include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") (include "task_records.scm") (include "test_records.scm") -(include "run_records.scm") +(include "vg_records.scm") +(include "js-path.scm") ;;====================================================================== ;; L O C K I N G M E C H A N I S M S ;;====================================================================== -(include "f1.scm") -(include "f2.scm") -(include "f3.scm") + +(include "api-inc.scm") +(include "archive-inc.scm") +(include "client-inc.scm") +(include "common-inc.scm") +(include "configf-inc.scm") +(include "db-inc.scm") +(include "dcommon-inc.scm") +(include "env-inc.scm") +(include "ezsteps-inc.scm") +(include "items-inc.scm") +(include "keys-inc.scm") +(include "launch-inc.scm") +(include "ods-inc.scm") +(include "process-inc.scm") +(include "rmt-inc.scm") +(include "runconfig-inc.scm") +(include "runs-inc.scm") +(include "server-inc.scm") +(include "subrun-inc.scm") +(include "tasks-inc.scm") +(include "tests-inc.scm") +(include "vg-inc.scm") + ) ;; http-transport:server-dat definition moved to common_records.scm ;; bunch of small functions factored out of send-receive to make debug easier Index: ods-inc.scm ================================================================== --- ods-inc.scm +++ ods-inc.scm @@ -14,14 +14,10 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(use csv-xml regex) -(declare (unit ods)) -(declare (uses common)) - (define ods:dirs '("Configurations2" "Configurations2/toolpanel" "Configurations2/menubar" "Configurations2/toolbar" Index: odsmod.scm ================================================================== --- odsmod.scm +++ odsmod.scm @@ -30,210 +30,210 @@ (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") -(define ods:dirs - '("Configurations2" - "Configurations2/toolpanel" - "Configurations2/menubar" - "Configurations2/toolbar" - "Configurations2/progressbar" - "Configurations2/floater" - "Configurations2/images" - "Configurations2/images/Bitmaps" - "Configurations2/statusbar" - "Configurations2/popupmenu" - "Configurations2/accelerator" - "META-INF" - "Thumbnails")) - -(define ods:0-len-files - '("Configurations2/accelerator/current.xml" - ;; "Thumbnails/thumbnail.png" - "content.xml" - )) - -(define ods:files - '(("META-INF/manifest.xml" - ("\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n")) - ("styles.xml" - ("\n" - "$-$???Page 1??? (???)09/06/2011, 20:48:51Page 1 / 99\n")) - ("settings.xml" - ("\n" - "0045161799view100000020000010060true04000020000010060trueSheet2270010060falsetruetruetrue12632256truetruetruetruefalsefalse1270127011truefalsetrue3falsetruetruetrue12701270false1truetrue1true12632256falsefalsetrue0truetruetruefalsetrue\n")) - ("mimetype" - ("application/vnd.oasis.opendocument.spreadsheet")) - ("meta.xml" - ("\n" - "Matt Welland2011-09-06T20:46:232011-09-06T20:48:51Matt WellandPT2M29S1LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301\n")))) - -(define ods:content-header - '("\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n" - "\n")) - -(define ods:content-footer - '("\n" - "\n" - "\n")) - -(define (ods:make-thumbnail path) - (let ((oup (open-output-pipe (conc "uudecode -o " path "/Thumbnails/thumbnail.png")))) - (with-output-to-port oup - (lambda () - (print "begin-base64 640 Thumbnail.png -iVBORw0KGgoAAAANSUhEUgAAAL4AAAEACAIAAACCoVt7AAAEWElEQVR4nO3X -MU4bWQCA4bGUo5gUKCcgJwCaVNvShdI06VKmSxNKp6PdKg3xCcgJIhr7Ll6P -DTgBRbv5i11W+r7Gw7yZx0jv5415sV6vB/h9L/7rB+D/apfO4nxy8nk8OPq0 -vDm9Pr8+nc+mv75pcXl5MNtfsLp8fXDxbRjefl3Pj//xb340yW+N8gyM6awu -vxwu1+txnVar1Xj2z7PJpoUxhYNdFmNSs+EukdHRcHpzt7Kr69s/luub6Wa1 -V8Px9tx9TLsSH2a4OxwjWx5+uLgYhtOr4ezXo8Ori4tt0b8XJf+KMZ3p7N3w -ejIZV227hMP3V+/XNweX59erxZddK98uPi5eDvfdbC672u8I09l8tvlYDC/v -z93HNJa4+Hj7fr0+3mxs54vTw1e7BM+vh9n7T8PBbPlx8jD/k9HT4WzsRzfP -0/aFtVi+vNl9W75b4MODhwv2C7c4vz/e7C8/zzK+8Iav6ycLPJ1Ol3/zAPv5 -N5vfo7tnN+vZuIFNJvJ5frYvrOHLh8nJyfjjuOsM1/slPH53uNmPTnYDD8dH -R5ut4uGFdf9F6WQy3C3wdPbmdjKZDNsw7u56PPMw3F6cXS6vDs/u57/66cE2 -o+e3w+fP203p7RvdPDvbF9bx/GY935/bvYDuPsa//IeBH473jufrH+9+cu54 -f9dPM893u9QPcz4dnT+emGfDP+dE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6R -dIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i -6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE -0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSI -pEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQ -SYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIh -kg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRD -JB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmH -SDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIO -kXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQd -IukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6 -RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0 -iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLp -EEmHSDpE0iGSDpF0iKRDJB0i6RBJh+gv8TgE/jVPQbMAAAAASUVORK5CYII= -===="))))) - -;; sheetdat is '("sheetname" (r1c1 r2c2 ...)(r2c1 r2c2 ...) ...) -(define (ods:sheet sheetdat) - (let ((name (car sheetdat)) - (rows (cdr sheetdat))) - (conc "\n" - (conc (ods:column) - (string-join (map ods:row rows) "")) - ""))) - -;; seems to be called once at top of each sheet, i.e. a column of rows -(define (ods:column) - "\n") - -;; cells is a list of ... -(define (ods:row cells) - (conc "\n" - (string-join (map ods:cell cells) "") - "\n")) - -;; types are "string" or "float" -(define (ods:cell value) - (let* ((type (cond - ((string? value) "string") - ((symbol? value) "string") - ((number? value) "float") - (else #f))) - (tmpval (if (symbol? value) - (symbol->string value) - (if type value ""))) ;; convert everything else to an empty string - (escval (if (string? tmpval)(string-substitute (regexp "<") "<" (string-substitute (regexp ">") ">" tmpval)) tmpval))) - (conc "\n" - "" escval "" "\n" - "" "\n"))) - -;; create the directories -(define (ods:construct-dir path) - (for-each - (lambda (subdir) - (system (conc "mkdir -p " path "/" subdir))) - ods:dirs)) - -;; populate the necessary, non-constructed, files -(define (ods:add-non-content-files path) - ;; first the zero-length files, nb// the dir should already be created - (for-each - (lambda (fname) - (system (conc "touch " path "/" fname))) - ods:0-len-files) - ;; create the files with stuff in them - (for-each - (lambda (fdat) - (let* ((name (car fdat)) - (lines (cadr fdat))) - (with-output-to-file (conc path "/" name) - (lambda () - (for-each - (lambda (line) - (display line)) - lines))))) - ods:files)) - -;; data format: -;; '( (sheet1 (r1c1 r1c2 r1c3 ...) -;; (r2c1 r2c3 r2c3 ...) ) -;; (sheet2 ( ... ) -;; ( ... ) ) ) -(define (ods:list->ods path fname data) - (if (not (file-exists? path)) - (print "ERROR: path to create ods data must pre-exist") - (begin - (with-output-to-file (conc path "/content.xml") - (lambda () - (ods:construct-dir path) - (ods:add-non-content-files path) - (ods:make-thumbnail path) - (map display ods:content-header) - ;; process each sheet - (map print - (map ods:sheet data)) - (map display ods:content-footer))) - (system (conc "cd " path "; zip " fname " -n mimetype mimetype `find . |grep -v mimetype` > /dev/null"))))) - - +;; (define ods:dirs +;; '("Configurations2" +;; "Configurations2/toolpanel" +;; "Configurations2/menubar" +;; "Configurations2/toolbar" +;; "Configurations2/progressbar" +;; "Configurations2/floater" +;; "Configurations2/images" +;; "Configurations2/images/Bitmaps" +;; "Configurations2/statusbar" +;; "Configurations2/popupmenu" +;; "Configurations2/accelerator" +;; "META-INF" +;; "Thumbnails")) +;; +;; (define ods:0-len-files +;; '("Configurations2/accelerator/current.xml" +;; ;; "Thumbnails/thumbnail.png" +;; "content.xml" +;; )) +;; +;; (define ods:files +;; '(("META-INF/manifest.xml" +;; ("\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n")) +;; ("styles.xml" +;; ("\n" +;; "$-$???Page 1??? (???)09/06/2011, 20:48:51Page 1 / 99\n")) +;; ("settings.xml" +;; ("\n" +;; "0045161799view100000020000010060true04000020000010060trueSheet2270010060falsetruetruetrue12632256truetruetruetruefalsefalse1270127011truefalsetrue3falsetruetruetrue12701270false1truetrue1true12632256falsefalsetrue0truetruetruefalsetrue\n")) +;; ("mimetype" +;; ("application/vnd.oasis.opendocument.spreadsheet")) +;; ("meta.xml" +;; ("\n" +;; "Matt Welland2011-09-06T20:46:232011-09-06T20:48:51Matt WellandPT2M29S1LibreOffice/3.3$Linux LibreOffice_project/330m19$Build-301\n")))) +;; +;; (define ods:content-header +;; '("\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n" +;; "\n")) +;; +;; (define ods:content-footer +;; '("\n" +;; "\n" +;; "\n")) +;; +;; (define (ods:make-thumbnail path) +;; (let ((oup (open-output-pipe (conc "uudecode -o " path "/Thumbnails/thumbnail.png")))) +;; (with-output-to-port oup +;; (lambda () +;; (print "begin-base64 640 Thumbnail.png +;; iVBORw0KGgoAAAANSUhEUgAAAL4AAAEACAIAAACCoVt7AAAEWElEQVR4nO3X +;; MU4bWQCA4bGUo5gUKCcgJwCaVNvShdI06VKmSxNKp6PdKg3xCcgJIhr7Ll6P +;; DTgBRbv5i11W+r7Gw7yZx0jv5415sV6vB/h9L/7rB+D/apfO4nxy8nk8OPq0 +;; vDm9Pr8+nc+mv75pcXl5MNtfsLp8fXDxbRjefl3Pj//xb340yW+N8gyM6awu +;; vxwu1+txnVar1Xj2z7PJpoUxhYNdFmNSs+EukdHRcHpzt7Kr69s/luub6Wa1 +;; V8Px9tx9TLsSH2a4OxwjWx5+uLgYhtOr4ezXo8Ori4tt0b8XJf+KMZ3p7N3w +;; ejIZV227hMP3V+/XNweX59erxZddK98uPi5eDvfdbC672u8I09l8tvlYDC/v +;; z93HNJa4+Hj7fr0+3mxs54vTw1e7BM+vh9n7T8PBbPlx8jD/k9HT4WzsRzfP +;; 0/aFtVi+vNl9W75b4MODhwv2C7c4vz/e7C8/zzK+8Iav6ycLPJ1Ol3/zAPv5 +;; N5vfo7tnN+vZuIFNJvJ5frYvrOHLh8nJyfjjuOsM1/slPH53uNmPTnYDD8dH +;; R5ut4uGFdf9F6WQy3C3wdPbmdjKZDNsw7u56PPMw3F6cXS6vDs/u57/66cE2 +;; o+e3w+fP203p7RvdPDvbF9bx/GY935/bvYDuPsa//IeBH473jufrH+9+cu54 +;; f9dPM893u9QPcz4dnT+emGfDP+dE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6R +;; dIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i +;; 6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE +;; 0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSI +;; pEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQ +;; SYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIh +;; kg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRD +;; JB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmH +;; SDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIO +;; kXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQd +;; IukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0iKRDJB0i6RBJh0g6 +;; RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLpEEmHSDpE0iGSDpF0 +;; iKRDJB0i6RBJh0g6RNIhkg6RdIikQyQdIukQSYdIOkTSIZIOkXSIpEMkHSLp +;; EEmHSDpE0iGSDpF0iKRDJB0i6RBJh+gv8TgE/jVPQbMAAAAASUVORK5CYII= +;; ===="))))) +;; +;; ;; sheetdat is '("sheetname" (r1c1 r2c2 ...)(r2c1 r2c2 ...) ...) +;; (define (ods:sheet sheetdat) +;; (let ((name (car sheetdat)) +;; (rows (cdr sheetdat))) +;; (conc "\n" +;; (conc (ods:column) +;; (string-join (map ods:row rows) "")) +;; ""))) +;; +;; ;; seems to be called once at top of each sheet, i.e. a column of rows +;; (define (ods:column) +;; "\n") +;; +;; ;; cells is a list of ... +;; (define (ods:row cells) +;; (conc "\n" +;; (string-join (map ods:cell cells) "") +;; "\n")) +;; +;; ;; types are "string" or "float" +;; (define (ods:cell value) +;; (let* ((type (cond +;; ((string? value) "string") +;; ((symbol? value) "string") +;; ((number? value) "float") +;; (else #f))) +;; (tmpval (if (symbol? value) +;; (symbol->string value) +;; (if type value ""))) ;; convert everything else to an empty string +;; (escval (if (string? tmpval)(string-substitute (regexp "<") "<" (string-substitute (regexp ">") ">" tmpval)) tmpval))) +;; (conc "\n" +;; "" escval "" "\n" +;; "" "\n"))) +;; +;; ;; create the directories +;; (define (ods:construct-dir path) +;; (for-each +;; (lambda (subdir) +;; (system (conc "mkdir -p " path "/" subdir))) +;; ods:dirs)) +;; +;; ;; populate the necessary, non-constructed, files +;; (define (ods:add-non-content-files path) +;; ;; first the zero-length files, nb// the dir should already be created +;; (for-each +;; (lambda (fname) +;; (system (conc "touch " path "/" fname))) +;; ods:0-len-files) +;; ;; create the files with stuff in them +;; (for-each +;; (lambda (fdat) +;; (let* ((name (car fdat)) +;; (lines (cadr fdat))) +;; (with-output-to-file (conc path "/" name) +;; (lambda () +;; (for-each +;; (lambda (line) +;; (display line)) +;; lines))))) +;; ods:files)) +;; +;; ;; data format: +;; ;; '( (sheet1 (r1c1 r1c2 r1c3 ...) +;; ;; (r2c1 r2c3 r2c3 ...) ) +;; ;; (sheet2 ( ... ) +;; ;; ( ... ) ) ) +;; (define (ods:list->ods path fname data) +;; (if (not (file-exists? path)) +;; (print "ERROR: path to create ods data must pre-exist") +;; (begin +;; (with-output-to-file (conc path "/content.xml") +;; (lambda () +;; (ods:construct-dir path) +;; (ods:add-non-content-files path) +;; (ods:make-thumbnail path) +;; (map display ods:content-header) +;; ;; process each sheet +;; (map print +;; (map ods:sheet data)) +;; (map display ods:content-footer))) +;; (system (conc "cd " path "; zip " fname " -n mimetype mimetype `find . |grep -v mimetype` > /dev/null"))))) +;; +;; ) Index: process-inc.scm ================================================================== --- process-inc.scm +++ process-inc.scm @@ -20,13 +20,10 @@ ;;====================================================================== ;; Process convience utils ;;====================================================================== -(use regex directory-utils) -(declare (unit process)) - (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) res))) Index: processmod.scm ================================================================== --- processmod.scm +++ processmod.scm @@ -30,247 +30,247 @@ ;; (import commonmod) ;; (use (prefix ulex ulex:)) (include "common_records.scm") - - -;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) -;; execute thunk in context of environment modified as per this list -;; restore env to prior state then return value of eval'd thunk. -;; ** this is not thread safe ** -(define (common:with-env-vars delta-env-alist-or-hash-table thunk) - (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) - (hash-table->alist delta-env-alist-or-hash-table) - delta-env-alist-or-hash-table)) - (restore-thunks - (filter - identity - (map (lambda (env-pair) - (let* ((env-var (car env-pair)) - (new-val (let ((tmp (cdr env-pair))) - (if (list? tmp) (car tmp) tmp))) - (current-val (get-environment-variable env-var)) - (restore-thunk - (cond - ((not current-val) (lambda () (unsetenv env-var))) - ((not (string? new-val)) #f) - ((eq? current-val new-val) #f) - (else - (lambda () (setenv env-var current-val)))))) - ;;(when (not (string? new-val)) - ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) - ;; (pp delta-env-alist) - ;; (exit 1)) - - - (cond - ((not new-val) ;; modify env here - (unsetenv env-var)) - ((string? new-val) - (setenv env-var new-val))) - restore-thunk)) - delta-env-alist)))) - (let ((rv (thunk))) - (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state - rv))) - -(define (process:conservative-read port) - (let loop ((res "")) - (if (not (eof-object? (peek-char port))) - (loop (conc res (read-char port))) - res))) - -(define (process:cmd-run-with-stderr->list cmd . params) - ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) -;; (handle-exceptions -;; exn -;; (begin -;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) -;; (print " " ((condition-property-accessor 'exn 'message) exn)) -;; #f) - (let-values (((fh fho pid fhe) (if (null? params) - (process* cmd) - (process* cmd params)))) - (let loop ((curr (read-line fh)) - (result '())) - (let ((errstr (process:conservative-read fhe))) - (if (not (string=? errstr "")) - (set! result (append result (list errstr))))) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list curr))) - (begin - (close-input-port fh) - (close-input-port fhe) - (close-output-port fho) - result))))) ;; ) - -(define (process:cmd-run-with-stderr-and-exitcode->list cmd . params) - ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) -;; (handle-exceptions -;; exn -;; (begin -;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) -;; (print " " ((condition-property-accessor 'exn 'message) exn)) -;; #f) - (let-values (((fh fho pid fhe) (if (null? params) - (process* cmd) - (process* cmd params)))) - (let loop ((curr (read-line fh)) - (result '())) - (let ((errstr (process:conservative-read fhe))) - (if (not (string=? errstr "")) - (set! result (append result (list errstr))))) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list curr))) - (begin - (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) - (close-input-port fh) - (close-input-port fhe) - (close-output-port fho) - (list result (if normalexit? exitstatus -1)))))))) - -(define (process:cmd-run-proc-each-line cmd proc . params) - ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) - (handle-exceptions - exn - (begin - (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (debug:print 5 *default-log-port* "exn=" (condition->list exn)) - #f) - (let-values (((fh fho pid) (if (null? params) - (process cmd) - (process cmd params)))) - (let loop ((curr (read-line fh)) - (result '())) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list (proc curr)))) - (begin - (close-input-port fh) - ;; (close-input-port fhe) - (close-output-port fho) - result)))))) - -(define (process:cmd-run-proc-each-line-alt cmd proc) - (let* ((fh (open-input-pipe cmd)) - (res (port-proc->list fh proc)) - (status (close-input-pipe fh))) - (if (eq? status 0) res #f))) - -(define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) - (common:with-env-vars - delta-env-alist-or-hash-table - (lambda () - (let* ((fh (open-input-pipe cmd)) - (res (port->list fh)) - (status (close-input-pipe fh))) - (list res status))))) - -(define (port->list fh) - (if (eof-object? fh) #f - (let loop ((curr (read-line fh)) - (result '())) - (if (not (eof-object? curr)) - (loop (read-line fh) - (append result (list curr))) - result)))) - -(define (port-proc->list fh proc) - (if (eof-object? fh) #f - (let loop ((curr (proc (read-line fh))) - (result '())) - (if (not (eof-object? curr)) - (loop (let ((l (read-line fh))) - (if (eof-object? l) l (proc l))) - (append result (list curr))) - result)))) - -;; here is an example line where the shell is sh or bash -;; "find / -print 2&>1 > findall.log" -(define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f)) - (if print-cmd - (debug:print 0 *default-log-port* - (if (string? print-cmd) - print-cmd - "") - (if run-dir (conc "Run in " run-dir ";") "") - cmdline - (if params - (conc " " (string-intersperse params " ")) - ""))) - (if (and run-dir - (directory-exists? run-dir)) - (push-directory run-dir)) - (let ((pid (if params - (process-run cmdline params) - (process-run cmdline)))) - (let loop ((i 0)) - (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) - (if (eq? pid-val 0) - (begin - (thread-sleep! 2) - (loop (+ i 1))) - (begin - (if (and run-dir - (directory-exists? run-dir)) - (pop-directory)) - (values pid-val exit-status exit-code))))))) - -;;====================================================================== -;; MISC PROCESS RELATED STUFF -;;====================================================================== - -(define (process:children proc) - (with-input-from-pipe - (conc "ps h --ppid " (current-process-id) " -o pid") - (lambda () - (let loop ((inl (read-line)) - (res '())) - (if (eof-object? inl) - (reverse res) - (let ((pid (string->number inl))) - (if proc (proc pid)) - (loop (read-line) (cons pid res)))))))) - -(define (process:alive? pid) - (handle-exceptions - exn - ;; possibly pid is a process not a child, look in /proc to see if it is running still - (file-exists? (conc "/proc/" pid)) - (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) - (and (number? rpid) - (equal? rpid pid))))) - -(define (process:alive-on-host? host pid) - (let ((cmd (conc "ssh " host " ps -o pid= -p " pid))) - (handle-exceptions - exn - #f ;; anything goes wrong - assume the process in NOT running. - (with-input-from-pipe - cmd - (lambda () - (let loop ((inl (read-line))) - (if (eof-object? inl) - #f - (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl)) - (innum (string->number clean-str))) - (and innum - (eq? pid innum)))))))))) - -(define (process:get-sub-pids pid) - (with-input-from-pipe - (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid) - (lambda () - (let loop ((inl (read-line)) - (res '())) - (if (eof-object? inl) - (reverse res) - (let ((nums (map string->number - (string-split-fields "\\d+" inl)))) - (loop (read-line) - (append res nums)))))))) +;; +;; +;; ;; accept an alist or hash table containing envvar/env value pairs (value of #f causes unset) +;; ;; execute thunk in context of environment modified as per this list +;; ;; restore env to prior state then return value of eval'd thunk. +;; ;; ** this is not thread safe ** +;; (define (common:with-env-vars delta-env-alist-or-hash-table thunk) +;; (let* ((delta-env-alist (if (hash-table? delta-env-alist-or-hash-table) +;; (hash-table->alist delta-env-alist-or-hash-table) +;; delta-env-alist-or-hash-table)) +;; (restore-thunks +;; (filter +;; identity +;; (map (lambda (env-pair) +;; (let* ((env-var (car env-pair)) +;; (new-val (let ((tmp (cdr env-pair))) +;; (if (list? tmp) (car tmp) tmp))) +;; (current-val (get-environment-variable env-var)) +;; (restore-thunk +;; (cond +;; ((not current-val) (lambda () (unsetenv env-var))) +;; ((not (string? new-val)) #f) +;; ((eq? current-val new-val) #f) +;; (else +;; (lambda () (setenv env-var current-val)))))) +;; ;;(when (not (string? new-val)) +;; ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) +;; ;; (pp delta-env-alist) +;; ;; (exit 1)) +;; +;; +;; (cond +;; ((not new-val) ;; modify env here +;; (unsetenv env-var)) +;; ((string? new-val) +;; (setenv env-var new-val))) +;; restore-thunk)) +;; delta-env-alist)))) +;; (let ((rv (thunk))) +;; (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state +;; rv))) +;; +;; (define (process:conservative-read port) +;; (let loop ((res "")) +;; (if (not (eof-object? (peek-char port))) +;; (loop (conc res (read-char port))) +;; res))) +;; +;; (define (process:cmd-run-with-stderr->list cmd . params) +;; ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) +;; ;; (handle-exceptions +;; ;; exn +;; ;; (begin +;; ;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) +;; ;; (print " " ((condition-property-accessor 'exn 'message) exn)) +;; ;; #f) +;; (let-values (((fh fho pid fhe) (if (null? params) +;; (process* cmd) +;; (process* cmd params)))) +;; (let loop ((curr (read-line fh)) +;; (result '())) +;; (let ((errstr (process:conservative-read fhe))) +;; (if (not (string=? errstr "")) +;; (set! result (append result (list errstr))))) +;; (if (not (eof-object? curr)) +;; (loop (read-line fh) +;; (append result (list curr))) +;; (begin +;; (close-input-port fh) +;; (close-input-port fhe) +;; (close-output-port fho) +;; result))))) ;; ) +;; +;; (define (process:cmd-run-with-stderr-and-exitcode->list cmd . params) +;; ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) +;; ;; (handle-exceptions +;; ;; exn +;; ;; (begin +;; ;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) +;; ;; (print " " ((condition-property-accessor 'exn 'message) exn)) +;; ;; #f) +;; (let-values (((fh fho pid fhe) (if (null? params) +;; (process* cmd) +;; (process* cmd params)))) +;; (let loop ((curr (read-line fh)) +;; (result '())) +;; (let ((errstr (process:conservative-read fhe))) +;; (if (not (string=? errstr "")) +;; (set! result (append result (list errstr))))) +;; (if (not (eof-object? curr)) +;; (loop (read-line fh) +;; (append result (list curr))) +;; (begin +;; (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) +;; (close-input-port fh) +;; (close-input-port fhe) +;; (close-output-port fho) +;; (list result (if normalexit? exitstatus -1)))))))) +;; +;; (define (process:cmd-run-proc-each-line cmd proc . params) +;; ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) +;; (handle-exceptions +;; exn +;; (begin +;; (print "ERROR: Failed to run command: " cmd " " (string-intersperse params " ")) +;; (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) +;; (debug:print 5 *default-log-port* "exn=" (condition->list exn)) +;; #f) +;; (let-values (((fh fho pid) (if (null? params) +;; (process cmd) +;; (process cmd params)))) +;; (let loop ((curr (read-line fh)) +;; (result '())) +;; (if (not (eof-object? curr)) +;; (loop (read-line fh) +;; (append result (list (proc curr)))) +;; (begin +;; (close-input-port fh) +;; ;; (close-input-port fhe) +;; (close-output-port fho) +;; result)))))) +;; +;; (define (process:cmd-run-proc-each-line-alt cmd proc) +;; (let* ((fh (open-input-pipe cmd)) +;; (res (port-proc->list fh proc)) +;; (status (close-input-pipe fh))) +;; (if (eq? status 0) res #f))) +;; +;; (define (process:cmd-run->list cmd #!key (delta-env-alist-or-hash-table '())) +;; (common:with-env-vars +;; delta-env-alist-or-hash-table +;; (lambda () +;; (let* ((fh (open-input-pipe cmd)) +;; (res (port->list fh)) +;; (status (close-input-pipe fh))) +;; (list res status))))) +;; +;; (define (port->list fh) +;; (if (eof-object? fh) #f +;; (let loop ((curr (read-line fh)) +;; (result '())) +;; (if (not (eof-object? curr)) +;; (loop (read-line fh) +;; (append result (list curr))) +;; result)))) +;; +;; (define (port-proc->list fh proc) +;; (if (eof-object? fh) #f +;; (let loop ((curr (proc (read-line fh))) +;; (result '())) +;; (if (not (eof-object? curr)) +;; (loop (let ((l (read-line fh))) +;; (if (eof-object? l) l (proc l))) +;; (append result (list curr))) +;; result)))) +;; +;; ;; here is an example line where the shell is sh or bash +;; ;; "find / -print 2&>1 > findall.log" +;; (define (run-n-wait cmdline #!key (params #f)(print-cmd #f)(run-dir #f)) +;; (if print-cmd +;; (debug:print 0 *default-log-port* +;; (if (string? print-cmd) +;; print-cmd +;; "") +;; (if run-dir (conc "Run in " run-dir ";") "") +;; cmdline +;; (if params +;; (conc " " (string-intersperse params " ")) +;; ""))) +;; (if (and run-dir +;; (directory-exists? run-dir)) +;; (push-directory run-dir)) +;; (let ((pid (if params +;; (process-run cmdline params) +;; (process-run cmdline)))) +;; (let loop ((i 0)) +;; (let-values (((pid-val exit-status exit-code) (process-wait pid #t))) +;; (if (eq? pid-val 0) +;; (begin +;; (thread-sleep! 2) +;; (loop (+ i 1))) +;; (begin +;; (if (and run-dir +;; (directory-exists? run-dir)) +;; (pop-directory)) +;; (values pid-val exit-status exit-code))))))) +;; +;; ;;====================================================================== +;; ;; MISC PROCESS RELATED STUFF +;; ;;====================================================================== +;; +;; (define (process:children proc) +;; (with-input-from-pipe +;; (conc "ps h --ppid " (current-process-id) " -o pid") +;; (lambda () +;; (let loop ((inl (read-line)) +;; (res '())) +;; (if (eof-object? inl) +;; (reverse res) +;; (let ((pid (string->number inl))) +;; (if proc (proc pid)) +;; (loop (read-line) (cons pid res)))))))) +;; +;; (define (process:alive? pid) +;; (handle-exceptions +;; exn +;; ;; possibly pid is a process not a child, look in /proc to see if it is running still +;; (file-exists? (conc "/proc/" pid)) +;; (let-values (((rpid exit-type exit-signal)(process-wait pid #t))) +;; (and (number? rpid) +;; (equal? rpid pid))))) +;; +;; (define (process:alive-on-host? host pid) +;; (let ((cmd (conc "ssh " host " ps -o pid= -p " pid))) +;; (handle-exceptions +;; exn +;; #f ;; anything goes wrong - assume the process in NOT running. +;; (with-input-from-pipe +;; cmd +;; (lambda () +;; (let loop ((inl (read-line))) +;; (if (eof-object? inl) +;; #f +;; (let* ((clean-str (string-substitute "^[^\\d]*([0-9]+)[^\\d]*$" "\\1" inl)) +;; (innum (string->number clean-str))) +;; (and innum +;; (eq? pid innum)))))))))) +;; +;; (define (process:get-sub-pids pid) +;; (with-input-from-pipe +;; (conc "pstree -A -p " pid) ;; | tr 'a-z\\-+`()\\.' ' ' " pid) +;; (lambda () +;; (let loop ((inl (read-line)) +;; (res '())) +;; (if (eof-object? inl) +;; (reverse res) +;; (let ((nums (map string->number +;; (string-split-fields "\\d+" inl)))) +;; (loop (read-line) +;; (append res nums)))))))) ) Index: rmt-inc.scm ================================================================== --- rmt-inc.scm +++ rmt-inc.scm @@ -16,20 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; ;;====================================================================== -(use format typed-records) ;; RADT => purpose of json format?? - -(declare (unit rmt)) -(declare (uses api)) -(declare (uses http-transport)) -(include "common_records.scm") -(declare (uses rmtmod)) - -(import rmtmod) - ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following Index: runconfig-inc.scm ================================================================== --- runconfig-inc.scm +++ runconfig-inc.scm @@ -18,17 +18,10 @@ ;;====================================================================== ;; read a config file, loading only the section pertinent ;; to this run field1val/field2val/field3val ... ;;====================================================================== -(use format directory-utils) - -(declare (unit runconfig)) -(declare (uses common)) - -(include "common_records.scm") - (define (runconfig:read fname target environ-patt) (let ((ht (make-hash-table))) (if target (hash-table-set! ht target '())) (read-config fname ht #t environ-patt: environ-patt sections: (if target (list "default" target) #f)))) Index: runs-inc.scm ================================================================== --- runs-inc.scm +++ runs-inc.scm @@ -15,32 +15,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) -;; (declare (uses filedb)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - -;; (include "debugger.scm") - ;; use this struct to facilitate refactoring ;; (defstruct runs:dat reglen regfull Index: server-inc.scm ================================================================== --- server-inc.scm +++ server-inc.scm @@ -15,31 +15,10 @@ ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest - directory-utils posix-extras matchable) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(declare (unit server)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -;; (declare (uses synchash)) -(declare (uses http-transport)) -;;(declare (uses rpc-transport)) -(declare (uses launch)) -;; (declare (uses daemon)) - -(include "common_records.scm") -(include "db_records.scm") - (define (server:make-server-url hostport) (if (not hostport) #f (conc "http://" (car hostport) ":" (cadr hostport)))) Index: subrun-inc.scm ================================================================== --- subrun-inc.scm +++ subrun-inc.scm @@ -16,31 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format - call-with-environment-variables) -(declare (unit subrun)) -;;(declare (uses runs)) -(declare (uses db)) -(declare (uses common)) -;;(declare (uses items)) -;;(declare (uses runconfig)) -;;(declare (uses tests)) -;;(declare (uses server)) -(declare (uses mt)) -;;(declare (uses archive)) -;; (declare (uses filedb)) - -;(include "common_records.scm") -;;(include "key_records.scm") -(include "db_records.scm") ;; provides db:test-get-id -;;(include "run_records.scm") -;;(include "test_records.scm") - (define (subrun:subrun-test-initialized? test-run-dir) (if (and (common:file-exists? (conc test-run-dir "/subrun-area") ) (common:file-exists? (conc test-run-dir "/testconfig.subrun") )) #t #f)) Index: tasks-inc.scm ================================================================== --- tasks-inc.scm +++ tasks-inc.scm @@ -16,24 +16,10 @@ ;; along with Megatest. If not, see . ;; ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit tasks)) -(declare (uses db)) -(declare (uses rmt)) -(declare (uses common)) -(declare (uses pgdb)) - -;; (import pgdb) ;; pgdb is a module - -(include "task_records.scm") -(include "db_records.scm") - ;;====================================================================== ;; Tasks db ;;====================================================================== ;; wait up to aprox n seconds for a journal to go away Index: tests-inc.scm ================================================================== --- tests-inc.scm +++ tests-inc.scm @@ -20,32 +20,10 @@ ;;====================================================================== ;; Tests ;;====================================================================== -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) -(import (prefix sqlite3 sqlite3:)) -(require-library stml) - -(declare (unit tests)) -(declare (uses lock-queue)) -(declare (uses db)) -(declare (uses tdb)) -(declare (uses common)) -;; (declare (uses dcommon)) ;; needed for the steps processing -(declare (uses items)) -(declare (uses runconfig)) -;; (declare (uses sdb)) -(declare (uses server)) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") -(include "js-path.scm") - ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; Index: vg-inc.scm ================================================================== --- vg-inc.scm +++ vg-inc.scm @@ -16,18 +16,10 @@ ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see . ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use typed-records srfi-1) - -(declare (unit vg)) -(use canvas-draw iup) -(import canvas-draw-iup) - -(include "vg_records.scm") - ;; ;; structs ;; ;; ;; (defstruct vg:lib comps) ;; (defstruct vg:comp objs name file) ;; ;; extents caches extents calculated on draw