From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 May 1995 22:32:44 +0000 (+0000)
Subject: Add OS/HOSTNAME procedure to get a host name suitable for use in an
X-Git-Tag: 20090517-FFI~6340
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=35137be2b58b9f56d32955bba627a62ec12774b3;p=mit-scheme.git

Add OS/HOSTNAME procedure to get a host name suitable for use in an
email address.  (Implemented for unix and OS/2.)
---

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index e9b1219e7..831573653 100644
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: dos.scm,v 1.24 1995/05/02 21:19:13 cph Exp $
+;;;	$Id: dos.scm,v 1.25 1995/05/05 22:32:23 cph Exp $
 ;;;
 ;;;	Copyright (c) 1992-95 Massachusetts Institute of Technology
 ;;;
@@ -471,6 +471,9 @@ Includes the new backup.  Must be > 0."
 (define (os/rmail-pop-procedure)
   #f)
 
+(define (os/hostname)
+  (error "OS/HOSTNAME procedure unimplemented."))
+
 (define (os/interprogram-cut string)
   string push?
   unspecific)
diff --git a/v7/src/edwin/os2.scm b/v7/src/edwin/os2.scm
index 52aaf46d1..d359dbe7d 100644
--- a/v7/src/edwin/os2.scm
+++ b/v7/src/edwin/os2.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: os2.scm,v 1.15 1995/05/04 07:06:12 cph Exp $
+;;;	$Id: os2.scm,v 1.16 1995/05/05 22:32:33 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-95 Massachusetts Institute of Technology
 ;;;
@@ -706,6 +706,26 @@ filename suffix \".gz\"."
 Otherwise, messages remain on the server and will be re-fetched later."
   #t
   boolean?)
+
+(define (os/hostname)
+  (if (not os2/cached-hostname)
+      (let ((buffer (temporary-buffer "*hostname*")))
+	(let ((status.reason
+	       (run-synchronous-process #f (buffer-end buffer) #f #f
+					"hostname")))
+	  (if (not (equal? status.reason '(EXITED . 0)))
+	      (begin
+		(pop-up-buffer buffer)
+		(error "Error running HOSTNAME program:" status.reason))))
+	(set! os2/cached-hostname (string-trim (buffer-string buffer)))
+	(kill-buffer buffer)))
+  os2/cached-hostname)
+
+(define os2/cached-hostname #f)
+(add-event-receiver! event:after-restore
+  (lambda ()
+    (set! os2/cached-hostname #f)
+    unspecific))
 
 ;;;; Generic Stuff
 ;;; These definitions are OS-independent and references to them should
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index b2a52c605..5bddb82d0 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: unix.scm,v 1.49 1995/05/02 21:19:22 cph Exp $
+;;;	$Id: unix.scm,v 1.50 1995/05/05 22:32:44 cph Exp $
 ;;;
 ;;;	Copyright (c) 1989-95 Massachusetts Institute of Technology
 ;;;
@@ -691,6 +691,9 @@ Value is a list of strings."
 (define (os/rmail-pop-procedure)
   #f)
 
+(define os/hostname
+  (ucode-primitive full-hostname 0))
+
 (define (os/ls-file-time-string time)
   (let ((dt (decode-file-time time))
 	(ns (lambda (n m c) (string-pad-left (number->string n) m c))))