DELETED utils/softlock.scm
Index: utils/softlock.scm
==================================================================
--- utils/softlock.scm
+++ /dev/null
@@ -1,124 +0,0 @@
-;;======================================================================
-;; Copyright 2019, 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 .
-;;
-;;======================================================================
-
-(use posix srfi-18)
-
-
-(if (< (length (command-line-arguments)) 2) ;; require at least lockfile command
- (begin
- (print "Usage:
-softlock lockfile command args ...
-
-Softlock does weak, transient locking. This is useful to slow down a
-deluge of events that can overwhelm hardware or software systems.
-
-Locks are only good for one second, just enough time to spread events
-out.
-
-On NFS the Unix file locking mechanism works well but lock handling on
-the filers can be overwhelmed by many locks occuring quickly. Jobs
-that must use NFS file locks can use softlock to minimize the rate
-that the file locks are created, preventing the NFS filer from being
-swamped.
-
-Environment variables:
-
- SOFTLOCK_DEBUG_MODE - if defined enable some messages
-
-WARNING: the file .softlock will be overwritten and removed by softlock!
-
-Part of the Megatest project http://www.kiatoa.com/fossils/megatest")
- (exit 1)))
-
-(define (read-lock-file fname)
- (handle-exceptions
- exn
- (begin
- (if (get-environment-variable "SOFTLOCK_DEBUG_MODE")
- (print "Exception on reading lock file. exn=" exn))
- #f)
- (with-input-from-file fname
- read-line)))
-
-(define (lock-file-old fname)
- (and (file-exists? fname)
- (> (- (current-seconds)(file-modification-time fname)) 1))) ;; hard coded to one second
-
-(define (check-locked-by-me fname mykey)
- (if (file-exists? fname)
- (let ((lock-data (read-lock-file fname)))
- (if (and lock-data
- (equal? mykey lock-data))
- #t
- (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked.
- #f))
-
-(define (check-locked-by-someone-else fname mykey)
- (if (file-exists? fname)
- (let ((lock-data (read-lock-file fname)))
- (and lock-data
- (not (equal? mykey lock-data))
- (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked.
- #f))
-
-(define (take-lock fname mykey)
- (with-output-to-file fname
- (lambda ()
- (print mykey))))
-
-(define (run-the-command command params)
- (process-wait (process-run command params)))
-
-(let* ((lockfile (car (command-line-arguments)))
- (fulllock (conc lockfile ".softlock")) ;; prevent accidentally removing important files
- (lockfdir (pathname-directory lockfile))
- (command (cadr (command-line-arguments)))
- (params (cddr (command-line-arguments)))
- (mykey (conc (get-host-name) "-" (current-process-id))))
-
- ;; sanity checks
- (cond
- ((not lockfdir)
- (print "ERROR: lock file parameter must include path component, e.g. ./mylock")
- (exit 1))
- ((not (file-write-access? lockfdir))
- (print "ERROR: Can not access directory for lock " lockfdir)
- (exit 1))
- ;; add more sanity checks here
- )
-
- (let loop ((remtries 10))
- (if (> remtries 0)
- (if (check-locked-by-someone-else fulllock mykey)
- (begin
- (print "... lock " fulllock " exists, waiting...")
- (thread-sleep! 1.9)
- (loop (- remtries 1)))
- (begin
- (take-lock fulllock mykey)
- (if (check-locked-by-me fulllock mykey)
- (run-the-command command params)
- (begin ;; didn't get the lock
- (thread-sleep! (+ 1.9 (/ 1 (+ 1 (random 20))))) ;; add some noise to prevent nyquist problems
- (loop (- remtries 1))))))
- (begin
- (print "ERROR: not able to get the lock. Gonna take it and proceed...")
- (take-lock fulllock mykey)
- (run-the-command command params)))))
ADDED utils/softlock/Makefile
Index: utils/softlock/Makefile
==================================================================
--- /dev/null
+++ utils/softlock/Makefile
@@ -0,0 +1,11 @@
+#Need a chicken 5.1.0 with system-information egg installed in your path
+
+.DEFAULT : all
+
+all : softlock
+
+softlock : softlock.scm
+ csc -static -L -static -L -lm -L -dl -L -lpthread -L -lcrypto -L -lz softlock.scm
+
+clean:
+ rm softlock *.o
ADDED utils/softlock/softlock.scm
Index: utils/softlock/softlock.scm
==================================================================
--- /dev/null
+++ utils/softlock/softlock.scm
@@ -0,0 +1,135 @@
+;;======================================================================
+;; Copyright 2019, 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 .
+;;
+;;======================================================================
+
+(import (chicken string)
+ (chicken pathname)
+ system-information
+ (chicken file posix)
+ (chicken process-context posix)
+ (chicken process-context)
+ (chicken process)
+ (chicken file posix)
+ (chicken file)
+ (chicken time)
+ srfi-18
+)
+
+
+(if (< (length (command-line-arguments)) 2) ;; require at least lockfile command
+ (begin
+ (print "Usage:
+softlock lockfile command args ...
+
+Softlock does weak, transient locking. This is useful to slow down a
+deluge of events that can overwhelm hardware or software systems.
+
+Locks are only good for one second, just enough time to spread events
+out.
+
+On NFS the Unix file locking mechanism works well but lock handling on
+the filers can be overwhelmed by many locks occuring quickly. Jobs
+that must use NFS file locks can use softlock to minimize the rate
+that the file locks are created, preventing the NFS filer from being
+swamped.
+
+Environment variables:
+
+ SOFTLOCK_DEBUG_MODE - if defined enable some messages
+
+WARNING: the file .softlock will be overwritten and removed by softlock!
+
+Part of the Megatest project http://www.kiatoa.com/fossils/megatest")
+ (exit 1)))
+
+(define (read-lock-file fname)
+ (handle-exceptions
+ exn
+ (begin
+ (if (get-environment-variable "SOFTLOCK_DEBUG_MODE")
+ (print "Exception on reading lock file. exn=" exn))
+ #f)
+ (with-input-from-file fname
+ read-line)))
+
+(define (lock-file-old fname)
+ (and (file-exists? fname)
+ (> (- (current-seconds)(file-modification-time fname)) 1))) ;; hard coded to one second
+
+(define (check-locked-by-me fname mykey)
+ (if (file-exists? fname)
+ (let ((lock-data (read-lock-file fname)))
+ (if (and lock-data
+ (equal? mykey lock-data))
+ #t
+ (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked.
+ #f))
+
+(define (check-locked-by-someone-else fname mykey)
+ (if (file-exists? fname)
+ (let ((lock-data (read-lock-file fname)))
+ (and lock-data
+ (not (equal? mykey lock-data))
+ (not (lock-file-old fname)))) ;; if the lockfile is old we are NOT locked.
+ #f))
+
+(define (take-lock fname mykey)
+ (with-output-to-file fname
+ (lambda ()
+ (print mykey))))
+
+(define (run-the-command command params)
+ (process-wait (process-run command params)))
+
+(let* ((lockfile (car (command-line-arguments)))
+ (fulllock (conc lockfile ".softlock")) ;; prevent accidentally removing important files
+ (lockfdir (pathname-directory lockfile))
+ (command (cadr (command-line-arguments)))
+ (params (cddr (command-line-arguments)))
+ (mykey (conc (get-host-name) "-" (current-process-id))))
+
+ ;; sanity checks
+ (cond
+ ((not lockfdir)
+ (print "ERROR: lock file parameter must include path component, e.g. ./mylock")
+ (exit 1))
+ ((not (file-writable? lockfdir))
+ (print "ERROR: Can not access directory for lock " lockfdir)
+ (exit 1))
+ ;; add more sanity checks here
+ )
+
+ (let loop ((remtries 10))
+ (if (> remtries 0)
+ (if (check-locked-by-someone-else fulllock mykey)
+ (begin
+ (print "... lock " fulllock " exists, waiting...")
+ (thread-sleep! 1.9)
+ (loop (- remtries 1)))
+ (begin
+ (take-lock fulllock mykey)
+ (if (check-locked-by-me fulllock mykey)
+ (run-the-command command params)
+ (begin ;; didn't get the lock
+ (thread-sleep! (+ 1.9 (/ 1 (+ 1 (random 20))))) ;; add some noise to prevent nyquist problems
+ (loop (- remtries 1))))))
+ (begin
+ (print "ERROR: not able to get the lock. Gonna take it and proceed...")
+ (take-lock fulllock mykey)
+ (run-the-command command params)))))