Commits

Peter Bex committed e2c9731

Implement appending to files

  • Participants
  • Parent commits 803b02c

Comments (0)

Files changed (2)

 (define-syntax setup-redirection
   (syntax-rules (< > << >> = - stdports)
     ((_ (< ?file-name)) (setup-redirection (< 0 ?file-name)))
+    ((_ (<< ?object)) (setup-redirection (<< 0 ?object)))
     ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
-    ((_ (<< ?object)) (setup-redirection (<< 0 ?object)))
-    ((_ (>> ?object)) (setup-redirection (>> 1 ?object)))
+    ((_ (>> ?file-name)) (setup-redirection (>> 1 ?file-name)))
+    ((_ (> ?fd ?file-name))
+     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
+                                  (fx+ open/wronly open/creat))
+                       `?fd))
+    ((_ (>> ?fd ?file-name))
+     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
+                                  (fx+ open/wronly (fx+ open/append open/creat)))
+                       `?fd))
     ((_ (< ?fd ?file-name))
      (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
                                   open/rdonly)
                        `?fd))
-    ((_ (> ?fd ?file-name))
-     (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
-                                  (fx+ open/wronly open/creat))
-                       `?fd))
     ((_ (<< ?fd ?object)) (error "<< currently not implemented"))
-    ((_ (>> ?fd ?object)) (error ">> currently not implemented"))
     ((_ (= ?fd-from ?fd/port-to))
      (let* ((fd/port-to ?fd/port-to)    ; Evaluate once
             (fd-to (if (port? fd/port-to)
     (let ((tmpfile (run/file (echo "blah"))))
       (test "Simple run/file"
             "blah\n"
-            (with-input-from-file tmpfile read-all))))
+            (with-input-from-file tmpfile read-all))
+
+      (test "Appending to a file"
+            '("blah" "foo")
+            (begin (run (echo foo) (>> ,tmpfile))
+                   (read-lines tmpfile)))
+      
+      (test "Redirecting from object"
+            '("blah" "foo" "testing, 1 2 3")
+            (run/strings (cat tmpfile -) (<< "testing, 1 2 3")))
+      (delete-file* tmpfile)))
 
   (test-group "Subprocesses"
     (let ((outfile "outfile"))