From d63a9c1f51410a88fbfae029f0a9a568d0165d26 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Thu, 9 Apr 2009 12:29:50 +0300
Subject: [PATCH] Added open-directory-steam, directory-stream?,
 read-directory-stream, and close-directory-stream as per bug 315804.

---
 scheme/ikarus.io.ss  | 65 +++++++++++++++++++++++++++++++++++++++++++-
 scheme/last-revision |  2 +-
 scheme/makefile.ss   |  4 +++
 src/ikarus-io.c      | 32 ++++++++++++++++++++++
 4 files changed, 101 insertions(+), 2 deletions(-)

diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index 19fa28f..20fa47a 100644
--- a/scheme/ikarus.io.ss
+++ b/scheme/ikarus.io.ss
@@ -71,7 +71,10 @@
     accept-connection accept-connection-nonblocking
     close-tcp-server-socket 
     register-callback
-    input-socket-buffer-size output-socket-buffer-size)
+    input-socket-buffer-size output-socket-buffer-size
+    
+    open-directory-stream directory-stream?  
+    read-directory-stream close-directory-stream)
 
 
   
@@ -130,6 +133,9 @@
       close-tcp-server-socket 
       register-callback
       input-socket-buffer-size output-socket-buffer-size
+
+      open-directory-stream directory-stream?  
+      read-directory-stream close-directory-stream
       ))
 
   ;(define-syntax assert* (identifier-syntax assert))
@@ -2569,6 +2575,63 @@
       [else (die who "invalid argument" what)]))
 
 
+  (module (directory-stream? open-directory-stream
+           read-directory-stream close-directory-stream)
+
+    (define-struct directory-stream (filename pointer closed?))
+    
+    (define G (make-guardian))
+    
+    (define (clean-up)
+      (cond
+        [(G) =>
+         (lambda (x)
+           (close-directory-stream x #f)
+           (clean-up))]))
+
+    (define (open-directory-stream filename)
+      (define who 'open-directory-stream)
+      (unless (string? filename)
+        (die who "not a string" filename))
+      (clean-up)
+      (let ([rv (foreign-call "ikrt_opendir" (string->utf8 filename))])
+        (if (fixnum? rv)
+            (io-error who filename rv)
+            (let ([stream (make-directory-stream filename rv #f)])
+              (G stream)
+              stream))))
+
+    (define (read-directory-stream x)
+      (define who 'read-directory-stream)
+      (unless (directory-stream? x)
+        (die who "not a directory stream" x))
+      (when (directory-stream-closed? x)
+        (die who "directory stream is closed" x))
+      (let ([rv (foreign-call "ikrt_readdir" 
+                   (directory-stream-pointer x))])
+        (cond
+          [(eqv? rv 0) #f]
+          [else (utf8->string rv)])))
+
+    (define close-directory-stream
+      (case-lambda
+        [(x wanterror?)
+         (define who 'close-directory-stream)
+         (clean-up)
+         (unless (directory-stream? x)
+           (die who "not a directory stream" x))
+         (unless (directory-stream-closed? x)
+           (set-directory-stream-closed?! x #t)
+           (let ([rv (foreign-call "ikrt_closedir" 
+                       (directory-stream-pointer x))])
+             (when (and wanterror? (not (eqv? rv 0)))
+               (io-error who (directory-stream-filename x) rv))))]
+        [(x) (close-directory-stream x #t)]))
+
+    (set-rtd-printer! (type-descriptor directory-stream)
+      (lambda (x p wr) 
+        (fprintf p "#<directory-stream ~a>" 
+           (directory-stream-filename x)))))
 
 
   ;(set-fd-nonblocking 0 'init '*stdin*)
diff --git a/scheme/last-revision b/scheme/last-revision
index ca06b0e..1351198 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1761
+1762
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index fa9287a..f04ff0c 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1271,6 +1271,10 @@
     [directory-list                              i]
     [make-directory                              i]
     [delete-directory                            i]
+    [directory-stream?                           i]
+    [open-directory-stream                       i]
+    [read-directory-stream                       i]
+    [close-directory-stream                      i]
     [change-mode                                 i]
     [make-symbolic-link                          i]
     [make-hard-link                              i]
diff --git a/src/ikarus-io.c b/src/ikarus-io.c
index 5ce0802..2f8b0dc 100644
--- a/src/ikarus-io.c
+++ b/src/ikarus-io.c
@@ -27,6 +27,7 @@
 #include <netdb.h>
 #include <string.h>
 #include <netinet/in.h>
+#include <dirent.h>
 #include "ikarus-data.h"
 
 extern ikptr ik_errno_to_code();
@@ -378,5 +379,36 @@ ikrt_file_mtime(ikptr filename, ikptr res){
 }
 
 
+ikptr
+ikrt_opendir(ikptr dirname, ikpcb* pcb){
+  DIR* d = opendir((char*)(dirname+off_bytevector_data));
+  if(d == NULL){
+    return ik_errno_to_code();
+  }
+  return(make_pointer((long)d, pcb));
+}
 
+ikptr
+ikrt_readdir(ikptr ptr, ikpcb* pcb){
+  DIR* d = (DIR*) ref(ptr, off_pointer_data);
+  struct dirent* ent = readdir(d);
+  if (ent == NULL){
+    return 0;
+  }
+  int len = ent->d_namlen;
+  ikptr bv = ik_safe_alloc(pcb, align(disp_bytevector_data+len+1))
+             + bytevector_tag;
+  ref(bv, -bytevector_tag) = fix(len);
+  memcpy((char*)(bv+off_bytevector_data), ent->d_name, len+1);
+  return bv;
+}
 
+ikptr
+ikrt_closedir(ikptr ptr, ikpcb* pcb){
+  DIR* d = (DIR*) ref(ptr, off_pointer_data);
+  int rv = closedir(d);
+  if (rv == -1){
+    return ik_errno_to_code();
+  }
+  return 0;
+}