File-append and download-file improvements

Jenkinsfile

@@ -29,7 +29,7 @@ pipeline {
     environment {
         R6RS_SCHEMES='capyscheme chezscheme ikarus ironscheme mosh racket sagittarius ypsilon'
         R7RS_SCHEMES='capyscheme chibi chicken gauche kawa mosh racket sagittarius stklos ypsilon'
-        LIBRARIES='system named-pipes shell download-file'
+        LIBRARIES='system named-pipes shell download-file file-append'
         PWD="${WORKSPACE}"
     }
 

retropikzel/download-file.scm

@@ -1,20 +1,7 @@
-(define CURLOPT-POSTFIELDSIZE 60)
-(define CURLOPT-POSTFIELDS 10015)
 (define CURLOPT-URL 10002)
-(define CURLOPT-HTTPHEADER 10023)
 (define CURLOPT-WRITEDATA 10001)
-(define CURLOPT-WRITEFUNCTION 20011)
-(define CURLOPT-CUSTOMREQUEST 10036)
-(define CURLOPT-COOKIE 10022)
-(define CURLOPT-COOKIEFILE 10031)
-(define CURLOPT-COOKIEJAR 10082)
-(define CURLINFO-RESPONSE-CODE 2097154)
-(define CURLHE-BADINDEX 1)
-(define CURLHE-HEADER 1)
-(define CURLINFO-COOKIELIST 4194332)
-(define randomized? #f)
 
-(define-c-library libc '("stdlib.h" "stdio.h" "time.h") #f '())
+(define-c-library libc '("stdio.h") #f '())
 (define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
 (define-c-procedure c-fclose libc 'fclose 'int '(pointer))
 (define-c-procedure c-perror libc 'perror 'void '(pointer))
@@ -24,11 +11,8 @@
 (define-c-procedure curl-easy-cleanup libcurl 'curl_easy_cleanup 'void '(pointer))
 (define-c-procedure curl-easy-setopt-pointer libcurl 'curl_easy_setopt 'int '(pointer int pointer))
 (define-c-procedure curl-easy-setopt-int libcurl 'curl_easy_setopt 'int '(pointer int int))
-;(define-c-procedure curl-slist-append libcurl 'curl_slist_append 'pointer '(pointer pointer))
 (define-c-procedure curl-easy-strerror libcurl 'curl_easy_strerror 'pointer '(int))
 (define-c-procedure curl-easy-perform libcurl 'curl_easy_perform 'int '(pointer))
-;(define-c-procedure curl-easy-getinfo libcurl 'curl_easy_getinfo 'int '(pointer int pointer))
-;(define-c-procedure curl-easy-nextheader libcurl 'curl_easy_nextheader 'pointer '(pointer int int pointer))
 
 (define (get-right-char-until str chars)
   (let ((result '())
@@ -41,6 +25,10 @@
     (list->string result)))
 
 (define (download-file url . download-path)
+  (when (and (not (null? download-path))
+             (not (string? (car download-path))))
+    (error "download-file error: download-path must be string"
+           (car download-path)))
   (when (< (string-length url) 4)
     (error "download-file error: url too short" url))
   (when (and (not (string=? (string-copy url 0 4) "http"))
@@ -48,10 +36,6 @@
     (error "download-file error: only http or https urls supported" url))
   (when (not (string? url))
     (error "download-file error: url must be string" url))
-  (when (and (not (null? download-path))
-             (not (string? (car download-path))))
-    (error "download-file error: download-path must be string"
-           (car download-path)))
   (let* ((handle (curl-easy-init))
          (to-path (if (null? download-path)
                     (get-right-char-until url '(#\/ #\\))

retropikzel/download-file/README.md

@@ -1 +1,7 @@
 Download file using HTTP or HTTPS.
+
+
+(**download-file** url [download-path])
+
+URL must begin with http or https. If download path is not given file is
+downloaded to the current direcotory with filename from url.

retropikzel/file-append.scm

@@ -1,17 +1,20 @@
 (define-c-library libc '("stdio.h") #f ())
 
 (define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer))
-(define-c-procedure c-fputs libc 'fputs 'int '(pointer pointer))
+;(define-c-procedure c-fputs libc 'fputs 'int '(pointer pointer))
+(define-c-procedure c-fputc libc 'fputc 'int '(int pointer))
 (define-c-procedure c-fclose libc 'fclose 'int '(pointer))
 
+(define mode-cbv (string->c-bytevector "a"))
+
 (define (with-append-to-file path thunk)
-  (let* ((output (parameterize ((current-output-port (open-output-string)))
+  (let* ((path-cbv (string->c-bytevector path))
-                   (apply thunk '())
+         (file-cbv (c-fopen path-cbv mode-cbv)))
-                   (get-output-string (current-output-port))))
+    (string-for-each
-         (mode-cbv (string->c-bytevector "a"))
+      (lambda (c)
-         (path-cbv (string->c-bytevector path))
+        (c-fputc (char->integer c) file-cbv))
-         (file-cbv (c-fopen path-cbv mode-cbv))
+      (parameterize ((current-output-port (open-output-string)))
-         (output-cbv (string->c-bytevector output)))
+        (apply thunk '())
-    (c-fputs output-cbv file-cbv)
+        (get-output-string (current-output-port))))
     (c-fclose file-cbv)
-    (c-bytevector-free mode-cbv path-cbv output-cbv)))
+    (c-bytevector-free path-cbv)))

retropikzel/file-append.sld

@@ -3,7 +3,5 @@
   (import (scheme base)
           (scheme write)
           (foreign c))
-  (cond-expand (mosh (import (srfi 39))
-                     (else)))
   (export with-append-to-file)
   (include "file-append.scm"))

retropikzel/file-append/VERSION

@@ -1 +1 @@
-0.1.1
+0.2.0