15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
+
|
;;
;; 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 commonmod))
;; (declare (uses debugprint))
(use srfi-69)
(module commonmod
*
(import scheme
|
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
+
+
|
posix
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
;; debugprint
)
;;======================================================================
;; CONTENTS
;;
;; config file utils
;; misc conversion, data manipulation functions
|
533
534
535
536
537
538
539
540
541
|
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
|
(hash-table-set! dat key1 (make-hash-table))
(db:hoh-set! dat key1 key2 val)))))
(define (db:hoh-get dat key1 key2)
(let* ((subhash (hash-table-ref/default dat key1 #f)))
(and subhash
(hash-table-ref/default subhash key2 #f))))
;;======================================================================
;; when called from a wrapper I need sometimes to find the calling
;; wrapper, this is for dashboard to find the correct megatest.
;;
(define (common:find-local-megatest #!optional (progname "megatest"))
(let ((res (filter file-exists?
(map (lambda (updir)
(let* ((lm (car (argv)))
(dir (pathname-directory lm))
(exe (pathname-strip-directory lm)))
(conc (if dir (conc dir "/") "")
(case (string->symbol exe)
((dboard) (conc updir progname))
((mtest) (conc updir progname))
((dashboard) progname)
(else exe)))))
'("../../" "../")))))
(if (null? res)
(begin
;; (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path")
progname)
(car res))))
)
|