guile/guile-scsh ChangeLog filesys.scm

[Gary Houston]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Gary Houston <address@hidden>   01/05/28 15:35:08

Modified files:
        guile-scsh     : ChangeLog filesys.scm 

Log message:
        * filesys.scm (create-directory, create-fifo, create-hard-link,
        create-symlink, create-file-thing): fixed.  for some reason
        these had never been ported to guile.  thanks to Paul Emsley
        for pointing out that create-directory didn't work.

CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/ChangeLog.diff?cvsroot=OldCVS&tr1=1.55&tr2=1.56&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/filesys.scm.diff?cvsroot=OldCVS&tr1=1.3&tr2=1.4&r1=text&r2=text

Patches:
Index: guile/guile-scsh/ChangeLog
diff -u guile/guile-scsh/ChangeLog:1.55 guile/guile-scsh/ChangeLog:1.56
--- guile/guile-scsh/ChangeLog:1.55     Fri May 25 13:09:15 2001
+++ guile/guile-scsh/ChangeLog  Mon May 28 15:35:08 2001
@@ -1,3 +1,10 @@
+2001-05-28  Gary Houston  <address@hidden>
+
+       * filesys.scm (create-directory, create-fifo, create-hard-link,
+       create-symlink, create-file-thing): fixed.  for some reason
+       these had never been ported to guile.  thanks to Paul Emsley
+       for pointing out that create-directory didn't work.
+
 2001-05-25  Gary Houston  <address@hidden>
 
        * syscalls.scm (directory-files): initialise result with '(), not ().
Index: guile/guile-scsh/filesys.scm
diff -u guile/guile-scsh/filesys.scm:1.3 guile/guile-scsh/filesys.scm:1.4
--- guile/guile-scsh/filesys.scm:1.3    Mon Dec  4 15:18:03 2000
+++ guile/guile-scsh/filesys.scm        Mon May 28 15:35:08 2001
@@ -51,22 +51,21 @@
                 (y-or-n? (string-append op-name ": " fname
                                         " already exists. Delete")))))
     (let loop ((override? override?))
-      ;; MAKEIT returns #f if win, errno if lose.
-      (cond ((makeit fname) =>
-            (lambda (err)
-              (if (not (= err errno/exist))
-                  (errno-error err syscall fname)
+      (catch 'system-error
+            (lambda () (makeit fname))
+            (lambda (tag proc msg msg-args rest)
+              (let ((errno (car rest)))
+                (if (= errno errno/exist)
+                    ;; FNAME exists. Nuke it and retry?
+                    (cond ((if (eq? override? 'query)
+                               (query)
+                               override?)
+                           (delete-filesys-object fname)
+                           (loop #t))
+                          (else
+                           (scm-error tag proc msg msg-args rest)))
+                    (scm-error tag proc msg msg-args rest))))))))
 
-                  ;; FNAME exists. Nuke it and retry?
-                  (cond ((if (eq? override? 'query)
-                             (query)
-                             override?)
-                         (delete-filesys-object fname)
-                         (loop #t))
-                        (else
-                         (errno-error err syscall fname))))))))))
-
-
 ;;;;;;;
 
 (define (create-directory dir . rest)
@@ -74,7 +73,7 @@
        (override? (if (or (null? rest) (null? (cdr rest))) #f
                       (cadr rest))))
     (create-file-thing dir
-                      (lambda (dir) (create-directory/errno dir perms))
+                      (lambda (dir) (mkdir dir perms))
                       override?
                       "create-directory"
                       create-directory)))
@@ -84,7 +83,7 @@
        (override? (if (or (null? rest) (null? (cdr rest))) #f
                       (cadr rest))))
     (create-file-thing fifo
-                      (lambda (fifo) (create-fifo/errno fifo perms))
+                      (lambda (fifo) (mknod fifo 'fifo perms 0))
                       override?
                       "create-fifo"
                       create-fifo)))
@@ -92,15 +91,15 @@
 (define (create-hard-link old-fname new-fname . maybe-override?)
   (create-file-thing new-fname
                     (lambda (new-fname)
-                      (create-hard-link/errno old-fname new-fname))
+                      (link old-fname new-fname))
                     (:optional maybe-override? #f)
                     "create-hard-link"
                     create-hard-link))
 
 (define (create-symlink old-fname new-fname . maybe-override?)
   (create-file-thing new-fname
-                    (lambda (symlink)
-                      (create-symlink/errno old-fname symlink))
+                    (lambda (new-fname)
+                      (symlink old-fname new-fname))
                     (:optional maybe-override? #f)
                     "create-symlink"
                     create-symlink))