Import Upstream version 3b1upstream/3b1

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"))