Index: dbfile.scm
==================================================================
--- dbfile.scm
+++ dbfile.scm
@@ -18,10 +18,11 @@
 
 ;;======================================================================
 
 (declare (unit dbfile))
 ;; (declare (uses debugprint))
+;; (declare (uses commonmod))
 
 (module dbfile
 	*
 	
 (import scheme chicken data-structures extras)
@@ -29,10 +30,12 @@
 	posix typed-records srfi-18
 	srfi-69
 	stack
 	files
 	ports
+
+	;; commonmod
 	)
 
 ;; (import debugprint)
 
 ;;======================================================================
@@ -268,22 +271,14 @@
 ;;
 ;;   NOTE: returns a dbdat not a dbstruct!
 ;;
 (define (dbfile:open-sqlite3-db dbpath init-proc)
   (let* ((dbexists     (file-exists? dbpath))
-	 (db           ;; need locking here so multiple open
-	               ;; do not collide
-	  (let* ((db (sqlite3:open-database dbpath)))
-	    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
-	    (init-proc db))
-	  #;(dbfile:lock-create-open dbpath
-	  (lambda (db)
-	  (init-proc db))))
-	 (write-access (file-write-access? dbpath)))
-    #;(if (and dbexists (not write-access))
-	(set! *db-write-access* #f))
-    ;; (cons db dbpath)))
+	 (write-access (file-write-access? dbpath))
+	 (db           (dbfile:cautious-open-database dbpath))) #;(sqlite3:open-database dbpath)
+    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 10000))
+    (init-proc db)
     (make-dbr:dbdat dbfile: dbpath dbh: db read-only: (not write-access))))
 
 (define (dbfile:print-and-exit . params)
   (with-output-to-port
       (current-error-port)
@@ -446,47 +441,60 @@
 ;; so watch for problems. I'm still not clear if it is needed to manually
 ;; finalize sqlite3 dbs with the sqlite3 egg.
 ;;
 
 (define (dbfile:cautious-open-database fname #!optional (tries-left 5))
-  (let* ((retry (lambda ()
-		  (thread-sleep! 0.5)
+  (let* ((lock-file (conc fname".lock"))
+	 (retry (lambda ()
+		  (thread-sleep! 1.1)
 		  (if (> tries-left 0)
 		      (dbfile:cautious-open-database fname (- tries-left 1))))))
-    (condition-case
-	(sqlite3:open-database fname)
-      (exn (io-error)
-	   (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
-	   (retry))
-      (exn (corrupt)
-	   (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
-	   (retry))
-      (exn (busy)
-	   (dbfile:print-err exn "ERROR: database " fname
-			     " is locked. Try copying to another location, remove original and copy back.")
-	   (retry))
-      (exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
-	   (retry))
-      (exn ()
-	   (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
-			     ((condition-property-accessor 'exn 'message) exn))
-	   (retry)))))
+    (assert (>= tries-left 0) (conc "FATAL: Five attempts in dbfile:cautious-open-database of "fname", giving up."))
+    (if (not (dbfile:simple-file-lock lock-file))
+	(begin
+	  (dbfile:print-err "INFO: lock file "lock-file" exists, trying again in 3 seconds.")
+	  (thread-sleep! 3)
+	  (dbfile:cautious-open-database fname (- tries-left 1)))
+	(let ((result (condition-case
+			  (sqlite3:open-database fname)
+			(exn (io-error)
+			     (dbfile:print-err exn "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")
+			     (retry))
+			(exn (corrupt)
+			     (dbfile:print-err exn "ERROR: database " fname " is corrupt. Repair it to proceed.")
+			     (retry))
+			(exn (busy)
+			     (dbfile:print-err exn "ERROR: database " fname
+					       " is locked. Try copying to another location, remove original and copy back.")
+			     (retry))
+			(exn (permission)(dbfile:print-err exn "ERROR: database " fname " has some permissions problem.")
+			     (retry))
+			(exn ()
+			     (dbfile:print-err exn "ERROR: Unknown error with database " fname " message: "
+					       ((condition-property-accessor 'exn 'message) exn))
+			     (retry)))))
+	  (dbfile:simple-file-release-lock lock-file)
+	  result))))
 
 
 (define (dbfile:open-no-sync-db dbpath)
-  (if (not (file-exists? dbpath))
-      (create-directory dbpath #t))
-  (let* ((dbname    (conc dbpath "/no-sync.db"))
-	 (db-exists (file-exists? dbname))
-	 (db        (dbfile:cautious-open-database dbname))) ;; (sqlite3:open-database dbname)))
-    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
-    (if (not db-exists)
-	(begin
-	  (sqlite3:execute db "PRAGMA synchronous = 0;")
-	  (sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
-	  #;(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
-    db))
+  (if *no-sync-db*
+      *no-sync-db*
+      (begin
+	(if (not (file-exists? dbpath))
+	    (create-directory dbpath #t))
+	(let* ((dbname    (conc dbpath "/no-sync.db"))
+	       (db-exists (file-exists? dbname))
+	       (db        (dbfile:cautious-open-database dbname))) ;; (sqlite3:open-database dbname)))
+	  (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 136000))
+	  (if (not db-exists)
+	      (begin
+		(sqlite3:execute db "PRAGMA synchronous = 0;")
+		(sqlite3:execute db "CREATE TABLE IF NOT EXISTS no_sync_metadat (var TEXT,val TEXT, CONSTRAINT no_sync_metadat_constraint UNIQUE (var));")
+		#;(sqlite3:execute db "PRAGMA journal_mode=WAL;")))
+	  (set! *no-sync-db* db)
+	  db))))
 
 (define (db:no-sync-set db var val)
   (sqlite3:execute db "INSERT OR REPLACE INTO no_sync_metadat (var,val) VALUES (?,?);" var val))
 
 (define (db:no-sync-del! db var)
@@ -564,48 +572,54 @@
 
 ;; dot-locking egg seems not to work, using this for now
 ;; if lock is older than expire-time then remove it and try again
 ;; to get the lock
 ;;
-(define (common:simple-file-lock fname #!key (expire-time 300))
+(define (dbfile:simple-file-lock fname #!key (expire-time 300))
   (let ((fmod-time (handle-exceptions
 		       ext
 		     (current-seconds)
 		     (file-modification-time fname))))
     (if (file-exists? fname)
 	(if (> (- (current-seconds) fmod-time) expire-time)
 	    (begin
 	      (handle-exceptions exn #f (delete-file* fname))	
-	      (common:simple-file-lock fname expire-time: expire-time))
+	      (dbfile:simple-file-lock fname expire-time: expire-time))
 	    #f)
-	(let ((key-string (conc (get-host-name) "-" (current-process-id))))
-	  (with-output-to-file fname
+	(let ((key-string (conc (get-host-name) "-" (current-process-id)))
+	      (oup        (open-output-file fname)))
+	  (with-output-to-port
+	      oup
 	    (lambda ()
 	      (print key-string)))
+	  (close-output-port oup)
+	  #;(with-output-to-file fname
+	    (lambda ()
+	  (print key-string)))
 	  (thread-sleep! 0.25)
 	  (if (file-exists? fname)
 	      (handle-exceptions exn
                 #f 
                 (with-input-from-file fname
 	  	  (lambda ()
 		    (equal? key-string (read-line)))))
 	      #f)))))
 
-(define (common:simple-file-lock-and-wait fname #!key (expire-time 300))
+(define (dbfile:simple-file-lock-and-wait fname #!key (expire-time 300))
   (let ((end-time (+ expire-time (current-seconds))))
-    (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time)))
+    (let loop ((got-lock (dbfile:simple-file-lock fname expire-time: expire-time)))
       (if got-lock
 	  #t
 	  (if (> end-time (current-seconds))
 	      (begin
 		(thread-sleep! 3)
-		(loop (common:simple-file-lock fname expire-time: expire-time)))
+		(loop (dbfile:simple-file-lock fname expire-time: expire-time)))
 	      #f)))))
 
-(define (common:simple-file-release-lock fname)
+(define (dbfile:simple-file-release-lock fname)
   (handle-exceptions
       exn
       #f ;; I don't really care why this failed (at least for now)
     (delete-file* fname)))
 
 
 )