Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Modify tests to work on C std only

This commit is contained in:
retropikzel 2024-09-22 08:26:39 +03:00
parent 8b362b4bfb
commit 7f996ab03c
1 changed files with 25 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
test.scm
View File

@ -342,48 +342,34 @@
(print-header 'pffi-define-callback) (print-header 'pffi-define-callback)
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers (define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3)))
(list ".") ; Additional search paths (pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3)
"curl" ; The named of shared object without the lib prefix (pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2)
(list ".4"))) (pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1)
(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list))
(pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer))
(pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback))
(pffi-define curl-easy-getinfo libcurl 'curl_easy_getinfo 'int (list 'pointer 'int 'pointer))
(pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer))
(define CURLOPT-WRITEFUNCTION 20011)
(define CURLOPT-FOLLOWLOCATION 52)
(define CURLOPT-URL 10002)
(define CURLINFO-RESPONSE-CODE 2097154)
(define result "") (pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback))
(pffi-define-callback collect-result
'void
(list 'pointer 'int 'int 'pointer)
(lambda (pointer size nmemb client-pointer)
(set! result (string-append result (string-copy (pffi-pointer->string pointer))))))
(define handle (curl-easy-init)) (pffi-define-callback compare
(define url "https://scheme.org") 'int
(debug url) (list 'pointer 'pointer)
(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION (pffi-string->pointer url))) (lambda (pointer-a pointer-b)
(debug curl-code1) (let ((a (pffi-pointer-get pointer-a 'int 0))
(assert = curl-code1 0) (b (pffi-pointer-get pointer-b 'int 0)))
(cond ((> a b) 1)
((= a b) 0)
((< a b) -1)))))
(define curl-code2 (curl-easy-setopt handle CURLOPT-URL (pffi-string->pointer url))) (display "Unsorted: ")
(debug curl-code2) (write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))
(assert = curl-code2 0) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1))
(pffi-pointer-get array 'int (* (pffi-size-of 'int) 2))))
(newline)
(qsort array 3 (pffi-size-of 'int) compare)
(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result)) (display "Sorted: ")
(debug curl-code3) (write (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))
(assert = curl-code3 0) (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1))
(pffi-pointer-get array 'int (* (pffi-size-of 'int) 2))))
(define curl-code4 (curl-easy-perform handle)) (newline)
(debug curl-code4)
(assert = curl-code4 0)
(define http-code (pffi-pointer-allocate (pffi-size-of 'int)))
(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE http-code)
(assert = (pffi-pointer-get http-code 'int 0) 200)
(exit 0) (exit 0)