Random Bits of Open Code

Check-in [e398fb41ad]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fixed bad /tmp format bug
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:e398fb41adce6e3c76fa8659335d9e3e6a593d2a
User & Date: matt 2018-05-21 05:29:03
Context
2018-05-21
06:03
Fixed bad /tmp format bug check-in: b6a399e9a9 user: matt tags: trunk
05:29
Fixed bad /tmp format bug check-in: e398fb41ad user: matt tags: trunk
2018-05-14
06:08
Added an assert on dbi:open. Wierd problems... check-in: 449cd12f61 user: matt tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to a3d/a3d.scm.

46
47
48
49
50
51
52


53
54
55
56
57
58
59
  (syntax-rules ()
    ((_ (name arg ...) body ...)
     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))

;;
(define *mode* 'openscad) ;; or 'povray
(define *indent* "")



;;======================================================================
;; misc and utils
;;======================================================================

(define (a3d-print . objs)
  (for-each







>
>







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
  (syntax-rules ()
    ((_ (name arg ...) body ...)
     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))

;;
(define *mode* 'openscad) ;; or 'povray
(define *indent* "")

(require-library geolib)

;;======================================================================
;; misc and utils
;;======================================================================

(define (a3d-print . objs)
  (for-each

Changes to mtutils/mtdb/mtdb.scm.

26
27
28
29
30
31
32

33
34
35
36
37
38
39
...
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290





















291
292
293
294
295
296
297
     ;; area dats (adat)
     adat-init
     adat->alist
     adat-mtconfig
     adat-runconfig
     adat-path
     adat-name

     
     ;; db access routines
     get-db-tmp-area
     with-megatest-db
     with-main-db
     with-run-db
     with-common-db
................................................................................
;;======================================================================
;; Manage the /tmp/ db mirror area (use current directory on Windows)
;;======================================================================

;; Need to consolidate this with a very similar call in mtview.scm.
;;
(define (adat-init adat-in #!key (mtpath #f)(area-name #f)(use-mt-area #t))
  (let* ((onwin  (common:windows?))
	 (adat   (or adat-in (make-adat)))
	 (aname  (or (adat-name adat)
		     (begin
		       (adat-name-set! adat area-name)
		       area-name)))
	 (apath  (or (adat-path adat)
		     (begin
		       (adat-path-set! adat mtpath)
		       mtpath)))
	 (mtdb   (conc apath "/megatest.db"))
	 (mtcfg  (conc apath "/megatest.config"))
	 (rccfg  (conc apath "/runconfigs.config"))
	 (tmpbase (if onwin (current-directory) "/tmp/"))
	 (tmppth (if (adat-tmppath adat)
		     (adat-tmppath adat)
		     (let* ((p1 (conc tmpbase (current-user-name) "/mtview_cache"))
			    (p2 (conc aname (string-translate (if (equal? apath ".")
								  "localdir"
								  apath)
							      "/" "-" )))
			    (tpath (conc p1 "/" p2)))
		       (adat-tmp-area-set! adat p1)
		       (adat-tmppath-set! adat tpath)
		       tpath))))
    (if (and (not (directory-exists? tmppth))
	     (not (file-exists? tmppth)))     ;; catch the case where ">" is provided
	(create-directory tmppth #t))
    (if (and use-mt-area (file-read-access? mtdb)(file-read-access? mtcfg)(file-read-access? rccfg))
	(begin
	  (if (not (adat-mtconfig adat))
	      (adat-mtconfig-set! adat (configf:read-config mtcfg #f #f)))
	  (if (not (adat-runconfig adat))
	      (adat-runconfig-set! adat (configf:read-config rccfg #f #f)))))
    adat))






















;; this is the megatest temp area from version v1.6X
(define (get-db-tmp-area area-path area-name)
  (let ((dbdir (conc "/tmp/" (current-user-name)
                     "/megatest_localdb/"
                     area-name "/"
                     (string-translate area-path "/" "."))))







>







 







|












|
|
<
<
<
<
<
<
<
<
<
<
<
<
<







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







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
...
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271













272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
     ;; area dats (adat)
     adat-init
     adat->alist
     adat-mtconfig
     adat-runconfig
     adat-path
     adat-name
     get-2.X-db-tmp-area
     
     ;; db access routines
     get-db-tmp-area
     with-megatest-db
     with-main-db
     with-run-db
     with-common-db
................................................................................
;;======================================================================
;; Manage the /tmp/ db mirror area (use current directory on Windows)
;;======================================================================

;; Need to consolidate this with a very similar call in mtview.scm.
;;
(define (adat-init adat-in #!key (mtpath #f)(area-name #f)(use-mt-area #t))
  (let* (;; (onwin  (common:windows?))
	 (adat   (or adat-in (make-adat)))
	 (aname  (or (adat-name adat)
		     (begin
		       (adat-name-set! adat area-name)
		       area-name)))
	 (apath  (or (adat-path adat)
		     (begin
		       (adat-path-set! adat mtpath)
		       mtpath)))
	 (mtdb   (conc apath "/megatest.db"))
	 (mtcfg  (conc apath "/megatest.config"))
	 (rccfg  (conc apath "/runconfigs.config"))
	 ;; (tmpbase (if onwin (current-directory) "/tmp/"))
	 (tmppth (get-2.X-db-tmp-area adat apath aname)))













    (if (and use-mt-area (file-read-access? mtdb)(file-read-access? mtcfg)(file-read-access? rccfg))
	(begin
	  (if (not (adat-mtconfig adat))
	      (adat-mtconfig-set! adat (configf:read-config mtcfg #f #f)))
	  (if (not (adat-runconfig adat))
	      (adat-runconfig-set! adat (configf:read-config rccfg #f #f)))))
    adat))

;; this is the megatest temp area from version v2.X
;;
(define (get-2.X-db-tmp-area adat area-path area-name)
  (if (adat-tmppath adat)
      (adat-tmppath adat)
      (let* ((onwin   (common:windows?))
	     (tmpbase (if onwin (current-directory) "/tmp/"))
	     (p1      (conc tmpbase (current-user-name) "/mtview_cache"))
	     (p2      (conc area-name
			    (string-translate (if (equal? area-path ".")
						  "localdir"
						  area-path)
					      "/" "-" )))
	     (tpath   (conc p1 "/" p2)))
	(adat-tmp-area-set! adat p1)
	(adat-tmppath-set! adat tpath)
	(if (and (not (directory-exists? tpath))
		 (not (file-exists? tpath)))     ;; catch the case where ">" is provided
	    (create-directory tpath #t))
	tpath)))

;; this is the megatest temp area from version v1.6X
(define (get-db-tmp-area area-path area-name)
  (let ((dbdir (conc "/tmp/" (current-user-name)
                     "/megatest_localdb/"
                     area-name "/"
                     (string-translate area-path "/" "."))))