254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
|
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
;; ;; This routine creates the db. It is only called if the db is not already opened
;; ;;
;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
|
|
|
>
>
>
>
>
>
>
>
>
|
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
|
(exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again."))
(exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed."))
(exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back."))
(exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem."))
(exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn))))
)))
;; this routine is used to determine if we are in write mode or read-only mode
(define (db:mtdbpath-writable? mtdbpath)
(let* ((parent-dir (pathname-directory mtdbpath))
(logdir (conc parent-dir "/logs")))
(and
(file-write-access? parent-dir)
(file-write-access? mtdbpath)
(or (not (common:file-exists? logdir)) (file-write-access? logdir))
(or (not (configf:lookup *configdat* "setup" "write-requires-ownership"))
(equal? (file-owner mtdbpath)(current-effective-user-id)))
)))
;; ;; This routine creates the db. It is only called if the db is not already opened
;; ;;
;; (define (db:open-rundb dbstruct run-id #!key (attemptnum 0)(do-not-open #f)) ;; (conc *toppath* "/megatest.db") (car *configinfo*)))
;; (let* ((dbfile (db:dbfile-path run-id)) ;; (conc toppath "/db/" run-id ".db"))
|
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
|
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (file-write-access? mtdbpath))
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f))
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
(if (and dbexists (not write-access))
(begin
|
|
|
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
(dbfexists (common:file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db")))
(mtdbexists (common:file-exists? (conc *toppath* "/megatest.db")))
(mtdb (db:open-megatest-db))
(mtdbpath (db:dbdat-get-path mtdb))
(tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db))
(refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db"))
(write-access (db:mtdbpath-writable? mtdbpath)) ;; this determines if we are i readonly mode or not.
(mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f))
(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f))
(modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime))))
;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access)
(if (and dbexists (not write-access))
(begin
|
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
(dbpath (conc dbdir "/" (or name "megatest.db")))
(dbexists (common:file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
;;(db:initialize-run-id-db db)
)))
(write-access (file-write-access? dbpath)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
(cons db dbpath)))
;; sync run to disk if touched
;;
|
|
|
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
|
(dbpath (conc dbdir "/" (or name "megatest.db")))
(dbexists (common:file-exists? dbpath))
(db (db:lock-create-open dbpath
(lambda (db)
(db:initialize-main-db db)
;;(db:initialize-run-id-db db)
)))
(write-access (db:mtdbpath-writable? dbpath)))
(debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath)
(if (and dbexists (not write-access))
(set! *db-write-access* #f))
(cons db dbpath)))
;; sync run to disk if touched
;;
|