Commits

David Krentzlin  committed 6b794e2

did a fair bit of refactoring. The source parameter can now be a port as well. ( fixes #542 )

  • Participants
  • Parent commits bcefab0

Comments (0)

Files changed (5)

File sendfile.import.scm

 ;;;; sendfile.import.scm - GENERATED BY CHICKEN 4.6.3 -*- Scheme -*-
 
-(eval '(import chicken scheme extras posix srfi-4 foreign lolevel))
+(eval '(import chicken scheme extras posix srfi-4 foreign lolevel ports))
 (##sys#register-compiled-module
   'sendfile
   (list)

File sendfile.scm

  impl:read-write-loop/port mmap-available sendfile-available sendfile)
 (import chicken scheme)
 (require-library posix lolevel srfi-4)
-(import extras posix srfi-4 foreign lolevel)
+(import extras posix srfi-4 foreign lolevel ports)
 
 
 (define (kilobytes num)  (* num 1024))
    ((and bytes (> (+ offset bytes) size)) (complain #f "Bytes + offset exceeds filesize" ))
    (else #t)))
 
-(define (sendfile src dst #!key (offset 0) (bytes #f))
-    (let* ((src (->fileno src))
-           (size (file-size src))
-           (len  (or bytes (- size offset))))
-      
-      ;; ensure sane offset/bytes
-      (ensure-sane-offset/bytes size offset bytes)
-      (if (or (and (eq? (force-implementation) 'read-write-port) (port? dst))
-              (and (port? dst) (not (port-has-fd? dst))))
-          (impl:read-write-loop/port src dst offset len)
-          (begin
-            (flush-output dst) ; Implementations below use non-buffered I/O
-            (let ((dst (->fileno dst)))
-              (case (force-implementation)
-                ((sendfile)
-                 (if sendfile-available
-                     (impl:sendfile src dst offset len)
-                     (complain #f "implementation sendfile was forced but is not available")))
-                ((mmapped)
-                 (if mmap-available
-                     (impl:mmapped src dst offset len)
-                     (complain #f "implementation mmap was forced but is not available")))
-                ((read-write)      (impl:read-write-loop/fd src dst offset len))
-                ((nothing)
-                 (let ((impl ((implementation-selector) size)))
-                   (impl src dst offset len)))
-                (else
-                 (complain #f "invalid implementation forced. Allowed values are (sendfile mmapped read-write read-write-port nothing)"))))))))
+(define (sendfile source target #!key (offset 0) (bytes #f))
+  (cond
+   ((ports? source target)
+    (sendfile/ports source target offset bytes))
+   (else (sendfile/best-strategy source target offset  bytes))))
 
-) ; module
+(define (port-without-fd? port)
+  (and (port? port) (not (port-has-fd? port))))
+
+(define (ports? source target)
+  (or
+   (and (eq? (force-implementation) 'read-write-port) (port? target))
+   (port-without-fd? source)
+   (port-without-fd? target)))
+
+(define (sendfile/ports source target offset bytes-to-send)
+  (if (port-without-fd? source)
+      (impl:read-write-loop/port-both source target offset  bytes-to-send)
+      (let* ((source  (->fileno source))
+             (size (file-size source))
+             (len (or bytes-to-send (- size offset))))
+        
+        (ensure-sane-offset/bytes size offset bytes-to-send)
+        (impl:read-write-loop/port source target offset len))))
+
+(define (sendfile/best-strategy source target offset bytes-to-send)
+    (let* ((source (->fileno source))
+           (size (file-size source))
+           (len  (or bytes-to-send (- size offset))))
+
+      (ensure-sane-offset/bytes size offset bytes-to-send)
+      (flush-output target)
+      (let ((target (->fileno target)))
+        (case (force-implementation)
+          ((sendfile)
+           (if sendfile-available
+               (impl:sendfile source target offset len)
+               (complain #f "implementation sendfile was forced but is not available")))
+          ((mmapped)
+           (if mmap-available
+               (impl:mmapped source target offset len)
+               (complain #f "implementation mmap was forced but is not available")))
+          ((read-write)      (impl:read-write-loop/fd source target offset len))
+          ((nothing)
+           (let ((impl ((implementation-selector) size)))
+             (impl source target offset len)))
+          (else
+           (complain #f "invalid implementation forced. Allowed values are (sendfile mmapped read-write read-write-port nothing)"))))))
+)
+
+

File strategies/rw.scm

 (define sys-seek (foreign-lambda int "lseek" integer integer int))
 (define-foreign-variable seek-set int "SEEK_SET")
 
+
+(define (impl:read-write-loop/port-both src dst offset bytes)
+  (set!  *last-selected-implementation* 'read-write-loop)
+  
+  (when (positive? offset)
+    (port-seek src offset))
+
+  (cond
+   ((not bytes)
+    (let ((bytes-send 0))
+      (copy-port src dst read-char (lambda (c to)
+                                     (set! bytes-send (+ bytes-send 1))
+                                     (write-char c to)))
+      bytes-send))
+   (else
+    (let loop ((bytes bytes))
+      (if (positive? bytes)
+        (let ((char (read-char src)))
+          (unless (eof-object? char)
+            (write-char char dst)
+            (loop (- bytes 1))))))
+    bytes)))
+
+(define (port-seek port bytes)
+  (let loop ((bytes bytes))
+        (when (positive? bytes)
+          (let ((char (read-char port)))
+            (unless (eof-object? char)
+              (loop (- bytes 1)))))))
+
 (define (impl:read-write-loop/port src dst offset bytes)
   (set!  *last-selected-implementation* 'read-write-loop)
   
           bytes-read
           (let* ((to-read (fxmin buffsize (inexact->exact bytes-left)))
                  (read-bytes (cadr (file-read src to-read buffer))))
+;            (printf "Now writing ~A~%" (substring buffer 0 read-bytes))
             (display (substring buffer 0 read-bytes) dst)
             (loop (- bytes-left read-bytes) (+ bytes-read read-bytes)))))))
 

File tests/run.scm

                      offset-test-file
                      (lambda (in out)
                        (parameterize ((force-implementation 'read-write-port))
-                         (sendfile in out offset: 1400))) #t)
+                         (sendfile in out offset: 1400))) #t #f)
                     (file-contents test-file-out)))
 
             (test "giving size"
                      offset-test-file
                      (lambda (in out)
                        (parameterize ((force-implementation 'read-write-port))
-                         (sendfile in out bytes: 32))) #t)
+                         (sendfile in out bytes: 32))) #t #f)
                     (file-contents test-file-out)))
 
             (test "giving size and offset"
                      offset-test-file
                      (lambda (in out)
                        (parameterize ((force-implementation 'read-write-port))
-                         (sendfile in out offset: 213 bytes: 15))) #t)
+                         (sendfile in out offset: 213 bytes: 15))) #t #f)
                     (file-contents test-file-out)))
 
             
        test-file-size
        (with-prepared-environment test-file
         (lambda (in out)
-          (impl:read-write-loop/fd in out 0 test-file-size))))
+          (impl:read-write-loop/fd in out 0 test-file-size)) #f #f))
       (sleep 1)
       (test "verify"
        test-file-checksum
         test-file-size
         (with-prepared-environment test-file
          (lambda (in out)
-             (impl:read-write-loop/port in out 0 test-file-size)) #t))
+             (impl:read-write-loop/port in out 0 test-file-size)) #t #f))
       (sleep 1)
       (test "verify"
        test-file-checksum
                       test-file-size 
                       (with-prepared-environment test-file
                        (lambda (in out)
-                         (impl:sendfile in out 0 test-file-size))))
+                         (impl:sendfile in out 0 test-file-size)) #f #f))
                  (sleep 1)
                  (test "verify"
                        test-file-checksum
                       test-file-size 
                       (with-prepared-environment test-file
                        (lambda (in out)
-                         (impl:mmapped in out 0 test-file-size))))
+                         (impl:mmapped in out 0 test-file-size)) #f #f))
                 (sleep 1)
                 (test "verify"
                       test-file-checksum
             test-file-size
             (with-prepared-environment test-file
              (lambda (in out)
-               (sendfile in out)) #t))
+               (sendfile in out)) #t #f))
       (sleep 1)
       (test "verify"
             test-file-checksum
             (compute-file-checksum test-file-out)))
 
+
+
+
+(test-group "custom input port without fd [bug #542]"
+            (let ((test-content "I'm content from a custom port"))
+              (test "send"
+                    (string-length test-content)
+                    (with-prepared-environment test-file
+                                               (lambda (ignored out)
+                                                 (sendfile
+                                                  (open-input-string test-content)
+                                                  out)) #t #t))))
+
+
+
 (test-end "interface")
 
 (test-begin "forcing implementation")

File tests/test-utils.scm

 ;; the size of the file to transfer in bytes
 (define wanted-test-file-size (* 1024 1024))
 
+
 ;; this may differ slightly from wanted-test-file-size
 ;; it is computed using (file-size)
 ;; The reason for the difference is that we use a fixed-size
 (define (destroy-test-files)
   (if (file-exists? test-file) (delete-file test-file)))
 
+(define (destroy-test-file-out)
+  (if (file-exists? test-file-out) (delete-file test-file-out)))
 
-(define (with-prepared-environment file proc #!optional (ports? #f) (return-output #f))
+
+(define (with-prepared-environment file proc #!optional (ports? #f) (cleanup? #t))
+  (when cleanup?
+    (destroy-test-file-out))
+  
   (parameterize ((tcp-read-timeout 3))
     (let ((in (file-open file (bitwise-ior open/rdonly open/binary)))
           (size (file-size file)))
 
 (define (tear-down pid)
   (destroy-test-files)
-  (stop-server pid))        
+  (stop-server pid))