diff options
Diffstat (limited to 'transact.scm')
| -rw-r--r-- | transact.scm | 486 |
1 files changed, 486 insertions, 0 deletions
diff --git a/transact.scm b/transact.scm new file mode 100644 index 0000000..59a06fe --- /dev/null +++ b/transact.scm @@ -0,0 +1,486 @@ +;;; "transact.scm" Interface to programs. +; Copyright 1997, 1998, 2002 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'string-search) +(require 'filename) +(require 'line-i/o) +(require 'system) +(require 'printf) +(require 'scanf) +(require 'byte) +(require-if 'compiling 'directory) + +;;@subsubheading File Locking +;; +;;@noindent +;;Unix file-locking is focussed on write permissions for segments of a +;;existing file. While this might be employed for (binary) database +;;access, it is not used for everyday contention (between users) for +;;text files. +;; +;;@noindent +;;Microsoft has several file-locking protocols. Their model denies +;;write access to a file if any reader has it open. This is too +;;restrictive. Write access is denied even when the reader has +;;reached end-of-file. And tracking read access (which is much more +;;common than write access) causes havoc when remote hosts crash or +;;disconnect. +;; +;;@noindent +;;It is bizarre that the concept of multi-user contention for +;;modifying files has not been adequately addressed by either of the +;;large operating system development efforts. There is further irony +;;that both camps support contention detection and resolution only +;;through weak conventions of some their document editing programs. +;; +;;@noindent +;;@cindex file-lock +;;The @dfn{file-lock} procedures implement a transaction method for file +;;replacement compatible with the methods used by the GNU @dfn{emacs} +;;text editor on Unix systems and the Microsoft @dfn{Word} editor. +;;@cindex emacs +;; +;;@noindent +;;@cindex certificate +;;Both protocols employ what I term a @dfn{certificate} containing the +;;user, hostname, time, and (on Unix) process-id. +;;Intent to replace @var{file} is indicated by adding to @var{file}'s +;;directory a certificate object whose name is derived from +;;@var{file}. +;; +;;@noindent +;;The Microsoft Word certificate is contained in a 162 byte file named +;;for the visited @var{file} with a @samp{~$} prefix. +;;Emacs/Unix creates a symbolic link to a certificate named for the +;;visited @var{file} prefixed with @samp{.#}. +;;Because Unix systems can import Microsoft file systems, these +;;routines maintain and check both Emacs and Word certificates. + +;;Returns a string naming the path of the emacs-style file-lock symbolic +;;link associated with @1. +(define (emacs-lock:path path) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path)))) + (in-vicinity dir (string-append ".#" file)))) + +;;Returns a string naming the path of the ms-word style lock file +;;associated with @1. +(define (word-lock:path path) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path))) + (filen (string-length file))) + (in-vicinity + dir (string-append + "~$" (substring file (min 2 (max 0 (- filen 10))) filen))))) + +(define (word-lock:certificate lockpath) + (define iport (open-file lockpath "rb")) + (and + iport + (call-with-open-ports + (lambda (iport) + (define len (read-byte iport)) + (define pos 1) + (and (number? len) + (let ((name (make-string len))) + (define (discard cnt) + (do ((cnt (+ -1 cnt) (+ -1 cnt))) + ((or (eof-object? (peek-char iport)) (negative? cnt)) + (negative? cnt)) + (or (eof-object? (read-byte iport)) (set! pos (+ 1 pos))))) + (define (read-field) + (define len (read-byte iport)) + (set! pos (+ 1 pos)) + (or (eof-object? (read-byte iport)) (set! pos (+ 1 pos))) + (and (number? len) + (let ((str (make-string len))) + (do ((idx 0 (+ 1 idx))) + ((or (eof-object? (peek-char iport)) (>= idx len)) + (and (>= idx len) str)) + (string-set! str idx (read-char iport)) + (or (eof-object? (read-char iport)) (set! pos (+ 2 pos))))))) +;;; read compact name + (do ((idx 0 (+ 1 idx))) + ((or (eof-object? (peek-char iport)) (>= idx len))) + (string-set! name idx (read-char iport)) + (set! pos (+ 1 pos))) +;;; read expanded names (interleaved with nul) + (let* ((name2 (and (discard (- 54 pos)) (read-field))) + (company (and (discard 6) (read-field))) + (name3 (and (discard 8) (read-field)))) + (define (check field fieldname) + (cond ((not field) (slib:warn 'missing fieldname)) + ((equal? name field)) + (else (slib:warn fieldname 'mismatch name field)))) + (check name2 'name2) + (check name3 'name3) + (or (and (eof-object? (peek-char iport)) (= pos 162)) + (and (not (and (discard (- 162 pos)) + (eof-object? (peek-char iport)))) + (slib:error lockpath 'length pos '(not = 162)))) + (and name company (sprintf #f "%s@%s" name company)))))) + iport))) + +(define (emacs-lock:certificate lockpath) + (define conflict + (system->line (sprintf #f "ls -ld %#a 2>/dev/null" lockpath))) + (cond ((and conflict (substring? "-> " conflict)) + => (lambda (idx) + (substring conflict (+ 3 idx) (string-length conflict)))) + (conflict (slib:error 'bad 'emacs 'lock lockpath conflict)) + (else #f))) + +(define (file-lock:certificate path) + (or (case (software-type) + ((UNIX COHERENT PLAN9) + (emacs-lock:certificate (emacs-lock:path path))) + (else #f)) + (word-lock:certificate (word-lock:path path)))) + +;;@body +;;Returns the string @samp{@var{user}@@@var{hostname}} associated with +;;the lock owner of file @1 if locked; and #f otherwise. +(define (file-lock-owner path) + (or (emacs-lock:certificate (emacs-lock:path path)) + (word-lock:certificate (word-lock:path path)))) + +(define (word:lock! path email) + (define lockpath (word-lock:path path)) + (define at (substring? "@" email)) + (let ((user (substring email 0 at)) + (hostname (substring email (+ 1 at) (string-length email))) + (oport (open-file lockpath "wb"))) + (define userlen (string-length user)) + (and oport (call-with-open-ports + oport (lambda (oport) + (define pos 1) + (define (nulls cnt) + (display (make-bytes cnt 0) oport) + (set! pos (+ cnt pos))) + (define (write-field field) + (define len (string-length field)) + (write-byte len oport) + (write-byte 0 oport) + (set! pos (+ 2 pos)) + (do ((idx 0 (+ 1 idx))) + ((>= idx len)) + (write-char (string-ref field idx) oport) + (write-byte 0 oport) + (set! pos (+ 2 pos)))) + (write-byte userlen oport) + (display user oport) (set! pos (+ userlen pos)) +;;; write expanded names (interleaved with nul) + (nulls (- 54 pos)) + (write-field user) + (nulls 6) + (write-field hostname) + (nulls 8) + (write-field user) + (nulls (- 162 pos)) + (and (not (eqv? 162 pos)) + (slib:error lockpath 'length pos '(not = 162))) + (let ((certificate (word-lock:certificate lockpath))) + (and (equal? email certificate) email))))))) + +(define (emacs:lock! path email) + (define lockpath (emacs-lock:path path)) + (define certificate (sprintf #f "%s.%s:%d" + email + (or (system->line "echo $PPID") "") + (current-time))) + (and (eqv? 0 (system (sprintf #f "ln -s %#a %#a" certificate lockpath))) + (let ((e-cert (emacs-lock:certificate lockpath))) + (and (equal? certificate e-cert) + certificate)))) + +;;@args path email +;;@args path +;; +;;@1 must be a string naming the file to be locked. If supplied, @2 +;;must be a string formatted as @samp{@var{user}@@@var{hostname}}. If +;;absent, @2 defaults to the value returned by @code{user-email-address}. +;; +;;If @1 is already locked, then @0 returns @samp{#f}. If @1 is +;;unlocked, then @0 returns the certificate string associated with the +;;new lock for file @1. +(define (file-lock! path . email) + (set! email (if (null? email) (user-email-address) (car email))) + (and (string? email) + (not (file-lock:certificate path)) + (let ((wl (word:lock! path email))) + (case (software-type) + ((UNIX COHERENT PLAN9) + ;; file-system may not support symbolic links. + (or (emacs:lock! path email) wl)) + (else wl))))) + +;;@body +;;@1 must be a string naming the file to be unlocked. @2 must be the +;;string returned by @code{file-lock!} for @1. +;; +;;If @1 is locked with @2, then @0 removes the locks and returns +;;@samp{#t}. Otherwise, @0 leaves the file system unaltered and returns +;;@samp{#f}. +(define (file-unlock! path certificate) + (define w-path (word-lock:path path)) + (let ((w-cert (word-lock:certificate w-path))) + (cond ((not w-cert) #f) + ((not certificate) #f) + ((equal? w-cert certificate) ; my word certificate + (delete-file w-path)) + ((not (eqv? 0 (substring? w-cert certificate))) + ;; word certificate doesn't match emacs certificate + (slib:warn 'file-unlock! w-path 'mismatch certificate) #f) + (else + (let ((e-path (emacs-lock:path path))) + (define e-cert (emacs-lock:certificate e-path)) + (case (software-type) + ((UNIX COHERENT PLAN9) + (cond ((not (equal? e-cert certificate)) + (slib:warn 'file-unlock! e-path 'mismatch certificate) + #f) + (else (and (delete-file e-path) + (delete-file w-path))))) + (else (delete-file w-path)))))))) + +;;;@subsubheading File Transactions + +(define (emacs:backup-number path) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path))) + (largest #f)) + (require 'directory) + (if (equal? "" dir) (set! dir "./")) + (directory-for-each + (lambda (str) + (define left.~ (substring? ".~" str)) + (cond ((not left.~)) + ((not (equal? file (substring str 0 left.~)))) + ((string->number (substring str + (+ 2 left.~) + (string-reverse-index str #\~))) + => (lambda (number) + (set! largest (max number (or largest number))))))) + dir (string-append file "*~*[0-9]~")) + largest)) + +;;@body +;;@1 must be a string. @2 must be a symbol. Depending on @2, @0 +;;returns: +;;@table @r +;;@item none +;;#f +;;@item simple +;;the string "@1~" +;;@item numbered +;;the string "@1.~@var{n}~", where @var{n} is one greater than the +;;highest number appearing in a filename matching "@1.~*~". @var{n} +;;defauls to 1 when no filename matches. +;;@item existing +;;the string "@1.~@var{n}~" if a numbered backup already exists in +;;this directory; otherwise. "@1~" +;;@item orig +;;the string "@1.orig" +;;@item bak +;;the string "@1.bak" +;;@end table +(define (emacs:backup-name path backup-style) + (define (numbered bn) (sprintf #f "%s.~%d~" path (+ 1 (or bn 0)))) + (define (simple) (string-append path "~")) + (case backup-style + ((none #f) #f) + ((simple) (simple)) + ((numbered) (numbered (emacs:backup-number path))) + ((existing) (let ((bn (emacs:backup-number path))) + (if bn (numbered bn) (simple)))) + ((orig bak) (sprintf #f "%s.%s" path backup-style)) + (else + (slib:error 'emacs:backup-name 'unknown 'backup-style backup-style)))) + +;;@args proc path backup-style certificate +;;@args proc path backup-style +;;@args proc path +;; +;;@2 must be a string naming an existing file. @3 is one of the +;;symbols @r{none}, @r{simple}, @r{numbered}, @r{existing}, @r{orig}, +;;@r{bak} or @r{#f}; with meanings described above; or a string naming +;;the location of a backup file. @3 defaults to @r{#f}. If supplied, +;;@4 is the certificate with which @2 is locked. +;; +;;@1 must be a procedure taking two string arguments: +;;@itemize @bullet +;;@item +;;@2, the original filename (to be read); and +;;@item +;;a temporary file-name. +;;@end itemize +;; +;;If @2 is locked by other than @4, or if @4 is supplied and @2 is not +;;locked, then @0 returns #f. If @4 is not supplied, then, @0 creates +;;temporary (Emacs and Word) locks for @2 during the transaction. The +;;lock status of @2 will be restored before @0 returns. +;; +;;@0 calls @1 with @2 (which should not be modified) and a temporary +;;file path to be written. +;;If @1 returns any value other than @r{#t}, then the file named by @2 +;;is not altered and @0 returns @r{#f}. +;;Otherwise, @code{emacs:backup-name} is called with @2 and @3. If it +;;returns a string, then @2 is renamed to it. +;; +;;Finally, the temporary file is renamed @2. +;;@0 returns #t if @2 was successfully replaced; and #f otherwise. +(define (transact-file-replacement proc path . args) + (define certificate (case (length args) + ((2) (cadr args)) + ((1 0) #f) + (else (slib:error 'transact-file-replacement + (+ 2 (length args)) 'args)))) + (define backup-style (if (null? args) #f (car args))) + (define move (case (software-type) + ((UNIX COHERENT PLAN9) "mv -f") + ((MS-DOS WINDOWS OS/2 ATARIST) "MOVE /Y") + (else (slib:error (software-type) 'move?)))) + (define (move? tmpfn path) + (eqv? 0 (system (sprintf #f "%s %#a %#a" move tmpfn path)))) + (let* ((dir (pathname->vicinity path)) + (file (substring path (string-length dir) (string-length path))) + (tmpfn (in-vicinity dir (string-append "#" file "#")))) + (cond ((not (file-exists? path)) (slib:warn 'file path 'missing) #f) + (else + (let ((f-cert (file-lock:certificate path))) + (cond ((and f-cert (not (equal? certificate f-cert))) + (slib:warn 'file path 'locked 'by f-cert) #f) + ((and (file-exists? tmpfn) + (slib:warn 'file tmpfn 'exists) + (not (delete-file tmpfn))) + #f) + ((or certificate (file-lock! path)) + => (lambda (cert) + (define result (proc path tmpfn)) + (cond + ((not (eqv? #t result)) + (delete-file tmpfn) + (or f-cert (file-unlock! path cert)) #f) + (else + (let ((bakf + (if (symbol? backup-style) + (emacs:backup-name path backup-style) + backup-style))) + (cond + ((and bakf (not (move? path bakf))) + (or f-cert (file-unlock! path cert)) #f) + ((not (move? tmpfn path)) + (or f-cert (file-unlock! path cert)) #f) + (else + (or f-cert (file-unlock! path cert)) #t))))))) + (else (slib:warn 'could 'not 'lock path) #f))))))) + +(define (windows:user-email-address user hostname) + (define compname (getenv "COMPUTERNAME")) ;without domain + (define workgroup #f) + (define netdir + (or (getenv "windir") + (getenv "winbootdir") + (and (getenv "SYSTEMROOT") + (string-append (getenv "SYSTEMROOT") "\\system32")) + "C:\\windows")) + (call-with-tmpnam + (lambda (tmp) + (define (net . cmd) + (zero? (system (apply string-append + (or netdir "") + (if netdir "\\" "") + "NET " cmd)))) + (and (zero? (system (string-append + (or netdir "") + (if netdir "\\" "") + "IPCONFIG /ALL > " tmp " "))) + (file-exists? tmp) ;(print tmp '=) (display-file tmp) + (call-with-input-file tmp + (lambda (port) + (find-string-from-port? "Host Name" port) + (fscanf port " %*[. ]: %s" hostname))) + (delete-file tmp)) + (and (net "START /LIST >" tmp) + (file-exists? tmp) + (not (eof-object? (call-with-input-file tmp read-char))) + (cond ((call-with-input-file tmp + (lambda (port) + (find-string-from-port? "o network servic" port))) + (and (net "CONFIG /YES >" tmp) (net "STOP /YES"))) + (else (net "CONFIG /YES >" tmp))) + (call-with-input-file tmp + (lambda (port) + (do ((line (read-line port) (read-line port))) + ((eof-object? line)) + (sscanf line " Workstation root directory %s" netdir) + (sscanf line " Computer name \\\\%s" compname) + (sscanf line " Workstation Domain %s" workgroup) + (sscanf line " Workgroup %s" workgroup) + (sscanf line " User name %s" user))))))) + + (and netdir (not (and user hostname)) + (set! netdir (string-append netdir "\\system.ini")) + (file-exists? netdir) + (call-with-input-file netdir + (lambda (port) (and (find-string-from-port? "[DNS]" port) + (read-line port) ;past newline + (do ((line (read-line port) (read-line port))) + ((not (and (string? line) + (string-index line #\=)))) + (sscanf line "HostName=%s" compname) + (sscanf line "DomainName=%s" workgroup))))) + (not user) + (call-with-input-file netdir + (lambda (port) (and (find-string-from-port? "[Network]" port) + (read-line port) ;past newline + (do ((line (read-line port) (read-line port))) + ((not (and (string? line) + (string-index line #\=)))) + (sscanf line "UserName=%s" user)))))) + + (string-append (or user "John_Doe") "@" + (if (and compname (not hostname)) + (string-append compname "." (or workgroup "localnet")) + (or hostname "localhost")))) + +;;@subsubheading Identification + +;;@args +;;@0 returns a string of the form @samp{username@r{@@}hostname}. If +;;this e-mail address cannot be obtained, #f is returned. +(define (user-email-address) + (define user (or (getenv "USER") (getenv "USERNAME"))) + (define hostname (getenv "HOSTNAME")) ;with domain + (cond ((and user hostname) (string-append user "@" hostname)) + (else (case (software-type) + ;;((AMIGA) ) + ;;((MACOS THINKC) ) + ((MS-DOS WINDOWS OS/2 ATARIST) + (windows:user-email-address user hostname)) + ;;((NOSVE) ) + ;;((VMS) ) + ((UNIX COHERENT PLAN9) + (call-with-tmpnam + (lambda (tmp) + (if (not user) (set! user (system->line "whoami" tmp))) + (if (not hostname) (set! hostname (system->line "hostname" tmp))) + (if (not user) (set! user "John_Doe")) + (if (not hostname) (set! hostname "localhost")))) + (string-append user "@" hostname)))))) |