summaryrefslogtreecommitdiffstats
path: root/transact.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:40 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:40 -0800
commit4684239efa63dc1b2c1cbe37ef7d3062029f5532 (patch)
tree606a687e9279e9bf6048925878968df9875a4973 /transact.scm
parent64f037d91e0c9296dcaef9a0ff3eb33b19a2ed34 (diff)
downloadslib-4684239efa63dc1b2c1cbe37ef7d3062029f5532.tar.gz
slib-4684239efa63dc1b2c1cbe37ef7d3062029f5532.zip
Import Upstream version 3b1upstream/3b1
Diffstat (limited to 'transact.scm')
-rw-r--r--transact.scm162
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"))