Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -30,11 +30,11 @@ MSRCFILES = dbmod.scm rmtmod.scm commonmod.scm apimod.scm \ archivemod.scm clientmod.scm envmod.scm ezstepsmod.scm itemsmod.scm \ keysmod.scm launchmod.scm odsmod.scm processmod.scm runconfigmod.scm \ runsmod.scm servermod.scm subrunmod.scm tasksmod.scm testsmod.scm \ pkts.scm mtargs.scm mtconfigf.scm ducttape-lib.scm ulex.scm \ -stml2.scm cookie.scm megamod.scm +stml2.scm cookie.scm megamod.scm mutils.scm GMSRCFILES = dcommonmod.scm vgmod.scm treemod.scm # Eggs to install (straightforward ones) @@ -64,11 +64,11 @@ # mofiles/ducttape-lib.o : ducttape-lib.scm ducttape/*scm # csc -I ducttape -J -c ducttape-lib.scm -o mofiles/ducttape-lib.o mofiles/%.o %.import.scm : %.scm - mkdir -p mofiles + @[ -e mofiles ] && mkdir -p mofiles csc $(CSCOPTS) -I $* -J -c $< -o mofiles/$*.o touch $*.import.scm # ensure it is touched after the .o is made # a.import.o : a.import.scm a.o # csc -unit a.import -c a.import.scm -o $*.o @@ -94,19 +94,19 @@ all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt # why were the files mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o listed on this target when MOFILES are there? # Removed non module .o files (i.e. $(OFILES) -mtest: readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) mofiles/ducttape-lib.o - csc megatest.o $(CSCOPTS) $(MOFILES) $(MOIMPFILES) -o mtest +mtest: readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES) + csc megatest.scm $(CSCOPTS) $(MOFILES) $(MOIMPFILES) -o mtest showmtesthash: @echo $(MTESTHASH) # removing $(GOFILES) dboard : dashboard.o $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) - csc dashboard.o $(CSCOPTS) $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard + csc dashboard.scm $(CSCOPTS) $(MOFILES) $(MOIMPFILES) $(GMOFILES) $(GMOIMPFILES) -o dboard ndboard : newdashboard.scm $(GOFILES) csc $(CSCOPTS) $(GOFILES) newdashboard.scm -o ndboard mtut: $(MOFILES) megatest-fossil-hash.scm mtut.scm @@ -174,11 +174,11 @@ mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm mofiles/ulex.o : ulex/ulex.scm # for the modularized stuff -mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/stml2.o mofiles/mtargs.o +mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/stml2.o mofiles/mtargs.o mofiles/pkts.o mofiles/mtconfigf.o mofiles/dbmod.o : mofiles/commonmod.o mofiles/keysmod.o \ mofiles/tasksmod.o mofiles/odsmod.o mofiles/commonmod.o : mofiles/processmod.o mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o \ mofiles/apimod.o mofiles/ulex.o Index: common-inc.scm ================================================================== --- common-inc.scm +++ common-inc.scm @@ -704,34 +704,11 @@ (begin (debug:print-info 0 *default-log-port* "forcing use of server, force setting is \"" force-setting "\".") #t) #f))) -;; hash-table tree to html list tree -;; -;; tipfunc takes two parameters: y the tip value and path the path to that point -;; -(define (common:htree->html ht path tipfunc) - (let ((datlist (sort (hash-table->alist ht) - (lambda (a b) - (string< (car a)(car b)))))) - (if (null? datlist) - (tipfunc #f path) ;; really shouldn't get here - (s:ul - (map (lambda (x) - (let* ((levelname (car x)) - (y (cdr x)) - (newpath (append path (list levelname))) - (leaf (or (not (hash-table? y)) - (null? (hash-table-keys y))))) - (if leaf - (s:li (tipfunc y newpath)) - (s:li - (list - levelname - (common:htree->html y newpath tipfunc)))))) - datlist))))) +;; moving common:htree->html to testsmod.scm to minimize deps on stml2 ;; hash-table tree to alist tree ;; (define (common:htree->atree ht) (map (lambda (x) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -18,11 +18,11 @@ ;;====================================================================== (declare (unit commonmod)) (declare (uses mtargs)) -(declare (uses stml2)) +;; (declare (uses stml2)) (declare (uses mtargs)) (module commonmod * @@ -35,11 +35,11 @@ pkts (prefix dbi dbi:) stack md5 message-digest (prefix mtconfigf configf:) - stml2 + ;; stml2 ;; (prefix margs args:) z3 (prefix base64 base64:) (prefix mtargs args:)) (include "common_records.scm") Index: launch-inc.scm ================================================================== --- launch-inc.scm +++ launch-inc.scm @@ -667,11 +667,11 @@ (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if (and (string? var)(string? val)) (begin - (safe-setenv var (config:eval-string-in-environment val))) ;; val) + (safe-setenv var (configf:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) ;;(bb-check-path msg: "launch:execute post block 1") Index: megamod.scm ================================================================== --- megamod.scm +++ megamod.scm @@ -102,11 +102,11 @@ ) (import (prefix mtconfigf configf:)) (define read-config configf:read-config) (define find-and-read-config configf:find-and-read-config) -(define config:eval-string-in-environment configf:eval-string-in-environment) +;; (define config:eval-string-in-environment configf:eval-string-in-environment) (import spiffy) (import stml2) ;; (import apimod) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -23,31 +23,34 @@ (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-19 srfi-18 extras format pkts regex regex-case (prefix dbi dbi:) - nanomsg (prefix mtconfigf configf:)) + nanomsg) ;; (declare (uses common)) ;; (declare (uses megatest-version)) ;; (declare (uses margs)) -;; (declare (uses configfmod)) + +(declare (uses mtconfigf)) +(import (prefix mtconfigf configf:)) + +(declare (uses stml2)) +(import stml2) + (declare (uses commonmod)) (declare (uses megamod)) (import commonmod) -;; (import configfmod) (import megamod) ;; (declare (uses rmt)) -(use ducttape-lib) +(declare (uses ducttape-lib)) +(import ducttape-lib) ;; (include "megatest-fossil-hash.scm") ;; comes from megamod -;; (require-library stml) -(use stml2) - ;; stuff for the mapper and checker functions ;; (define *target-mappers* (make-hash-table)) (define *runname-mappers* (make-hash-table)) (define *area-checkers* (make-hash-table)) ADDED mutils/Makefile Index: mutils/Makefile ================================================================== --- /dev/null +++ mutils/Makefile @@ -0,0 +1,22 @@ +# Copyright 2007-2010, Matthew Welland. +# +# This program is made available under the GNU GPL version 2.0 or +# greater. See the accompanying file COPYING for details. +# +# This program is distributed WITHOUT ANY WARRANTY; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +# PURPOSE. + +# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)") + +all : uptodate.log # $(TARGDIR)/mutils.so + +uptodate.log : mutils.scm mutils.setup + chicken-setup | tee uptodate.log + +$(TARGDIR)/mutils.so : mutils.so + @echo installing to $(TARGDIR) + cp mutils.so $(TARGDIR) + +mutils.so : mutils.scm + csc -s mutils.scm ADDED mutils/mutils.meta Index: mutils/mutils.meta ================================================================== --- /dev/null +++ mutils/mutils.meta @@ -0,0 +1,20 @@ +( +; Your egg's license: +(license "BSD") + +; Pick one from the list of categories (see below) for your egg and enter it +; here. +(category misc) + +; A list of eggs mpeg3 depends on. If none, you can omit this declaration +; altogether. If you are making an egg for chicken 3 and you need to use +; procedures from the `files' unit, be sure to include the `files' egg in the +; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit). +; `depends' is an alias to `needs'. +(needs sparse-vectors) + +; A list of eggs required for TESTING ONLY. See the `Tests' section. +(test-depends test) + +(author "Matt Welland") +(synopsis "A basic description of the purpose of the egg.")) ADDED mutils/mutils.scm Index: mutils/mutils.scm ================================================================== --- /dev/null +++ mutils/mutils.scm @@ -0,0 +1,171 @@ +;; Copyright 2006-2011, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on +;; lots of disparate data +;; +(define (mutils:hierhash-ref hh . keys) + (if (null? keys) + #f + (let loop ((ht hh) + (key (car keys)) + (tail (cdr keys))) + (if (null? tail) + (if (hash-table? ht) + (hash-table-ref/default ht key #f) + #f) + (if (hash-table? ht) + (loop (hash-table-ref/default ht key #f) + (car tail) + (cdr tail)) + #f))))) + +;; WATCH THE NON-INTUITIVE INTERFACE HERE!!!! +;; val comes first! +;; +(define (mutils:hierhash-set! hh val . keys) + (if (null? keys) + #f + (let loop ((ht hh) + (key (car keys)) + (tail (cdr keys))) + (if (null? tail) ;; last one! + (hash-table-set! ht key val) + (let ((nh (hash-table-ref/default ht key #f))) + (if (not nh)(set! nh (make-hash-table))) + (hash-table-set! ht key nh) + (loop nh + (car tail) + (cdr tail))))))) + +;; nice little routine to add an item to a list in a hashtable +;; +(define (mutils:hash-table-add-to-list htbl key item) + (let ((l (hash-table-ref/default htbl key #f))) + (if l + (hash-table-set! htbl key (cons item l)) + (hash-table-set! htbl key (list item))))) + +(define (mutils:hash-table-append-to-list htbl key lst) + (let ((l (hash-table-ref/default htbl key #f))) + (if l + (hash-table-set! htbl key (append lst l)) + (hash-table-set! htbl key lst)))) + +;;====================================================================== +;; Utils +;;====================================================================== + +(define (mutils:file->list fname) + (let ((fh (open-input-file fname)) + (comment (regexp "^\\s*#")) + (blank (regexp "^\\s*$"))) + (let loop ((l (read-line fh)) + (res '())) + (if (eof-object? l) + (reverse res) + (if (or (string-match comment l) + (string-match blank l)) + (loop (read-line fh) res) + (loop (read-line fh) (cons l res))))))) + +(use sparse-vectors) + +;; this is a simple two dimensional sparse array + +;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!! +;; +(define (mutils:make-sparse-array) + (let ((a (make-sparse-vector))) + (sparse-vector-set! a 0 (make-sparse-vector)) + a)) + +(define (mutils:sparse-array? a) + (and (sparse-vector? a) + (sparse-vector? (sparse-vector-ref a 0)))) + +(define (mutils:sparse-array-ref a x y) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-ref row y) + #f))) + +(define (mutils:sparse-array-set! a x y val) + (let ((row (sparse-vector-ref a x))) + (if row + (sparse-vector-set! row y val) + (let ((new-row (make-sparse-vector))) + (sparse-vector-set! a x new-row) + (sparse-vector-set! new-row y val))))) + +;; some routines for treating assoc lists a bit like hash tables + +(define (mutils:assoc-get/default alist key default) + (let ((res (assoc key alist))) + (if (and res (list? res)(> (length res) 1)) + (cadr res) + default))) + +(define (mutils:assoc-get alist key) + (cadr (assoc key alist))) + +(define (mutils:hier-list? @hierlist) + (and (list? @hierlist) + (> (length @hierlist) 0) + (list? (car @hierlist)) + (> (length (car @hierlist)) 1))) + +(define (mutils:hier-list-get @hierlist . @path) + (if (list? @hierlist) + (let* (($path (car @path)) + (@rempath (cdr @path)) + (@match (assoc $path @hierlist))) + (if @match + (if (or (not (list? @rempath))(null? @rempath)) + (cadr @match) + (apply mutils:hier-list-get (cadr @match) @rempath)) + #f)) + #f)) + +(define (mutils:hier-list-put! @hierlist . @path) + (let* (($path (car @path)) + (@rempath (cdr @path)) + ($value (cadr @path)) + (@match (assoc $path @hierlist)) + (@remhierlist (remove (lambda (a) + (equal? a @match)) + @hierlist)) + (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '()))) + (@new-pair (list $path (if (eq? (length @rempath) 1) + (car @rempath) + (apply mutils:hier-list-put! @old-pair @rempath))))) + (cons @new-pair @remhierlist))) + +(define (mutils:hier-list-remove! @hierlist . @path) + (let (($path (car @path))) + (if (eq? (length @path) 1) + (remove (lambda (a) + (equal? a (assoc $path @hierlist))) + @hierlist) + (let* ((@rempath (cdr @path)) + (@match (assoc $path @hierlist)) + (@remhierlist (remove (lambda (a) + (equal? @match a)) + @hierlist)) + (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '()))) + (@new-pair (list $path (apply mutils:hier-list-remove! @old-pair @rempath)))) + (cons @new-pair @remhierlist))))) + +(define (mutils:keys @hierlist . @path) + (map (lambda (@l) + (if (and (list? @l)(not (null? @l))) + (car @l))) + (if (null? @path) @hierlist + (apply mutils:hier-list-get @hierlist @path)))) + ADDED mutils/mutils.setup Index: mutils/mutils.setup ================================================================== --- /dev/null +++ mutils/mutils.setup @@ -0,0 +1,18 @@ +;; Copyright 2007-2010, Matthew Welland. +;; +;; This program is made available under the GNU GPL version 2.0 or +;; greater. See the accompanying file COPYING for details. +;; +;; This program is distributed WITHOUT ANY WARRANTY; without even the +;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. + +;;;; mutils.setup + +;; compile the code into a dynamically loadable shared object +;; (will generate mutils.so) +(compile -s mutils.scm) + +;; Install as extension library +(install-extension 'mutils "mutils.so") + ADDED mutils/tests/datastruct.scm Index: mutils/tests/datastruct.scm ================================================================== --- /dev/null +++ mutils/tests/datastruct.scm @@ -0,0 +1,15 @@ + +(use test) + +(include "datastruct.scm") + +(define hh (make-hash-table)) + +(hierhash-set! hh 5 1 2 3 4) + +(test 5 (hierhash-ref hh 1 2 3 4)) + +(hierhash-set! hh 10 1 2 3 5) + +(test 10 (hierhash-ref hh 1 2 3 5)) +(test 5 (hierhash-ref hh 1 2 3 4)) Index: stml2/stml2.scm ================================================================== --- stml2/stml2.scm +++ stml2/stml2.scm @@ -14,11 +14,12 @@ (module stml2 * (import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1) -(use cookie (prefix dbi dbi:) (prefix crypt c:) typed-records) +(import cookie) +(use (prefix dbi dbi:) (prefix crypt c:) typed-records) ;; (declare (uses misc-stml)) (use regex) ;; The (usually global) sdat contains everything about the session Index: tests-inc.scm ================================================================== --- tests-inc.scm +++ tests-inc.scm @@ -545,10 +545,36 @@ (hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path)))) test-data))) runs) resh)) + +;; hash-table tree to html list tree +;; +;; tipfunc takes two parameters: y the tip value and path the path to that point +;; +(define (common:htree->html ht path tipfunc) + (let ((datlist (sort (hash-table->alist ht) + (lambda (a b) + (string< (car a)(car b)))))) + (if (null? datlist) + (tipfunc #f path) ;; really shouldn't get here + (s:ul + (map (lambda (x) + (let* ((levelname (car x)) + (y (cdr x)) + (newpath (append path (list levelname))) + (leaf (or (not (hash-table? y)) + (null? (hash-table-keys y))))) + (if leaf + (s:li (tipfunc y newpath)) + (s:li + (list + levelname + (common:htree->html y newpath tipfunc)))))) + datlist))))) + ;; tests:genrate dashboard body ;; (define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt) Index: ulex.scm ================================================================== --- ulex.scm +++ ulex.scm @@ -17,7 +17,8 @@ ;; along with Megatest. If not, see . ;;====================================================================== (declare (unit ulex)) +(declare (uses pkts)) (include "ulex/ulex.scm")