From a420b6849bb54ec139316df465bd6c00eb8d44af Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 29 Jun 2024 12:55:00 +0300 Subject: [PATCH] Done --- .gitignore | 1 + README.md | 17 ++++++++ retropikzel/pffi/v0-2-2/main.scm | 26 +++++++++--- retropikzel/pffi/v0-2-2/main.sld | 1 + retropikzel/pffi/v0-2-2/sagittarius.scm | 10 +++++ test/800_libcurl.scm | 53 +++++++++++++++++++++++++ 6 files changed, 102 insertions(+), 6 deletions(-) create mode 100644 test/800_libcurl.scm diff --git a/.gitignore b/.gitignore index bf94be3..0469163 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.swp +*.swo docuptmp *.log *.c diff --git a/README.md b/README.md index cf64ddb..422136f 100644 --- a/README.md +++ b/README.md @@ -57,6 +57,7 @@ Got a [question](https://codeberg.org/r7rs-pffi/pffi/projects/9575)? - [Gerbil](https://cons.io/) - [Ypsilon](http://www.littlewingpinball.com/doc/en/ypsilon/) +- [Larceny](https://larcenists.org/) ## Support maybe possible/dreaming about @@ -189,6 +190,22 @@ Arguments: - arguments-types - (list symbol ...) - The C function argument types +#### pffi-define-callback + +Defines new callback function. + +Arguments: + +- scheme-name + - The name of the function used on scheme side +- return-type - symbol + - The return type of the callback +- arguments-types - (list symbol ...) + - The callback function argument types +- procedure - procedure + - Procedure used as callback function + - Argument count must mathc the argument-types count + ### pffi-size-of Get the size of type. diff --git a/retropikzel/pffi/v0-2-2/main.scm b/retropikzel/pffi/v0-2-2/main.scm index 55f4d40..eb284bd 100644 --- a/retropikzel/pffi/v0-2-2/main.scm +++ b/retropikzel/pffi/v0-2-2/main.scm @@ -65,6 +65,7 @@ (export pffi-shared-object-auto-load pffi-shared-object-load pffi-define + pffi-define-callback pffi-size-of pffi-pointer-allocate pffi-pointer-null @@ -155,7 +156,7 @@ (if (get-environment-variable "SystemRoot") (list (string-append (get-environment-variable "SystemRoot") - "system32")) + "system32")) (list)) (list "." ) @@ -171,11 +172,24 @@ (if (get-environment-variable "LD_LIBRARY_PATH") (list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)) (list)) - (list "/lib/x86_64-linux-gnu" - "/usr/lib/x86_64-linux-gnu" - "/usr/local/lib" - "/usr/lib" - "/usr/lib64")))))) + (list + ;;; x86-64 + ; Debian + "/lib/x86_64-linux-gnu" + "/usr/lib/x86_64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + ;;; aarch64 + ; Debian + "/lib/aarch64-linux-gnu" + "/usr/lib/aarch64-linux-gnu" + "/usr/local/lib" + ; Fedora/Alpine + "/usr/lib" + "/usr/lib64" + )))))) (define auto-load-versions (list "")) diff --git a/retropikzel/pffi/v0-2-2/main.sld b/retropikzel/pffi/v0-2-2/main.sld index 9fd08be..eb284bd 100644 --- a/retropikzel/pffi/v0-2-2/main.sld +++ b/retropikzel/pffi/v0-2-2/main.sld @@ -65,6 +65,7 @@ (export pffi-shared-object-auto-load pffi-shared-object-load pffi-define + pffi-define-callback pffi-size-of pffi-pointer-allocate pffi-pointer-null diff --git a/retropikzel/pffi/v0-2-2/sagittarius.scm b/retropikzel/pffi/v0-2-2/sagittarius.scm index a5387cb..2d7ee48 100644 --- a/retropikzel/pffi/v0-2-2/sagittarius.scm +++ b/retropikzel/pffi/v0-2-2/sagittarius.scm @@ -8,6 +8,7 @@ (sagittarius)) (export pffi-shared-object-load pffi-define + pffi-define-callback pffi-size-of pffi-pointer-allocate pffi-pointer-null @@ -44,6 +45,7 @@ ((equal? type 'pointer) 'void*) ((equal? type 'string) 'char*) ((equal? type 'void) 'void) + ((equal? type 'callback) 'callback) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define pffi-pointer? (lambda (object) (pointer? object))) @@ -57,6 +59,14 @@ c-name (map pffi-type->native-type argument-types)))))) + (define-syntax pffi-define-callback + (syntax-rules () + ((pffi-define-callback scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback (pffi-type->native-type return-type) + (map pffi-type->native-type argument-types) + procedure))))) + (define pffi-size-of (lambda (type) (cond ((eq? type 'int8) size-of-int8_t) diff --git a/test/800_libcurl.scm b/test/800_libcurl.scm new file mode 100644 index 0000000..30d7a40 --- /dev/null +++ b/test/800_libcurl.scm @@ -0,0 +1,53 @@ +(import (scheme base) + (scheme write) + (scheme process-context) + (retropikzel pffi v0-2-2 main) + (sagittarius ffi)) + +(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers + (list ".") ; Additional search paths + "curl" ; The named of shared object without the lib prefix + (list ".4"))) ;Additional versions to search + +(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list)) + +; Define the curl-easy-setopt twice since some implementations (Sagittarius) complain if you pass +; callback type instead of pointer type +(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-perform libcurl 'curl_easy_perform 'int (list 'pointer)) + +;These values need to be get from c file like this: +; #include +; int main() { +; printf("Value: %d", CURLOPT_WRITEFUNCTION); +; } +; many times you can get them from .h files directly +(define CURLOPT-WRITEFUNCTION 20011) +(define CURLOPT-FOLLOWLOCATION 52) +(define CURLOPT-URL 10002) + +(define result "") +(pffi-define-callback collect-result + 'int + (list 'pointer 'int 'int 'pointer) + (lambda (pointer size nmemb client-pointer) + (set! result + (string-append result (pffi-pointer->string pointer))))) + +(define handle (curl-easy-init)) +(define url (pffi-string->pointer "https://scheme.org")) +(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url)) +(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url)) +(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result)) +(display curl-code1) +(newline) +(display curl-code2) +(newline) +(display curl-code3) +(newline) +(curl-easy-perform handle) + +(display (string-length result)) +(newline)