diff options
Diffstat (limited to 'transact.scm')
| -rw-r--r-- | transact.scm | 162 |
1 files changed, 78 insertions, 84 deletions
diff --git a/transact.scm b/transact.scm index 3533aa3..5dfbeb6 100644 --- a/transact.scm +++ b/transact.scm @@ -1,5 +1,5 @@ ;;; "transact.scm" Interface to programs. -; Copyright 1997, 1998, 2002 Aubrey Jaffer +; Copyright 1997, 1998, 2002, 2008 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 @@ -90,7 +90,7 @@ "~$" (substring file (min 2 (max 0 (- filen 10))) filen))))) (define (word-lock:certificate lockpath) - (define iport (and (file-exists? lockpath) (open-file lockpath 'rb))) + (define iport (open-file lockpath 'rb)) (and iport (call-with-open-ports @@ -121,6 +121,7 @@ (string-set! name idx (read-char iport)) (set! pos (+ 1 pos))) ;;; read expanded names (interleaved with nul) +;;; I think this is probably UTF-16. (let* ((name2 (and (discard (- 54 pos)) (read-field))) (company (and (discard 6) (read-field))) (name3 (and (discard 8) (read-field)))) @@ -167,36 +168,38 @@ (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) - (write-bytes (make-bytes cnt 0) cnt 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)) + (and oport + (call-with-open-ports + oport (lambda (oport) + (define pos 1) + (define (nulls cnt) + (write-bytes (make-bytes cnt 0) cnt 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))))))) + (nulls (- 54 pos)) + (write-field user) + (nulls 6) + (write-field hostname) + (nulls 8) + (write-field user) + (nulls (- 162 pos)) + (if (not (eqv? 162 pos)) + (slib:error lockpath 'length pos '(not = 162))) + #t)) + (let ((certificate (word-lock:certificate lockpath))) + (and (equal? email certificate) email))))) (define (emacs:lock! path email) (define lockpath (emacs-lock:path path)) @@ -243,7 +246,8 @@ (let ((w-cert (word-lock:certificate w-path))) (cond ((not w-cert) #f) ((not certificate) #f) - ((equal? w-cert certificate) ; my word certificate + ((equal? w-cert certificate) ; word certificate only + ; (emacs certificate is longer) (delete-file w-path)) ((not (eqv? 0 (substring? w-cert certificate))) ;; word certificate doesn't match emacs certificate @@ -260,6 +264,44 @@ (delete-file w-path))))) (else (delete-file w-path)))))))) +;;@args path prefix +;;@args path +;;@1 must be a string naming a file. Optional argument @2 is a string +;;printed before each line of the message. @0 prints to +;;@code{(current-error-port)} that @1 is locked for writing and lists +;;its lock-files. +;; +;;@example +;;(describe-file-lock "my.txt" ">> ") +;;@print{} +;;>> "my.txt" is locked for writing by 'luser@@no.com.4829:1200536423' +;;>> (lock files are "~$my.txt" and ".#my.txt") +;;@end example +(define (describe-file-lock path . prefix) + (define cep (current-error-port)) + (define w-path (word-lock:path path)) + (define e-path (emacs-lock:path path)) + (set! prefix (if (null? prefix) "" (car prefix))) + (let ((w-cert (word-lock:certificate w-path)) + (e-cert (emacs-lock:certificate e-path))) + (cond ((or (file-exists? w-path) (file-exists? e-path)) + (fprintf cep + "%s\"%s\" is locked for writing by '%s'\\n" + prefix + path + (or e-cert w-cert '??))) + (else + (fprintf cep + "%s\"%s\" is not locked for writing\\n" + prefix + path))) + (if e-cert + (fprintf cep "%s(lock files are \"%s\" and \"%s\")\\n" + prefix w-path e-path) + (fprintf cep "%s(lock file is \"%s\")\\n" + prefix w-path)) + (force-output cep))) + ;;;@subsubheading File Transactions (define (emacs:backup-number path) @@ -395,67 +437,19 @@ (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) + (and (zero? (system (string-append "net config workstation >" 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 " User name %s" user) (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)))))) - + ;; Don't want "DNS" from "Workstation Domain DNS Name" + (sscanf line " Workstation domain %s" workgroup))))))) (string-append (or user "John_Doe") "@" (if (and compname (not hostname)) (string-append compname "." (or workgroup "localnet")) |