diff --git a/Jenkinsfile b/Jenkinsfile index fef76cf..b77dbd3 100644 --- a/Jenkinsfile +++ b/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}" } diff --git a/retropikzel/download-file.scm b/retropikzel/download-file.scm index b1abad0..04f754c 100644 --- a/retropikzel/download-file.scm +++ b/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 '(#\/ #\\)) diff --git a/retropikzel/download-file/README.md b/retropikzel/download-file/README.md index 658de82..59385a2 100644 --- a/retropikzel/download-file/README.md +++ b/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. diff --git a/retropikzel/file-append.scm b/retropikzel/file-append.scm index 605a637..247b2e9 100644 --- a/retropikzel/file-append.scm +++ b/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))) - (apply thunk '()) - (get-output-string (current-output-port)))) - (mode-cbv (string->c-bytevector "a")) - (path-cbv (string->c-bytevector path)) - (file-cbv (c-fopen path-cbv mode-cbv)) - (output-cbv (string->c-bytevector output))) - (c-fputs output-cbv file-cbv) + (let* ((path-cbv (string->c-bytevector path)) + (file-cbv (c-fopen path-cbv mode-cbv))) + (string-for-each + (lambda (c) + (c-fputc (char->integer c) file-cbv)) + (parameterize ((current-output-port (open-output-string))) + (apply thunk '()) + (get-output-string (current-output-port)))) (c-fclose file-cbv) - (c-bytevector-free mode-cbv path-cbv output-cbv))) + (c-bytevector-free path-cbv))) diff --git a/retropikzel/file-append.sld b/retropikzel/file-append.sld index 7f41078..024a22d 100644 --- a/retropikzel/file-append.sld +++ b/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")) diff --git a/retropikzel/file-append/VERSION b/retropikzel/file-append/VERSION index 17e51c3..0ea3a94 100644 --- a/retropikzel/file-append/VERSION +++ b/retropikzel/file-append/VERSION @@ -1 +1 @@ -0.1.1 +0.2.0