;;;; 	Copyright (C) 1995 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; 

;; By Gary Houston (ghouston@actrix.gen.nz)
;;



;; Wrappers to provide the "revealed pot" policy.
;; Follows SCSH.

(define (fdes->inport fdes)
  (let ((ports (fdes->ports fdes)))
    (let loop ((rest-ports ports))
	(cond ((null? rest-ports)
	       (let ((result (fdopen fdes "r")))
		 (set-port-revealed! result 1)
		 result))
	      ((input-port? (car rest-ports))
	       (car rest-ports))
	      (else
	       (loop (cdr rest-ports)))))))

(define (fdes->outport fdes)
  (let ((ports (fdes->ports fdes)))
    (let loop ((rest-ports ports))
	(cond ((null? rest-ports)
	       (let ((result (fdopen fdes "w")))
		 (set-port-revealed! result 1)
		 result))
	      ((output-port? (car rest-ports))
	       (car rest-ports))
	      (else
	       (loop (cdr rest-ports)))))))

(define (port->fdes port)
  (set-port-revealed! port (+ (port-revealed port) 1))
  (fileno port))

(define (release-port-handle port)
  (let ((revealed (port-revealed port)))
    (if (> revealed 0)
	(set-port-revealed! port (- revealed 1)))))

(define (move->fdes port fd)
  (if (= 1 (primitive-move->fdes port fd))
      (set-port-revealed! port 1)))

(define null-device "/dev/null")

;;; Error throwing interfaces to system calls.

(define (syserror key fn err . args)
  (errno err)
  (apply error (cons fn args)))

(define (syscall thunk)
  (errno 0)
  (catch 'syserror thunk syserror))

(define (delete-file filename)
  (syscall
   (lambda ()
     (let ((rv (%delete-file filename)))
       (if (eq? rv #f)
	   (throw 'syserror 'delete-file (errno) filename))))))
  
(define (ftell port)
  (syscall
   (lambda ()
     (let ((rv (%ftell port)))
       (if (eq? rv #f)
	   (throw 'syserror 'ftell (errno) port)
	   rv)))))

(define (file-position port)
  (ftell port))

(define (fseek port offset whence)
  (syscall
   (lambda ()
     (let ((rv (%fseek port offset whence)))
       (if (eq? rv #f)
	   (throw 'syserror 'fseek (errno) port))))))

(define (file-set-position port offset whence)
  (fseek port offset whence))

(define (freopen filename modes port)
  (syscall
   (lambda ()
     (let ((rv (%freopen filename modes port)))
       (if (eq? rv #f)
	   (throw 'syserror 'freopen (errno) filename)
	   rv)))))

(define (reopen-file filename modes port)
  (freopen filename modes port))

(define (duplicate-port port modes)
  (syscall
   (lambda ()
     (let ((rv (%duplicate-port port modes)))
       (if (eq? rv #f)
	   (throw 'syserror 'duplicate-port (errno) port)
	   rv)))))

(define (redirect-port! old new)
  (syscall
   (lambda ()
     (let ((rv (%redirect-port! old new)))
       (if (eq? rv #f)
	   (throw 'syserror 'redirect-port! (errno) old new))))))

(define (opendir dirname)
  (syscall
   (lambda ()
     (let ((rv (%opendir dirname)))
       (if (eq? rv #f)
	   (throw 'syserror 'opendir (errno) dirname)
	   rv)))))

(define (readdir port)
  (syscall
   (lambda ()
     (let ((rv (%readdir port)))
       (if (eq? rv #f)
	   (throw 'syserror 'readdir (errno) port)
	   rv)))))

(define (closedir port)
  (syscall
   (lambda ()
     (let ((rv (%closedir port)))
       (if (eq? rv #f)
	   (throw 'syserror 'closedir (errno) port))))))

(define (mkdir path . mode)
  (syscall
   (lambda ()
     (let ((rv (if (null? mode)
		   (%mkdir path)
		   (%mkdir path (car mode)))))
       (if (eq? rv #f)
	   (throw 'syserror 'mkdir (errno) path))))))

(define (rmdir path)
  (syscall
   (lambda ()
     (let ((rv (%rmdir path)))
       (if (eq? rv #f)
	   (throw 'syserror 'rmdir (errno) path))))))

(define (chdir path)
  (syscall
   (lambda ()
     (let ((rv (%chdir path)))
       (if (eq? rv #f)
	   (throw 'syserror 'chdir (errno) path))))))

(define (getcwd)
  (syscall
   (lambda ()
     (let ((rv (%getcwd)))
       (if (eq? rv #f)
	   (throw 'syserror 'getcwd (errno))
	   rv)))))

(define (chmod path mode)
  (syscall
   (lambda ()
     (let ((rv (%chmod path mode)))
       (if (eq? rv #f)
	   (throw 'syserror 'chmod (errno)))))))

(define (utime path . times)
  (syscall
   (lambda ()
     (let ((rv (cond ((null? times)
		      (%utime path))
		     ((null? (cdr times))
		      (%utime path (car times)))
		     (else
		      (%utime path (car times) (cadr times))))))
       (if (eq? rv #f)
	   (throw 'syserror 'utime (errno) times))))))

(define (rename-file oldname newname)
  (syscall
   (lambda ()
     (let ((rv (%rename-file oldname newname)))
       (if (eq? rv #f)
	   (throw 'syserror 'rename-file (errno) oldname newname))))))

(define (fileno port)
  (syscall
   (lambda ()
     (let ((rv (%fileno port)))
       (if (eq? rv #f)
	   (throw 'syserror 'fileno (errno) port)
	   rv)))))

(define (isatty? port)
  (syscall
   (lambda ()
     (let ((rv (%isatty? port)))
       (if (eof-object? rv)
	   (throw 'syserror 'isatty? (errno) port)
	   rv)))))

(define (fdopen fdes modes)
  (syscall
   (lambda ()
     (let ((rv (%fdopen fdes modes)))
       (if (eq? rv #f)
	   (throw 'syserror 'fdopen (errno) fdes modes)
	   rv)))))

(define (primitive-move->fdes port fdes)
  (syscall
   (lambda ()
     (let ((rv (%primitive-move->fdes port fdes)))
       (if (eq? rv #f)
	   (throw 'syserror 'primitive-move->fdes (errno) port fdes)
	   rv)))))

(define (stat port-or-path)
  (syscall
   (lambda ()
     (let ((rv (%stat port-or-path)))
       (if (eq? rv #f)
	   (throw 'syserror 'stat (errno) port-or-path)
	   rv)))))

(define (putenv str)
  (syscall
   (lambda ()
     (let ((rv (%putenv str)))
       (if (eq? rv #f)
	   (throw 'syserror 'putenv (errno) str))))))

(define (chown path owner group)
  (syscall
   (lambda ()
     (let ((rv (%chown path owner group)))
       (if (eq? rv #f)
	   (throw 'syserror 'chown (errno) path owner group))))))

(define (link oldpath newpath)
  (syscall
   (lambda ()
     (let ((rv (%link oldpath newpath)))
       (if (eq? rv #f)
	   (throw 'syserror 'link (errno) oldpath newpath))))))

(define (pipe)
  (syscall
   (lambda ()
     (let ((rv (%pipe)))
       (if (eq? rv #f)
	   (throw 'syserror 'pipe (errno))
	   rv)))))

(define (getpwuid . args)
  (syscall
   (lambda ()
     (let ((rv (apply %getpwuid args)))
       (if (eq? rv #f)
	   (apply throw `(syserror getpwuid ,(errno) ,@args))
	   rv)))))

(define (getpwent) (getpwuid))

(define (endpwent) (setpwent #f))

(define (getpwnam . args) (apply getpwuid args))

(define (getgrgid user)
  (syscall
   (lambda ()
     (let ((rv (%getgrgid user)))
       (if (eq? rv #f)
	   (throw 'syserror 'getgrgid (errno) user)
	   rv)))))

(define (getgrent) (getgrgid #f))
(define (endgrent) (setgrent #f))

(define (kill pid sig)
  (syscall
   (lambda ()
     (let ((rv (%kill pid sig)))
       (if (eq? rv #f)
	   (throw 'syserror 'kill (errno) pid sig))))))

(define (waitpid pid . options)
  (syscall
   (lambda ()
     (let ((rv (if (null? options)
		   (%waitpid pid)
		   (%waitpid pid (car options)))))
       (if (eq? rv #f)
	   (throw 'syserror 'waitpid (errno) pid)
	   rv)))))

(define (setuid id)
  (syscall
   (lambda ()
     (let ((rv (%setuid id)))
       (if (eq? rv #f)
	   (throw 'syserror 'setuid (errno) id))))))

(define (setgid id)
  (syscall
   (lambda ()
     (let ((rv (%setgid id)))
       (if (eq? rv #f)
	   (throw 'syserror 'setgid (errno) id))))))

(define (seteuid id)
  (syscall
   (lambda ()
     (let ((rv (%seteuid id)))
       (if (eq? rv #f)
	   (throw 'syserror 'seteuid (errno) id))))))

(define (setegid id)
  (syscall
   (lambda ()
     (let ((rv (%setegid id)))
       (if (eq? rv #f)
	   (throw 'syserror 'setegid (errno) id))))))

(define (ttyname port)
  (syscall
   (lambda ()
     (let ((rv (%ttyname port)))
       (if (eq? rv #f)
	   (throw 'syserror 'ttyname (errno) port)
	   rv)))))

(define (uname)
  (syscall
   (lambda ()
     (let ((rv (%uname)))
       (if (eq? rv #f)
	   (throw 'syserror 'uname (errno))
	   rv)))))

(define (execl prog . args)
  (syscall
   (lambda ()
     (let ((rv (apply %execl (cons prog args))))
       (if (eq? rv #f)
	   (throw 'syserror 'execl (errno) args))))))

(define (execlp prog . args)
  (syscall
   (lambda ()
     (let ((rv (apply %execlp (cons prog args))))
       (if (eq? rv #f)
	   (throw 'syserror 'execlp (errno) args))))))

(define (fork)
  (syscall
   (lambda ()
     (let ((rv (%fork)))
       (if (eq? rv #f)
	   (throw 'syserror 'fork (errno))
	   rv)))))

(define (mknod path mode dev)
  (syscall
   (lambda ()
     (let ((rv (%mknod path mode dev)))
       (if (eq? rv #f)
	   (throw 'syserror 'mknod (errno) path))))))

(define (acct path)
  (syscall
   (lambda ()
     (let ((rv (%acct path)))
       (if (eq? rv #f)
	   (throw 'syserror 'acct (errno) path))))))

(define (nice incr)
  (syscall
   (lambda ()
     (let ((rv (%nice incr)))
       (if (eq? rv #f)
	   (throw 'syserror 'nice (errno) incr))))))

(define (symlink oldpath newpath)
  (syscall
   (lambda ()
     (let ((rv (%symlink oldpath newpath)))
       (if (eq? rv #f)
	   (throw 'syserror 'symlink (errno) oldpath newpath))))))

(define (readlink path)
  (syscall
   (lambda ()
     (let ((rv (%readlink path)))
       (if (eq? rv #f)
	   (throw 'syserror 'readlink (errno) path)
	   rv)))))

(define (lstat path)
  (syscall
   (lambda ()
     (let ((rv (%lstat path)))
       (if (eq? rv #f)
	   (throw 'syserror 'lstat (errno) path)
	   rv)))))

(define (getgroups)
  (syscall
   (lambda ()
     (let ((rv (%getgroups)))
       (if (eq? rv #f)
	   (throw 'syserror 'getgroups (errno))
	   rv)))))

(define (select . args)
  (syscall
   (lambda ()
     (let ((rv (apply %select args)))
       (if (number? rv)
	   (apply throw `(syserror select ,(errno) ,@args))
	   rv)))))

(define (open-pty)
  (syscall
   (lambda ()
     (let ((rv (%open-pty)))
       (if (eq? rv #f)
	   (throw 'syserror 'open-pty (errno))
	   rv)))))

(define (child-setup-master-pty port)
  (syscall
   (lambda ()
     (let ((rv (%child-setup-master-pty port)))
       (if (eq? rv #f)
	   (throw 'syserror 'child-setup-master-pty (errno) port))))))

(define (open-slave-pty name)
  (syscall
   (lambda ()
     (let ((rv (%open-slave-pty name)))
       (if (eq? rv #f)
	   (throw 'syserror 'open-slave-pty (errno) name)
	   rv)))))

(define (inet-aton address)
  (syscall
   (lambda ()
     (let ((rv (%inet-aton address)))
       (if (eq? rv #f)
	   (throw 'syserror 'inet-aton (errno) address)
	   rv)))))

(define (socket family style proto)
  (syscall
   (lambda ()
     (let ((rv (%socket family style proto)))
       (if (eq? rv #f)
	   (throw 'syserror 'socket (errno) family style proto)
	   rv)))))

(define (socketpair family style proto)
  (syscall
   (lambda ()
     (let ((rv (%socketpair family style proto)))
       (if (eq? rv #f)
	   (throw 'syserror 'socketpair (errno) family style proto)
	   rv)))))

(define (getsockopt port level optname)
  (syscall
   (lambda ()
     (let ((rv (%getsockopt port level optname)))
       (if (eq? rv #f)
	   (throw 'syserror 'getsockopt (errno) port level optname)
	   rv)))))

(define (setsockopt port level optname value)
  (syscall
   (lambda ()
     (let ((rv (%setsockopt port level optname value)))
       (if (eq? rv #f)
	   (throw 'syserror 'setsockopt (errno) port level optname value))))))

(define (shutdown port how)
  (syscall
   (lambda ()
     (let ((rv (%shutdown port how)))
       (if (eq? rv #f)
	   (throw 'syserror 'shutdown (errno) port how))))))

(define (connect port address . args)
  (syscall
   (lambda ()
     (let ((rv (apply %connect (cons port (cons address args)))))
       (if (eq? rv #f)
	   (throw 'syserror 'connect (errno) port address args))))))

(define (bind sockpt address)
  (syscall
   (lambda ()
     (let ((rv (%bind sockpt address)))
       (if (eq? rv #f)
	   (throw 'syserror 'bind (errno) sockpt address))))))

(define (listen port backlog)
  (syscall
   (lambda ()
     (let ((rv (%listen port backlog)))
       (if (eq? rv #f)
	   (throw 'syserror 'listen (errno) port backlog))))))

(define (accept port)
  (syscall
   (lambda ()
     (let ((rv (%accept port)))
       (if (eq? rv #f)
	   (throw 'syserror 'accept (errno) port)
	   rv)))))

(define (getpeername sockpt)
  (syscall
   (lambda ()
     (let ((rv (%getpeername sockpt)))
       (if (eq? rv #f)
	   (throw 'syserror 'getpeername (errno) sockpt)
	   rv)))))

(define (getsockname sockpt)
  (syscall
   (lambda ()
     (let ((rv (%getsockname sockpt)))
       (if (eq? rv #f)
	   (throw 'syserror 'getsockname (errno) sockpt)
	   rv)))))

