From 64ef3fac3f5426cd4d6440b39ebc43dbd7318d8d Mon Sep 17 00:00:00 2001
From: Vitaly Mayatskikh <v.mayatskih@gmail.com>
Date: Mon, 17 Aug 2009 11:40:47 +0200
Subject: [PATCH] Override `slot-value' via MOP

slot-value and with-slots can be used now with all v4l2 classes.
A bit slow as for now, but works.
---
 cl-v4l2.asd    |  3 ++-
 package.lisp   |  6 ++++--
 v4l2.lisp      | 13 ++++++++-----
 videodev2.lisp | 32 +++++++++++++++++++++++++++-----
 4 files changed, 41 insertions(+), 13 deletions(-)

diff --git a/cl-v4l2.asd b/cl-v4l2.asd
index 4540239..adf89a0 100644
--- a/cl-v4l2.asd
+++ b/cl-v4l2.asd
@@ -18,7 +18,8 @@
 (cl:eval-when (:load-toplevel :execute)
   (asdf:operate 'asdf:load-op :cffi-grovel)
   (asdf:operate 'asdf:load-op :iolib.syscalls)
-  (asdf:operate 'asdf:load-op :trivial-garbage))
+  (asdf:operate 'asdf:load-op :trivial-garbage)
+  (asdf:operate 'asdf:load-op :closer-mop))
 
 (defpackage #:cl-v4l2-asd
   (:use :cl :asdf))
diff --git a/package.lisp b/package.lisp
index 60a55db..ee68684 100644
--- a/package.lisp
+++ b/package.lisp
@@ -17,7 +17,7 @@
 
 (defpackage #:cl-v4l2
   (:nicknames :v4l2)
-  (:use :cl :cffi :iolib.syscalls #:trivial-garbage)
+  (:use :cl :cffi :iolib.syscalls #:trivial-garbage #:closer-mop)
   (:export
    #:v4l2-query-capabilities
    #:v4l2-capable
@@ -160,4 +160,6 @@
    #:buf-flag-timecode
    #:buf-flag-input
    #:v4l2-input-type-tuner
-   #:v4l2-input-type-camera))
+   #:v4l2-input-type-camera
+   #:cid-brightness
+))
diff --git a/v4l2.lisp b/v4l2.lisp
index 35915c8..c29dcda 100644
--- a/v4l2.lisp
+++ b/v4l2.lisp
@@ -30,7 +30,9 @@
 
 (in-package :cl-v4l2)
 
+(define-wrapper v4l2-pix-format ())
 (define-wrapper v4l2-format ())
+(define-wrapper v4l2-buffer ())
 
 ;; hack uint32->int32
 (defun ioctl (fd req arg)
@@ -87,7 +89,7 @@
 (defun v4l2-get-format (fd idx)
   "Get pixel format."
   (let ((fmt (make-instance 'v4l2-fmtdesc)))
-    (with-wrapped-slots (index type) fmt v4l2-fmtdesc
+    (with-slots (index type) fmt
       (setf index idx
 	    type :buf-type-video-capture))
     (ioctl fd vidioc-enum-fmt (v4l2-fmtdesc-raw fmt))
@@ -114,8 +116,8 @@
 (defun v4l2-set-image-format (fd w h pixfmt)
   "Set dimenstions and pixel format."
   (let ((format (make-instance 'v4l2-format)))
-    (with-wrapped-slots (type pix) format v4l2-format
-      (with-wrapped-slots (width height pixelformat field colorspace) pix v4l2-pix-format
+    (with-slots (type pix) format
+      (with-slots (width height pixelformat field colorspace) pix
 	(setf type :buf-type-video-capture
 	      width w
 	      height h
@@ -145,7 +147,7 @@
 (defun v4l2-query-buffer (fd n map-type)
   "Query buffer number `n' of type `map-type'"
   (let ((buf (make-instance 'v4l2-buffer)))
-    (with-wrapped-slots (index type memory) buf v4l2-buffer
+    (with-slots (index type memory) buf
       (setf index n
 	    type :buf-type-video-capture
 	    memory map-type))
@@ -162,7 +164,8 @@
 	 (buffers (v4l2-query-buffers fd count :memory-mmap)))
     (loop for buf in buffers
        collect
-	 (with-wrapped-slots (length m) buf v4l2-buffer
+	 (with-slots (index length m) buf
+	   (format t "map buffer ~D of length ~X~%" index length)
 	   (list buf
 	    (%sys-mmap (make-pointer 0) length prot-read map-shared fd
 		       (v4l2-buffer-union-offset m))
diff --git a/videodev2.lisp b/videodev2.lisp
index 85097bc..9bc45a7 100644
--- a/videodev2.lisp
+++ b/videodev2.lisp
@@ -1,5 +1,9 @@
 (in-package :cl-v4l2)
 
+(defclass v4l2 (standard-class) ())
+
+(defmethod validate-superclass ((obj v4l2) (obj1 standard-class)) t)
+
 (defmacro define-wrapper (class-and-type supers &optional slots)
   (destructuring-bind (class-name &optional (struct-type class-name))
       (cffi::ensure-list class-and-type)
@@ -8,14 +12,14 @@
 	 (defclass ,class-name ,supers
 	   (,@(loop for slot in slots collect
 		   `(,slot))
-	    (raw :accessor ,(cffi::format-symbol t "~A-RAW" class-name))))
+	    (raw :accessor ,(cffi::format-symbol t "~A-RAW" class-name)))
+	   (:metaclass v4l2))
 
 	 ,@(loop for slot in slots
 	      for slot-name = (cffi::format-symbol t "~A-~A" class-name slot)
 	      for slot-type = (cffi::slot-type (cffi::get-slot-info class-name slot))
 	      collect
-		`(defmethod ,slot-name
-		     ((inst ,class-name))
+		`(defun ,slot-name (inst)
 		   ,(if (or (eq slot-type :char) (eq slot-type :uchar))
 			`(cffi:convert-from-foreign
 			  (cffi:foreign-slot-value (slot-value inst 'raw) ',class-name ',slot) :string)
@@ -24,12 +28,30 @@
 					    :pointer (cffi:foreign-slot-value (slot-value inst 'raw) ',class-name ',slot))
 			    `(cffi:foreign-slot-value (slot-value inst 'raw) ',class-name ',slot))))
 	      collect
-		`(defmethod (setf ,slot-name)
-		     (new (inst ,class-name))
+		`(defun (setf ,slot-name) (new inst)
 		   (let ((raw (slot-value inst 'raw)))
 		     (setf (cffi:foreign-slot-value raw ',class-name ',slot)
 			   (cffi:convert-to-foreign new ',slot-type)))))
 
+	 (defmethod slot-value-using-class ((class v4l2) inst slot)
+	   (if (string= (string-upcase (slot-definition-name slot)) "RAW")
+	       (call-next-method class inst)
+	       (funcall (symbol-function
+			 (cffi::format-symbol t "~A-~A"
+					      (class-name class)
+					      (slot-definition-name slot)))
+			inst)))
+
+	 (defmethod (setf slot-value-using-class) (new (class v4l2) inst slot)
+	   (let ((slot-name (string-upcase (slot-definition-name slot))))
+	     (if (string= slot-name "RAW")
+		 (call-next-method new class inst)
+		 (funcall (fdefinition
+			   (read-from-string (format nil "(SETF ~A-~A)"
+						     (class-name class)
+						     slot-name)))
+			  new inst))))
+
          (defmethod initialize-instance :after ((inst ,class-name) &key pointer)
 	   (let ((obj (or pointer (cffi:foreign-alloc ',class-name))))
 	     (setf (slot-value inst 'raw) obj)
-- 
2.11.4.GIT