Megatest

Check-in [0e8fa15f1d]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Use debugprint module in dbfile module as stepping stone to replacing old debug:print calls with new.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.80-debugprint
Files: files | file ages | folders
SHA1: 0e8fa15f1dc53990cb86e2af2f76942e2d96d36c
User & Date: matt on 2023-02-10 20:19:49
Other Links: branch diff | manifest | tags
Context
2023-02-10
20:19
Use debugprint module in dbfile module as stepping stone to replacing old debug:print calls with new. Closed-Leaf check-in: 0e8fa15f1d user: matt tags: v1.80-debugprint
2023-02-02
12:54
Use an actual droop check-in: 19861e6399 user: matt tags: v1.80
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified dashboard.scm from [4ad343f07e] to [2a55359814].

︙︙
13
14
15
16
17
18
19




20
21
22
23
24
25
26

;;     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/>.
;;
;;======================================================================





(use format)

(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)








>
>
>
>








13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

;;     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 debugprint))

(import debugprint)

(use format)

(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
︙︙

Modified dbfile.scm from [25f8271ef2] to [cb34ff9622].

︙︙
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 dbfile))
;; (declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme
	  chicken








|








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 dbfile))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme
	  chicken
︙︙
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

	stack
	files
	ports

	commonmod
	)

;; (import debugprint)

;;======================================================================
;;  R E C O R D S
;;======================================================================

;; a single Megatest area with it's multiple dbs is
;; managed in a dbstruct








|








37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

	stack
	files
	ports

	commonmod
	)

(import debugprint)

;;======================================================================
;;  R E C O R D S
;;======================================================================

;; a single Megatest area with it's multiple dbs is
;; managed in a dbstruct
︙︙
320
321
322
323
324
325
326

327
328
329
330
331
332
333
334
335
336
337

  (with-output-to-port
      (current-error-port)
    (lambda ()
      (apply print params)))
  (exit 1))
    
(define (dbfile:print-err . params)

  (with-output-to-port
      (current-error-port)
    (lambda ()
      (apply print params))))

(define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode #!optional (tries-left 500))
  (let* ((busy-file  (conc fname "-journal"))
	 (delay-time (* (- 51 tries-left) 1.1))
      	 (write-access (file-write-access? fname))
         (dir-access (file-write-access? (pathname-directory fname)))
         (retry      (lambda ()








>
|
|
|
|








320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338

  (with-output-to-port
      (current-error-port)
    (lambda ()
      (apply print params)))
  (exit 1))
    
(define (dbfile:print-err . params)
  (apply debug:print 0 *default-log-port* params))
;;   (with-output-to-port
;;       (current-error-port)
;;     (lambda ()
;;       (apply print params))))

(define (dbfile:cautious-open-database fname init-proc sync-mode journal-mode #!optional (tries-left 500))
  (let* ((busy-file  (conc fname "-journal"))
	 (delay-time (* (- 51 tries-left) 1.1))
      	 (write-access (file-write-access? fname))
         (dir-access (file-write-access? (pathname-directory fname)))
         (retry      (lambda ()
︙︙

Modified debugprint.scm from [54f7083883] to [993bf82387]. 






















1
2
3
4
5
6
7























(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
	

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








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

;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     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/>.

;;======================================================================

(use srfi-69)

(declare (unit debugprint))
(declare (uses mtargs))

(module debugprint
	*
︙︙
21
22
23
24
25
26
27

28
29
30
31
32
33
34

    ;; chicken.time.posix
    ;; chicken.port
    ;; chicken.process-context
    ;; chicken.process-context.posix
    
    (prefix mtargs args:)
    srfi-1

    ;; system-information
    )
  
;;======================================================================
;; debug stuff
;;======================================================================









>








42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

    ;; chicken.time.posix
    ;; chicken.port
    ;; chicken.process-context
    ;; chicken.process-context.posix
    
    (prefix mtargs args:)
    srfi-1
    srfi-69
    ;; system-information
    )
  
;;======================================================================
;; debug stuff
;;======================================================================
︙︙

Modified megatest.scm from [79d9696058] to [a2b02168c4].

︙︙
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

(declare (uses env))
(declare (uses diff-report))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
;; (declare (uses debugprint))
;; (declare (uses debugprint.import))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod








|
|
|
|








43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

(declare (uses env))
(declare (uses diff-report))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbmod.import))
(declare (uses commonmod))
(declare (uses commonmod.import))
(declare (uses debugprint))
(declare (uses debugprint.import))
(declare (uses dbfile))
(declare (uses dbfile.import))
;; (declare (uses mtargs))
;; (declare (uses mtargs.import))

;; (declare (uses ftail))
;; (import ftail)

(import dbmod
︙︙

Modified mtargs.scm from [1e6b59e54f] to [bf4593d143].

︙︙
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 mtargs))

(include "mtargs/mtargs.scm")








|


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 mtargs))
(use srfi-69)
(include "mtargs/mtargs.scm")

Modified rmt.scm from [771d7d8ec4] to [78a0a807b4].

︙︙
116
117
118
119
120
121
122

123
124
125
126
127
128
129

	  (set! *runremote* (make-remote))
          (let* ((server-info (remote-server-info *runremote*))) 
            (if server-info
		(begin
			(remote-server-url-set! *runremote* (server:record->url server-info))
			(remote-server-id-set! *runremote* (server:record->id server-info)))))  
	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration

    
    ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
    ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
    ;; DOT SET_HOMEHOST -> MUTEXLOCK;
    ;; ensure we have a homehost record
    (if (or (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
	    (not (cdr (remote-hh-dat runremote))))   ;; not on homehost








>








116
117
118
119
120
121
122
123
124
125
126
127
128
129
130

	  (set! *runremote* (make-remote))
          (let* ((server-info (remote-server-info *runremote*))) 
            (if server-info
		(begin
			(remote-server-url-set! *runremote* (server:record->url server-info))
			(remote-server-id-set! *runremote* (server:record->id server-info)))))  
	  (set! runremote   *runremote*))) ;; new runremote will come from this on next iteration
    
    
    ;; DOT SET_HOMEHOST; // leaving off - doesn't really add to the clarity
    ;; DOT MUTEXLOCK -> SET_HOMEHOST [label="no homehost?"];
    ;; DOT SET_HOMEHOST -> MUTEXLOCK;
    ;; ensure we have a homehost record
    (if (or (not (pair? (remote-hh-dat runremote)))  ;; not on homehost
	    (not (cdr (remote-hh-dat runremote))))   ;; not on homehost
︙︙

This page was generated in about 0.113s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00