summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--scsh-process.scm17
-rw-r--r--tests/run.scm12
2 files changed, 21 insertions, 8 deletions
diff --git a/scsh-process.scm b/scsh-process.scm
index 6102c4d..57a773e 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -214,19 +214,22 @@
(define-syntax setup-redirection
(syntax-rules (< > << >> = - stdports)
((_ (< ?file-name)) (setup-redirection (< 0 ?file-name)))
- ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
((_ (<< ?object)) (setup-redirection (<< 0 ?object)))
- ((_ (>> ?object)) (setup-redirection (>> 1 ?object)))
- ((_ (< ?fd ?file-name))
- (duplicate-fileno (file-open (maybe-symbol->string `?file-name)
- open/rdonly)
- `?fd))
+ ((_ (> ?file-name)) (setup-redirection (> 1 ?file-name)))
+ ((_ (>> ?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 ?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)
diff --git a/tests/run.scm b/tests/run.scm
index 4e3bb8a..df73ac3 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -38,7 +38,17 @@
(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"))