More shit. Can do basic calls and stuff. Using manual result fetching…

… for callresults works, using the callback system crashes on a null pointer deref upon call-results. No idea how to debug.

c-object.lisp

@@ -40,7 +40,7 @@
 (defmethod initialize-instance :around ((object c-managed-object) &key handle)
   (if handle
       (call-next-method)
-      (with-cleanup-on-error (free object)
+      (with-cleanup-on-failure (free object)
         (call-next-method))))
 
 (defgeneric allocate-handle (c-managed-object))

callback.lisp

@@ -41,19 +41,19 @@
   (let ((callback (pointer->object this)))
     (if callback
         (callback callback (cffi:mem-ref parameter `(:struct ,(struct-type callback))))
-        (warn "Callback for unregistered pointer ~a" this))))
+        (warn* "Callback for unregistered pointer ~a" this))))
 
 (cffi:defcallback callback-with-info :void ((this :pointer) (parameter :pointer) (failed :bool) (api-call :uint64))
   (let ((callback (pointer->object this)))
     (if callback
         (callback callback (cffi:mem-ref parameter `(:struct ,(struct-type callback))) failed api-call)
-        (warn "Callback for unregistered pointer ~a" this))))
+        (warn* "Callback for unregistered pointer ~a" this))))
 
 (cffi:defcallback size :int ((this :pointer))
   (let ((callback (pointer->object this)))
     (if callback
         (cffi:foreign-type-size `(:struct ,(struct-type callback)))
-        (warn "Callback for unregistered pointer ~a" this))))
+        (warn* "Callback for unregistered pointer ~a" this))))
 
 (defclass callresult (callback)
   ())
@@ -65,23 +65,37 @@
     (setf (steam::callback-function handle) (cffi:callback result))
     (steam::register-call-result handle call-id)))
 
+(defmethod free-handle-function ((callresult callresult) handle)
+  (lambda ()
+    (steam::unregister-call-result handle call-id)
+    (cffi:foreign-free handle)))
+
 (defmethod maybe-result ((callresult callresult))
   (let ((utils (handle (utils (steamworks)))))
     (cffi:with-foreign-object (failed :bool)
       (when (steam::utils-is-apicall-completed utils (call-id callresult) failed)
         (result callresult)))))
 
 (defmethod result ((callresult callresult))
-  (let ((utils (handle (utils (steamworks))))
+  (let ((utils (handle (interface 'steamutils T)))
+        (token (steam::callback-token (handle callresult)))
         (result-type `(:struct ,(struct-type callresult))))
-    (cffi:with-foreign-object (result result-type)
+    (cffi:with-foreign-objects ((failed :bool)
+                                (result result-type))
       (if (steam::utils-get-apicall-result
-           utils id result (cffi:foreign-type-size result-type) (symbol-value (struct-type callresult)) failed)
+           utils token result (cffi:foreign-type-size result-type) (symbol-value (struct-type callresult)) failed)
           (cffi:mem-ref result result-type)
-          (error "FIXME: call failed: ~a" (steam::utils-get-apicall-failure-reason utils id))))))
+          (error "FIXME: call failed: ~a" (steam::utils-get-apicall-failure-reason utils token))))))
 
 (cffi:defcallback result :void ((this :pointer) (parameter :pointer) (failed :bool))
   (let ((callback (pointer->object this)))
     (if callback
-        (callback callback (cffi:mem-ref parameter `(:struct ,(struct-type callback))))
-        (warn "Callback for unregistered pointer ~a" this))))
+        (callback callback (cffi:mem-ref parameter `(:struct ,(struct-type callback))) failed)
+        (warn* "Callback for unregistered pointer ~a" this))))
+
+(defclass closure-callresult (callresult)
+  ((closure :initarg :closure :initform (error "CLOSURE required.") :reader closure)))
+
+(defmethod callback ((callresult closure-callresult) parameter &optional failed api-call)
+  (declare (ignore api-call))
+  (funcall (closure callresult) (if failed NIL parameter)))

cl-steamworks.asd

@@ -21,6 +21,7 @@
                (:file "steamclient")
                (:file "steamutils")
                (:file "steamuser")
+               (:file "steamfriends")
                (:file "documentation"))
   :depends-on (:documentation-utils
                :alexandria

steamfriends.lisp

@@ -0,0 +1,14 @@
+#|
+ This file is a part of cl-steamworks
+ (c) 2019 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
+ Author: Nicolas Hafner <shinmera@tymoon.eu>
+|#
+
+(in-package #:org.shirakumo.fraf.steamworks)
+
+(defclass steamfriends (interface)
+  ())
+
+(defmethod initialize-instance :after ((interface steamfriends) &key version steamworks)
+  (setf (handle interface) (get-interface-handle steamworks 'steam::client-get-isteam-friends
+                                                 (user steamworks) (pipe steamworks) version)))

steamworks.lisp

@@ -8,7 +8,7 @@
 
 (defvar *steamworks* NIL)
 (defvar *default-interfaces*
-  '(steamclient steamutils steamuser))
+  '(steamclient steamutils steamuser steamfriends))
 
 (defun steamworks (&optional container)
   (if container
@@ -70,6 +70,9 @@
 (defmethod interface ((name symbol) (steamworks steamworks))
   (gethash name (interfaces steamworks)))
 
+(defmethod interface (name (steamworks (eql T)))
+  (interface name (steamworks)))
+
 (defmethod list-interfaces ((steamworks steamworks))
   (alexandria:hash-table-values (interfaces steamworks)))
 

toolkit.lisp

@@ -20,9 +20,18 @@
     (dotimes (i (* count (cffi:foreign-type-size type)) ptr)
       (setf (cffi:mem-aref ptr :uchar i) 0))))
 
+(defun warn* (datum &rest args)
+  (let ((condition (etypecase datum
+                     (string (make-condition 'simple-warning :format-control datum :format-arguments args))
+                     (symbol (apply #'make-condition 'datum args))
+                     (condition datum))))
+    (format *error-output* "~&WARNING: ~a~%" condition)
+    (warn condition)))
+
 ;; This fucking sucks man
 (defun foreign-type-p (type)
-  (not (null (ignore-errors (cffi:foreign-type-size type)))))
+  (handler-bind ((warning #'muffle-warning))
+    (not (null (ignore-errors (cffi:foreign-type-size type))))))
 
 (defun maybe-load-low-level (&optional file)
   (let ((file (or file (make-pathname :name "low-level" :type "lisp" :defaults steam::*this*))))