Actualize example.

[cl-v4l2.git] / videodev2.lisp

(in-package :cl-v4l2)

;; Generate wrapper classes for all structures.
;; Slot access is overtaken via MOP. This allows to utilize usual `with-slots'
;; macro. This is slow, 'cause it uses hash lookup tables.
;;
;; Better access speed can be achieved using generated accessors
;; named like <class-name>-<slot-name>, e.g. `capability-driver'.

(defclass v4l2 (standard-class) ())

(defmethod validate-superclass ((obj v4l2) (obj1 standard-class)) t)

(defun class-slot-definition (class slot)
  (dolist (s (class-direct-slots class))
    (when (equal slot (slot-definition-name s))
      (return s))))

(defvar *v4l2-slot-readers* (make-hash-table :test 'equal))
(defvar *v4l2-slot-writers* (make-hash-table :test 'equal))

(defmethod slot-value-using-class ((class v4l2) inst slot)
  (if (string= (string-upcase (slot-definition-name slot)) "RAW")
      (call-next-method class inst)
      (funcall (gethash (cons (class-name class) (slot-definition-name slot))
                        *v4l2-slot-readers*)
               inst)))

(defmethod (setf slot-value-using-class) (new (class v4l2) inst slot)
  (if (string= (string-upcase (slot-definition-name slot)) "RAW")
      (call-next-method new class inst)
      (funcall (gethash (cons (class-name class) (slot-definition-name slot))
                        *v4l2-slot-writers*)
               new inst)))

(defmacro define-wrapper (class-and-type supers &optional slots)
  (destructuring-bind (class-name &optional (struct-type class-name))
      (cffi::ensure-list class-and-type)
    (let ((slots (or slots (cffi::foreign-slot-names struct-type)))
          (raw-accessor (cffi::format-symbol t "~A-RAW" class-name)))
      `(progn
         (defclass ,class-name ,supers
           (,@(loop for slot in slots collect
                   `(,slot))
            (raw :accessor ,raw-accessor))
           (: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
                `(defun ,slot-name (inst)
                   ,(if (or (eq slot-type :char) (eq slot-type :uchar))
                        `(convert-from-foreign
                          (foreign-slot-value (,raw-accessor inst) ',class-name ',slot) :string)
                        (if (cffi::aggregatep (cffi::parse-type slot-type))
                            `(make-instance ',slot-type
                                            :pointer (foreign-slot-value (,raw-accessor inst) ',class-name ',slot))
                            `(foreign-slot-value (,raw-accessor inst) ',class-name ',slot))))
              collect
                `(setf (gethash (cons ',class-name ',slot) *v4l2-slot-readers*)
                       (fdefinition ',slot-name))

              collect
                `(defun (setf ,slot-name) (new inst)
                   (setf (foreign-slot-value (,raw-accessor inst) ',class-name ',slot)
                         (convert-to-foreign new ',slot-type)))
              collect
                `(setf (gethash (cons ',class-name ',slot) *v4l2-slot-writers*)
                       (fdefinition '(setf ,slot-name))))

         (defmethod initialize-instance :after ((inst ,class-name) &key pointer)
           (let ((obj (or pointer (foreign-alloc ',class-name))))
             (setf (,raw-accessor inst) obj)
             (unless pointer
               (finalize inst (lambda ()
                                (cl:format t "finalize ~A~%" obj)
                                (foreign-free obj))))))
         ',class-name))))

(defmacro def-c-struct (name &rest args)
  "Define cffi struct and generate wrapper"
  `(progn
     (defcstruct ,name
       ,@args)
     (define-wrapper ,name ())))

(defmacro def-c-union (name &rest args)
  "Define cffi union and generate wrapper"
  `(progn
     (defcunion ,name
       ,@args)
     (define-wrapper ,name ())))

(def-c-struct capability
  (driver       :uchar :count 16)
  (card         :uchar :count 32)
  (bus-info     :uchar :count 32)
  (version      :uint32)
  (capabilities :uint32)
  (reserved     :uint32 :count 4))

(def-c-struct fract
  (numerator    :uint32)
  (denominator  :uint32))

(def-c-struct captureparm
  (capability   :uint32) ; Supported modes
  (capturemode  :uint32) ; Current mode
  (timeperframe fract)   ; Time per frame in .1us units
  (extendedmode :uint32) ; Driver-specific extensions
  (readbuffers  :uint32) ; # of buffers for read
  (reserved     :uint32 :count 4))

(def-c-struct outputparm
  (capability   :uint32) ; Supported modes
  (outputmode   :uint32) ; Current mode
  (timeperframe fract)   ; Time per frame in .1us units
  (extendedmode :uint32) ; Driver-specific extensions
  (writebuffers :uint32) ; # of buffers for write
  (reserved     :uint32 :count 4))

(def-c-union streamparm-union
  (capture      captureparm)
  (output       outputparm)
  (raw-data     :uchar :count 200))

(defcenum buf-type
  (:buf-type-video-capture 1)
  :buf-type-video-output
  :buf-type-video-overlay
  :buf-type-vbi-capture
  :buf-type-vbi-output
  :buf-type-sliced-vbi-capture
  :buf-type-sliced-vbi-output
  :buf-type-video-output-overlay)

(def-c-struct streamparm
  (type         buf-type)
  (parm         streamparm-union))

(defcenum tuner-type
  (:tuner-radio 1)
  :tuner-analog-tv
  :tuner-digital-tv)

(def-c-struct tuner
 (index         :uint32)
 (name          :uchar :count 32)
 (type          tuner-type)
 (capability    :uint32)
 (rangelow      :uint32)
 (rangehigh     :uint32)
 (rxsubchans    :uint32)
 (audmode       :uint32)
 (signal        :int32)
 (afc           :int32)
 (reserved      :uint32 :count 4))

(def-c-struct standard
 (index         :uint32)
 (id            :uint64)
 (name          :uchar :count 24)
 (frameperiod   fract)
 (framelines    :uint32)
 (reserved      :uint32 :count 4))

(def-c-struct input
  (index        :uint32)                ; Which input
  (name         :uchar :count 32)       ; Label
  (type         :uint32)                ; Type of input
  (audioset     :uint32)                ; Associated audios (bitfield)
  (tuner        :uint32)                ; Associated tuner
  (std          :uint64)
  (status       :uint32)
  (reserved     :uint32 :count 4))

;;
;;      F O R M A T   E N U M E R A T I O N
;;
(def-c-struct fmtdesc
 (index         :uint32)                ; Format number
 (type          buf-type)               ; buffer type
 (flags         :uint32)
 (description   :uchar :count 32)       ; Description string
 (pixelformat   :uint32)                ; Format fourcc
 (reserved      :uint32 :count 4))

;; Values for the 'type' field
(defconstant input-type-tuner 1)

(defconstant input-type-camera 2)

(defcenum field
  :field-any                            ; driver can choose from none
                                        ; top, bottom, interlaced
                                        ; depending on whatever it thinks
                                        ; is approximate ...
  :field-none                           ; this device has no fields ...
  :field-top                            ; top field only
  :field-bottom                         ; bottom field only
  :field-interlaced                     ; both fields interlaced
  :field-seq-tb                         ; both fields sequential into one
                                        ; buffer, top-bottom order
  :field-seq-bt                         ; same as above + bottom-top order
  :field-alternate                      ; both fields alternating into
                                        ; separate buffers
  :field-interlaced-tb                  ; both fields interlaced, top field
                                        ; first and the top field is
                                        ; transmitted first
  :field-interlaced-bt                  ; both fields interlaced, top field
                                        ; first and the bottom field is
                                        ; transmitted first
  )

(defcenum colorspace
  (:colorspace-smpte170m 1)             ; ITU-R 601 -- broadcast NTSC/PAL
  :colorspace_smpte240m                 ; 1125-Line (US) HDTV
  :colorspace-rec709                    ; HD and modern captures.
  ; broken BT878 extents (601, luma range 16-253 instead of 16-235)
  :colorspace-bt878
  ; These should be useful.  Assume 601 extents.
  :colorspace-470-system-m
  :colorspace-470-system-bg

  ; I know there will be cameras that send this.  So, this is
  ; unspecified chromaticities and full 0-255 on each of the
  ; Y'CbCr components
  :colorspace-jpeg

  ; For RGB colourspaces, this is probably a good start.
  :colorspace-srgb)

;;
;;       V I D E O   I M A G E   F O R M A T
;;
(def-c-struct pix-format
  (width        :uint32)
  (height       :uint32)
  (pixelformat  :uint32)
  (field        field)
  (bytesperline :uint32)        ; for padding, zero if unused
  (sizeimage    :uint32)
  (colorspace   colorspace)
  (priv         :uint32))       ; private data, depends on pixelformat

;;      Stream data format
;;

(def-c-struct timecode
  (type         :uint32)
  (flags        :uint32)
  (frames       :uchar)
  (seconds      :uchar)
  (minutes      :uchar)
  (hours        :uchar)
  (userbits     :uchar :count 4))

(defcenum memory
  (:memory-mmap 1)
  :memory-userptr
  :memory-overlay)
;;
;;      M E M O R Y - M A P P I N G   B U F F E R S
;;
(def-c-struct requestbuffers
  (count        :uint32)
  (type         buf-type)
  (memory       memory)
  (reserved     :uint32 :count 2))

(def-c-union buffer-union
  (offset       :uint32)
  (userptr      :ulong))

(def-c-struct buffer
  (index        :uint32)
  (type         buf-type)
  (bytesused    :uint32)
  (flags        :uint32)
  (field        field)
  (timestamp    timeval)
  (timecode     timecode)
  (sequence     :uint32)
  ; memory location
  (memory       memory)
  (m            buffer-union)
  (length       :uint32)
  (input        :uint32)
  (reserved     :uint32))

(defcenum ctrl-type
  (:ctrl-type-integer 1)
  :ctrl-type-boolean
  :ctrl-type-menu
  :ctrl-type-button
  :ctrl-type-integer64
  :ctrl-type-ctrl-class)

;;  Used in the VIDIOC_QUERYCTRL ioctl for querying controls
(def-c-struct queryctrl
  (id                   :uint32)
  (type                 ctrl-type)
  (name                 :uchar :count 32)
  (minimum              :int32)
  (maximum              :int32)
  (step                 :int32)
  (default-value        :int32)
  (flags                :uint32)
  (reserved             :uint32 :count 2))

(def-c-struct control
  (id           :uint32)
  (value        :int32))

(defcenum power-line-frequency
  :cid-power-line-frequency-disabled
  :cid-power-line-frequency-50hz
  :cid-power-line-frequency-60hz)

(defcenum colorfx
  :colorfx-none
  :colorfx-bw
  :colorfx-sepia)

(defcenum exposure-auto-type
  :exposure-auto
  :exposure-manual
  :exposure-shutter-priority
  :exposure-aperture-priority)