Merge pull request 'Done' (#24) from callback-sagittarius into master

Reviewed-on: https://codeberg.org/r7rs-pffi/pffi/pulls/24

.gitignore

@@ -1,4 +1,5 @@
 *.swp
+*.swo
 docuptmp
 *.log
 *.c

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.

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 ""))
 

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

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)

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 <curl/curl.h>
+; 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)