Changes In Branch v1.70-ck5 Through [da6fbf9f56] Excluding Merge-Ins
This is equivalent to a diff from ba39e7edd8 to da6fbf9f56
2022-07-14
| ||
10:31 | updated mt-old-to-new.sh to fix the wrap arround check-in: 3d09b9433e user: pjhatwal tags: v1.70 | |
2022-06-27
| ||
12:52 | Compiles check-in: 786ae4bacc user: matt tags: v1.70-ck5 | |
11:34 | Migrate to ck5 (again) check-in: da6fbf9f56 user: matt tags: v1.70-ck5 | |
09:00 | Merged forward the beginnings of nohome Closed-Leaf check-in: 3b3dbdec4b user: matt tags: v1.70-nohome-00 | |
2022-06-13
| ||
19:25 | Changed megatest version to v1.7004 check-in: ba39e7edd8 user: mmgraham tags: v1.70, v1.7004 | |
17:44 | Got pgdb sync working by querying for test related data in the correct dbs, passing the test ids, test_step ids and test_data ids as pairs with the run-id, and adding run-id to a few test data query functions. check-in: 6fb02466de user: mmgraham tags: v1.70 | |
Modified Makefile from [9727712751] to [e4815dcfcc].
︙ | ︙ | |||
26 27 28 29 30 31 32 | process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files | | | < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | process.scm runs.scm tasks.scm tests.scm genexample.scm \ http-transport.scm tdb.scm client.scm mt.scm \ ezsteps.scm lock-queue.scm rmt.scm api.scm \ subrun.scm portlogger.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \ ducttape-lib.scm pkts.scm dbi.scm # ftail.scm rmtmod.scm commonmod.scm removed # MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \ # mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \ # rmtmod.scm apimod.scm GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \ |
︙ | ︙ | |||
150 151 152 153 154 155 156 | fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes | | > > > > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js $(PREFIX)/share/db/mt-pg.sql : mt-pg.sql mkdir -p $(PREFIX)/share/db $(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql # Special dependencies for the includes $(MOFILE) $(MOIMPFILES) $(MSRCFILES) : megatest-fossil-hash.scm mofiles/pkts.o : mofiles/dbi.o mofiles/dbfile.o : mofiles/debugprint.o mofiles/debugprint.o : mofiles/mtargs.o common.o : mofiles/commonmod.o megatest-fossil-hash.scm # mofiles/dbmod.o : mofiles/configfmod.o # commonmod.o dashboard.o megatest.o tcmt.o apimod.o : megatest-fossil-hash.scm |
︙ | ︙ |
Modified TODO from [da5eae4898] to [8c7ba74ce3].
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. TODO ==== WW15 . fill newview matrix with data, filter pipeline gui elements . improve [script], especially indent handling WW16 . split db into megatest.db (runs etc.) db/<something>.db | > > > > > > > > > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. TODO ==== Loose ends ---------- 15:09:29 error in calling find-and-mark-incomplete for run-id 5, exn=#<condition: (exn type)> might be related to initial conditions in the db. (no run entry in runs table?). . -list-servers not correct . move *remotedat* into bigdata . add back server stats on exit (look in rmt:run in rmtmod.scm) WW15 . fill newview matrix with data, filter pipeline gui elements . improve [script], especially indent handling WW16 . split db into megatest.db (runs etc.) db/<something>.db |
︙ | ︙ |
Modified cgisetup/models/pgdb.scm from [4136225c9c] to [3f24f4a8cc].
︙ | ︙ | |||
14 15 16 17 18 19 20 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== | | | | | | | | | | | | | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== ;; (declare (unit pgdb)) ;; (declare (uses configf)) ;; ;; ;; I don't know how to mix compilation units and modules, so no module here. ;; ;; ;; ;; (module pgdb ;; ;; ( ;; ;; open-pgdb ;; ;; ) ;; ;; ;; ;; (import scheme) ;; ;; (import data-structures) ;; ;; (import chicken) ;; ;; (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) (let ((pgconf (or dbispec (args:get-arg "-pgsync") (if configdat |
︙ | ︙ |
Modified common.scm from [a70e001edf] to [511916cc75].
︙ | ︙ | |||
200 201 202 203 204 205 206 | ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) (use posix-extras pathname-expand files) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers (define *numcpus-cache* (make-hash-table)) (use posix-extras pathname-expand files) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) #;(let-values (( (chicken-release-number chicken-major-version) (apply values (map string->number (take (string-split (chicken-version) ".") 2))))) (let ((resolve-pathname-broken? (or (> chicken-release-number 4) |
︙ | ︙ |
Modified commonmod.scm from [79bf78cc96] to [7b81cda74c].
︙ | ︙ | |||
21 22 23 24 25 26 27 | (declare (unit commonmod)) (use srfi-69) (module commonmod * | > > > > > > > > > > > > > > | | | > > > | > | > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | (declare (unit commonmod)) (use srfi-69) (module commonmod * (import scheme chicken.base chicken.condition chicken.file chicken.file.posix chicken.io chicken.pathname chicken.process-context chicken.process-context.posix chicken.string chicken.time system-information ;; data-structures extras files (prefix sqlite3 sqlite3:) ;; posix typed-records srfi-18 srfi-69 md5 message-digest regex srfi-1 ) ;;====================================================================== ;; CONTENTS ;; ;; config file utils ;; misc conversion, data manipulation functions ;; testsuite and area utilites |
︙ | ︙ |
Modified configure from [08e182d3ee] to [8c62b68887].
︙ | ︙ | |||
13 14 15 16 17 18 19 | # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. | < | < < < < < | < < < | < < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | < < | < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Megatest. If not, see <http://www.gnu.org/licenses/>. # Flavors include: simple, full and none # look at build.config (not a version controlled file and # create ulex.scm and dbmgr.scm if [[ -e transport-flavor ]];then FLAVOR=$(cat transport-flavor) else FLAVOR=simple fi sed -e "s/FLAVOR/$FLAVOR/" ulex.scm.template > ulex.scm sed -e "s/FLAVOR/$FLAVOR/" dbmgrmod.scm.template > dbmgrmod.scm |
Modified dbfile.scm from [2cf29f02a0] to [b093af9538].
︙ | ︙ | |||
21 22 23 24 25 26 27 | (declare (unit dbfile)) ;; (declare (uses debugprint)) (declare (uses commonmod)) (module dbfile * | | > > > > > > | > > > > > > > | | | < | > | > > | | > | | | | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | (declare (unit dbfile)) ;; (declare (uses debugprint)) (declare (uses commonmod)) (module dbfile * (import scheme chicken.base chicken.condition chicken.file chicken.file.posix chicken.io chicken.port chicken.process chicken.process-context.posix chicken.sort chicken.time chicken.string ;; data-structures ;; extras matchable (prefix sqlite3 sqlite3:) ;; posix typed-records srfi-18 srfi-1 srfi-69 stack system-information ;; files ;; ports commonmod ) ;; (import debugprint) ;;====================================================================== ;; R E C O R D S ;;====================================================================== |
︙ | ︙ | |||
310 311 312 313 314 315 316 | ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (dbfile:open-sqlite3-db dbpath init-proc) (let* ((dbexists (file-exists? dbpath)) | | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 | ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; (define (dbfile:open-sqlite3-db dbpath init-proc) (let* ((dbexists (file-exists? dbpath)) (write-access (file-writable? dbpath)) (db (dbfile:cautious-open-database dbpath init-proc))) #;(sqlite3:open-database dbpath) (dbfile:inc-db-open dbpath) (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000)) (sqlite3:execute db (conc "PRAGMA synchronous = 0;")) ;; (init-proc db) (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access)))) |
︙ | ︙ | |||
489 490 491 492 493 494 495 | (let* ((busy-file (conc fname"-journal")) (delay-time (* (- 51 tries-left) 1.1)) (retry (lambda () (thread-sleep! delay-time) (if (> tries-left 0) (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) | | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 | (let* ((busy-file (conc fname"-journal")) (delay-time (* (- 51 tries-left) 1.1)) (retry (lambda () (thread-sleep! delay-time) (if (> tries-left 0) (dbfile:cautious-open-database fname init-proc (- tries-left 1)))))) (assert (>= tries-left 0) (conc "FATAL: too many attempts in dbfile:cautious-open-database of "fname", giving up.")) (if (and (file-writable? fname) (file-exists? busy-file)) (begin (dbfile:print-err "INFO: dbfile:cautious-open-database: journal file " busy-file " exists, trying again in few seconds.") (thread-sleep! 1) (if (eq? tries-left 2) (begin (dbfile:print-err "INFO: forcing journal rollup "busy-file) |
︙ | ︙ | |||
884 885 886 887 888 889 890 | ((not (sqlite3:database? (dbr:dbdat-dbh fromdb))) (dbfile:print-err "db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (dbr:dbdat-dbh todb))) (dbfile:print-err "db:sync-tables called with todb not a database " todb) -4) | | | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 | ((not (sqlite3:database? (dbr:dbdat-dbh fromdb))) (dbfile:print-err "db:sync-tables called with fromdb not a database " fromdb) -3) ((not (sqlite3:database? (dbr:dbdat-dbh todb))) (dbfile:print-err "db:sync-tables called with todb not a database " todb) -4) ((not (file-writable? (dbr:dbdat-dbfile todb))) (dbfile:print-err "db:sync-tables called with todb not a read-only database " todb) -5) ((not (null? (let ((readonly-slave-dbs (filter (lambda (dbdat) (not (file-writable? (dbr:dbdat-dbfile todb)))) slave-dbs))) (for-each (lambda (bad-dbdat) (dbfile:print-err "db:sync-tables called with todb not a read-only database " bad-dbdat)) readonly-slave-dbs) readonly-slave-dbs))) -6) (else ;; (dbfile:print-err "db:sync-tables: args are good") (let ((stmts (make-hash-table)) ;; table-field => stmt (all-stmts '()) ;; ( ( stmt1 value1 ) ( stml2 value2 )) (numrecs (make-hash-table)) (start-time (current-process-milliseconds)) (tot-count 0)) (for-each ;; table (lambda (tabledat) (let* ((tablename (car tabledat)) (fields (cdr tabledat)) (has-last-update (member "last_update" fields)) (use-last-update (cond |
︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 | (if (member "last_update" field-names) (db:create-trigger db tablename)))) (append (list todb) slave-dbs) ) ) ) tbls) | | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 | (if (member "last_update" field-names) (db:create-trigger db tablename)))) (append (list todb) slave-dbs) ) ) ) tbls) (let* ((runtime (- (current-process-milliseconds) start-time)) (should-print (or ;; (debug:debug-mode 12) (common:low-noise-print 120 "db sync" (> runtime 500))))) ;; low and high sync times treated as separate. (if should-print (dbfile:print-err "INFO: db sync, total run time " runtime " ms")) (for-each (lambda (dat) (let ((tblname (car dat)) (count (cdr dat))) |
︙ | ︙ |
Modified dbmod.scm from [043beb90c3] to [1c8d71a217].
︙ | ︙ | |||
19 20 21 22 23 24 25 | ;;====================================================================== (declare (unit dbmod)) (module dbmod * | > > > | | > | | > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | ;;====================================================================== (declare (unit dbmod)) (module dbmod * (import scheme chicken.string ;; chicken data-structures extras (prefix sqlite3 sqlite3:) ;; posix typed-records srfi-18 srfi-69 ) (define (db:run-id->dbname run-id) (cond ((number? run-id)(conc run-id ".db")) ((not run-id) "main.db") (else run-id))) |
︙ | ︙ |
Modified debugprint.scm from [54f7083883] to [cb27731940].
1 2 3 4 5 6 7 8 9 10 | (declare (unit debugprint)) (declare (uses mtargs)) (module debugprint * ;;(import scheme chicken data-structures extras files ports) (import scheme | > > > > > | > > | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | (declare (unit debugprint)) (declare (uses mtargs)) (module debugprint * ;;(import scheme chicken data-structures extras files ports) (import scheme chicken.base chicken.process-context chicken.process-context.posix chicken.time chicken.port chicken.time.posix chicken.string system-information ;; data-structures ;; posix ;; ports ;; extras ;; scheme ;; chicken.base ;; chicken.string ;; chicken.time ;; chicken.time.posix ;; chicken.port |
︙ | ︙ | |||
43 44 45 46 47 48 49 | (verbosity (debug:calc-verbosity debugstr 'q)) (debug:check-verbosity (verbosity) debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not (verbosity))(verbosity 1)) (if (and (not (args:get-arg "-debug-noprop")) (or (args:get-arg "-debug") (not (get-environment-variable "MT_DEBUG_MODE")))) | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | (verbosity (debug:calc-verbosity debugstr 'q)) (debug:check-verbosity (verbosity) debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not (verbosity))(verbosity 1)) (if (and (not (args:get-arg "-debug-noprop")) (or (args:get-arg "-debug") (not (get-environment-variable "MT_DEBUG_MODE")))) (set-environment-variable! "MT_DEBUG_MODE" (if (list? (verbosity)) (string-intersperse (map conc (verbosity)) ",") (conc (verbosity))))))) ;; check verbosity, #t is ok (define (debug:check-verbosity verbosity vstr) (if (not (or (number? verbosity) (list? verbosity))) |
︙ | ︙ |
Modified diff-report.scm from [722e4fdcd5] to [6d3c4f6f16].
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (declare (unit diff-report)) (declare (uses common)) (declare (uses rmt)) (include "common_records.scm") | > > | | | > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (declare (unit diff-report)) (declare (uses common)) (declare (uses rmt)) (declare (uses ducttape-lib)) (include "common_records.scm") (import matchable fmt ducttape-lib) (define css "") (define (diff:tests-mindat->hash tests-mindat) (let* ((res (make-hash-table))) (for-each (lambda (item) (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1))) |
︙ | ︙ |
Modified ducttape/ducttape-lib.scm from [59b0a2f94a] to [eeb65452c2].
︙ | ︙ | |||
42 43 44 45 46 47 48 | seconds->wwdate-values isodate->seconds isodate->wwdate wwdate->seconds wwdate->isodate current-wwdate current-isodate | | | | > > | > | > > > > > > > > > > > > > > > > > > > > > | > > | | | > > > > > | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | seconds->wwdate-values isodate->seconds isodate->wwdate wwdate->seconds wwdate->isodate current-wwdate current-isodate ;; *this-exe-dir* ;; *this-exe-name* ;; *this-exe-fullpath* ) (import scheme ;; chicken extras ports data-structures ) ;; (use posix regex ansi-escape-sequences test srfi-1 chicken.base chicken.condition chicken.file chicken.file.posix chicken.format chicken.irregex chicken.io chicken.string chicken.time chicken.time.posix chicken.pathname chicken.port chicken.process chicken.process-context chicken.process-context.posix slice srfi-13 srfi-19 rfc3339 ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process* ;; directory-utils uuid-lib ;; filepath srfi-19 ) ; linenoise ;; plugs a hole in posix-extras in latter chicken versions ;; (use posix-extras pathname-expand files) srfi-19 test ;;(use format) ) ;; (define ##sys#expand-home-path pathname-expand) ;; (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) ;; (include "mimetypes.scm") ; provides ext->mimetype ;; (include "workweekdate.scm") ;; gathered from macosx: ;; cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm ;; + manual manipulation |
︙ | ︙ | |||
839 840 841 842 843 844 845 | ("wmx" . "video/x-ms-wmx") ("wvx" . "video/x-ms-wvx") ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) | < < < < | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 | ("wmx" . "video/x-ms-wmx") ("wvx" . "video/x-ms-wvx") ("avi" . "video/x-msvideo") ("movie" . "video/x-sgi-movie") ("smv" . "video/x-smv") ("ice" . "x-conference/x-cooltalk"))) ;(declare (unit wwdate)) ;; utility procedures to convert among ;; different ways to express date (wwdate, seconds since epoch, isodate) ;; ;; samples: ;; isodate -> "2016-01-01" ;; wwdate -> "16ww01.5" |
︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 | (let loop ((rest-path-items path-items)) (if (null? rest-path-items) #f (let* ((this-dir (car rest-path-items)) (next-rest (cdr rest-path-items)) (candidate (conc this-dir "/" exe))) | | | | | | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 | (let loop ((rest-path-items path-items)) (if (null? rest-path-items) #f (let* ((this-dir (car rest-path-items)) (next-rest (cdr rest-path-items)) (candidate (conc this-dir "/" exe))) (if (file-executable? candidate) candidate (loop next-rest))))))) ;;;; define some handy globals ;; resolve fullpath to this script or binary. #;(define (__get-this-script-fullpath #!key (argv (argv))) (let* ((this-script (cond ((and (> (length argv) 2) (string-match "^(.*/csi|csi)$" (car argv)) (string-match "^-(s|ss|sx|script)$" (cadr argv))) (caddr argv)) (else (car argv)))) ;;(foo (begin (print "hello "(find-exe "/bin/sh") #f))) (fullpath (or (find-exe this-script) (realpath this-script)))) fullpath)) ;; (define *this-exe-fullpath* (__get-this-script-fullpath)) ;; (define *this-exe-dir* (pathname-directory *this-exe-fullpath*)) ;; (define *this-exe-name* (pathname-strip-directory *this-exe-fullpath*)) ;;;; utility procedures ;; begin credit: megatest's process.scm |
︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) ) (if raw-debug-level (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) (if (integer? num-debug-level) (begin (let ((new-num-debug-level (- num-debug-level 1))) (if (> new-num-debug-level 0) ;; decrement | | | | | 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 | (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) ) (if raw-debug-level (let ((num-debug-level (runs-ok (string->number raw-debug-level)))) (if (integer? num-debug-level) (begin (let ((new-num-debug-level (- num-debug-level 1))) (if (> new-num-debug-level 0) ;; decrement (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level)) (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL"))) num-debug-level) ; it was set and > 0, mode is value (begin (unset-environment-variable! "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it #f))) ; value was invalid, mode is f #f)))) ; var not set, mode is f (define ducttape-debug-mode (if (ducttape-debug-level) #t #f)) ;; ducttape-debug-regex-filter suppresses non-matching debug messages |
︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 | " ")) (pwd (or (get-environment-variable "PWD") "nopwd")) (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) | | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | " ")) (pwd (or (get-environment-variable "PWD") "nopwd")) (user (or (get-environment-variable "USER") "nouser")) (host (or (get-environment-variable "HOST") "nohost"))) (if logfile (begin (ducttape-log-file logfile) (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file)))) (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t))) ;; log exit code (define (set-ducttape-log-exit-handler) (let ((orig-exit-handler (exit-handler))) (exit-handler |
︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 | (file-mkstemp (conc (if dir dir (get-tmpdir)) "/" prefix ".XXXXXX")))) (close-output-port (open-output-file* fd)) path)) | < < | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 | (file-mkstemp (conc (if dir dir (get-tmpdir)) "/" prefix ".XXXXXX")))) (close-output-port (open-output-file* fd)) path)) ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment ;; write send-email using: ;; - isys-foreach-stdin-line ;; - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment (define (sendmail to_addr subject body #!key (from_addr "admin") |
︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 | (wl "Content-Disposition: inline") (wl "") (wl body) (body-boundary)) (define (attach-file file #!key (content-id #f)) (let* ((filename | | | | 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 | (wl "Content-Disposition: inline") (wl "") (wl body) (body-boundary)) (define (attach-file file #!key (content-id #f)) (let* ((filename (pathname-file file)) (ext-with-dot (pathname-extension file)) (ext (string-take-right ext-with-dot (- (string-length ext-with-dot) 1))) (mimetype (ext->mimetype ext)) (uuencode-command (conc "uuencode " file " " filename))) (boundary) (wl (conc "Content-Type: " mimetype "; name=\"" filename "\"")) |
︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 | ;; are sure they can coexist. (define (ducttape-process-command-line) ;; --quiet (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) (if (not (null? quiet-opts)) (begin | | | | | | | | | 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 | ;; are sure they can coexist. (define (ducttape-process-command-line) ;; --quiet (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet"))) (if (not (null? quiet-opts)) (begin (set-environment-variable! "DUCTTAPE_QUIET_MODE" "1") (ducttape-quiet-mode "1")))) ;; --silent (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent"))) (if (not (null? silent-opts)) (begin (set-environment-variable! "DUCTTAPE_SILENT_MODE" "1") (ducttape-silent-mode "1")))) ;; -color (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?"))) (if (not (null? color-opts)) (begin (set-environment-variable! "DUCTTAPE_COLORIZE" "1") (ducttape-color-mode "1")))) ;; -nocolor (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?"))) (if (not (null? nocolor-opts)) (begin (unset-environment-variable! "DUCTTAPE_COLORIZE" ) (ducttape-color-mode #f)))) ;; -logfile (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?"))) (if (not (null? logfile-opts)) (begin (ducttape-log-file (car (reverse logfile-opts))) (set-environment-variable! "DUCTTAPE_LOG_FILE" (ducttape-log-file))))) ;; -d -dd -d# (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)")) (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) )) (if (not (null? debug-opts)) (begin (ducttape-debug-level (let loop ((opts debug-opts) (debuglevel initial-debuglevel)) (if (null? opts) debuglevel (let* ( (curopt (car opts)) (restopts (cdr opts)) (ds (string-match "-(d+)" curopt)) (dnum (string-match "-d(\\d+)" curopt))) (cond (ds (loop restopts (+ debuglevel (string-length (cadr ds))))) (dnum (loop restopts (string->number (cadr dnum))))))))) (set-environment-variable! "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level)))))) ;; -dp <pat> / --debug-pattern <pat> (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)"))) (if (not (null? debugpat-opts)) (begin (ducttape-debug-regex-filter (string-join debugpat-opts "|")) (set-environment-variable! "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) ;;; following code commented out; side effects not wanted on startup ;; immediately activate logfile (will be noop if logfile disabled) ;;(ducttape-activate-logfile) ;;(set-ducttape-log-exit-handler) |
︙ | ︙ |
Modified http-transport.scm from [9e9f2a4e8b] to [9f49aa94f0].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. | > | | | > > > | > > > | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. (import (srfi 18) ;; extras chicken.tcp s11n srfi-1 ;; posix regex regex-case srfi-69 ;; hostinfo md5 message-digest ;;posix-extras spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; Configurations for server (tcp-buffer-size 2048) (max-connections 2048) (declare (unit http-transport)) |
︙ | ︙ |
Modified megatest.scm from [dc12e408b1] to [68c3e57406].
︙ | ︙ | |||
65 66 67 68 69 70 71 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") | > > > | | > > | > > | | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (import (prefix sqlite3 sqlite3:) srfi-1 ;; posix regex regex-case srfi-69 (prefix base64 base64:) breadline apropos json http-client ;; directory-utils typed-records http-client srfi-18 ;; extras (chicken.format) ;; Added for csv stuff - will be removed ;; sparse-vectors) (require-library mutils) (define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file (define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file (dbfile:db-init-proc db:initialize-main-db) |
︙ | ︙ | |||
2397 2398 2399 2400 2401 2402 2403 | ;; (exit) ;; EOF (repl)) (else (begin (set! *db* dbstructs) | | | | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 | ;; (exit) ;; EOF (repl)) (else (begin (set! *db* dbstructs) ;; (import extras) ;; might not be needed ;; (import csi) (import breadline) (import apropos) (import dbfile) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (if *use-new-readline* (begin (install-history-file (get-environment-variable "HOME") ".megatest_history") ;; [homedir] [filename] [nlines]) |
︙ | ︙ |
Modified mtargs/mtargs.scm from [147e7c2628] to [4001bae578].
︙ | ︙ | |||
24 25 26 27 28 29 30 | usage get-args print-args any-defined? help ) | > > > > > | | > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | usage get-args print-args any-defined? help ) (import scheme chicken.base chicken.process-context ;; scheme ;; chicken data-structures extras posix ports files srfi-69 srfi-1 ) (define arg-hash (make-hash-table)) (define help "") (define (get-arg arg . default) (if (null? default) (hash-table-ref/default arg-hash arg #f) |
︙ | ︙ |
Modified mtut.scm from [413cf26858] to [2967125a3c].
︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; ;; (include "common.scm") (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) | > > > > > > > > > | | > > > | | | < < < < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (declare (uses common)) (declare (uses margs)) (declare (uses configf)) (declare (uses pkts)) ;; (declare (uses rmt)) ;; (include "common.scm") (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (import srfi-1 ;; posix srfi-69 breadline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-19 srfi-18 ;; extras chicken.format pkts regex regex-case (prefix dbi dbi:) (prefix sqlite3 sqlite3:) nanomsg) (use ducttape-lib) (include "megatest-fossil-hash.scm") (require-library stml) |
︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 | (begin (stml:main #f) (exit))) (if (or (args:get-arg "-repl") (args:get-arg "-load")) (begin | | | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 | (begin (stml:main #f) (exit))) (if (or (args:get-arg "-repl") (args:get-arg "-load")) (begin ;; (import extras) ;; might not be needed ;; (import csi) (import breadline) (import apropos) ;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ... (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) |
︙ | ︙ |
Modified pkts/pkts.scm from [90f8c93eeb] to [a1d0fb88b2].
︙ | ︙ | |||
160 161 162 163 164 165 166 | pktdb-pktspec ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) | > > > > > | > | > > | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | pktdb-pktspec ;; utility procs increment-string ;; used to get indexes for strings in ref pkts make-report ;; make a .dot file ) (import ;; chicken scheme ;; data-structures posix srfi-1 regex srfi-13 srfi-69 ;; ports extras) crypt sha1 message-digest (prefix dbi dbi:) typed-records) ;;====================================================================== ;; DATA MANIPULATION UTILS ;;====================================================================== (define-inline (unescape-data data) (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\")))) |
︙ | ︙ |
Modified portlogger.scm from [36a4964f50] to [db569cc07a].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | > | > > > > > > | > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (import (srfi 18) ;; chicken.tcp s11n srfi-1 ;; posix srfi-69 ;; hostinfo ;; dot-locking z3 (prefix sqlite3 sqlite3:)) (declare (unit portlogger)) (declare (uses db)) ;; lsof -i (define (portlogger:open-db fname) |
︙ | ︙ |
Modified runs.scm from [2838f87e3f] to [9dc99d390b].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') | > > > | | > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') (import (prefix sqlite3 sqlite3:) srfi-1 ;; posix regex regex-case srfi-69 (srfi 18) ;; posix-extras directory-utils pathname-expand typed-records format sxml-serializer sxml-modifications matchable) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) (declare (uses runconfig)) (declare (uses tests)) |
︙ | ︙ |
Modified server.scm from [bb020a2020] to [a060e1f916].
︙ | ︙ | |||
12 13 14 15 16 17 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; | > | > > > > > | > > | > > | > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;; (import (srfi 18) ;; extras chicken.tcp s11n srfi-1 ;; posix regex regex-case srfi-69 ;; hostinfo md5 message-digest ;; directory-utils posix-extras matchable ;; utils spiffy uri-common intarweb http-client spiffy-request-vars ) (declare (unit server)) (declare (uses commonmod)) (declare (uses common)) (declare (uses db)) |
︙ | ︙ |
Modified tdb.scm from [6edff6262d] to [753c51811c].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== | > > | > > | > | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | ;; ;;====================================================================== ;;====================================================================== ;; Database access ;;====================================================================== (import (srfi 18) ;; extras tcp) sqlite3 srfi-1 ;; posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 (prefix sqlite3 sqlite3:) (prefix base64 base64:)) (declare (unit tdb)) (declare (uses common)) (declare (uses keys)) (declare (uses ods)) (declare (uses client)) (declare (uses mt)) |
︙ | ︙ |