v4l2.lisp

   1 ;;;; Copyright 2009 Vitaly Mayatskikh <v.mayatskih@gmail.com>
   2 ;;;;
   3 ;;;; This file is a part of CL-Video4Linux2
   4 ;;;;
   5 ;;;; Performance counters are special hardware registers available on most modern
   6 ;;;; CPUs. These registers count the number of certain types of hw events: such
   7 ;;;; as instructions executed, cachemisses suffered, or branches mis-predicted -
   8 ;;;; without slowing down the kernel or applications. These registers can also
   9 ;;;; trigger interrupts when a threshold number of events have passed - and can
  10 ;;;; thus be used to profile the code that runs on that CPU.
  11 ;;;;
  12 ;;;; The Linux Performance Counter subsystem provides an abstraction of these
  13 ;;;; hardware capabilities. It provides per task and per CPU counters, counter
  14 ;;;; groups, and it provides event capabilities on top of those.  It
  15 ;;;; provides "virtual" 64-bit counters, regardless of the width of the
  16 ;;;; underlying hardware counters.
  17 ;;;;
  18 ;;;; CL-Perfcounters is free software: you can redistribute it and/or modify
  19 ;;;; it under the terms of the GNU General Public License as published by
  20 ;;;; the Free Software Foundation, either version 3 of the License, or
  21 ;;;; (at your option) any later version.
  22 ;;;;
  23 ;;;; CL-Perfcounters is distributed in the hope that it will be useful,
  24 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  25 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  26 ;;;; GNU General Public License for more details.
  27 ;;;;
  28 ;;;; You should have received a copy of the GNU General Public License
  29 ;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  30
  31 (in-package :cl-v4l2)
  32
  33 (define-wrapper v4l2-format ())
  34
  35 ;; hack uint32->int32
  36 (defun ioctl (fd req arg)
  37   (let ((req! (if (> req (ash 1 31))
  38                   (- (- (ash 1 32) req))
  39                   req)))
  40     (%sys-ioctl fd req! arg)))
  41
  42 (defun v4l2-query-capabilities (fd)
  43   "Query for device capabilities."
  44   (let ((caps (make-instance 'v4l2-capability)))
  45     (ioctl fd vidioc-querycap (v4l2-capability-raw caps))
  46     caps))
  47
  48 (defun v4l2-capable (caps cap)
  49   "Check if device supports given capability."
  50   (not (zerop (logand (v4l2-capability-capabilities caps) cap))))
  51
  52 (defun v4l2-get-stream-params (fd buf-type)
  53   "Get stream parameters."
  54   (let ((parms (make-instance 'v4l2-streamparm)))
  55     (setf (v4l2-streamparm-type parms) buf-type)
  56     (ioctl fd vidioc-g-parm (v4l2-streamparm-raw parms))
  57     parms))
  58
  59 (defun v4l2-get-tuner-params (fd idx)
  60   "Get tuner parameters."
  61   (let ((tuner (make-instance 'v4l2-tuner)))
  62     (setf (v4l2-tuner-index tuner) idx)
  63     (ioctl fd vidioc-g-tuner (v4l2-tuner-raw tuner))
  64     tuner))
  65
  66 (defun v4l2-get-input-params (fd idx)
  67   "Get input parameters."
  68   (let ((vidin (make-instance 'v4l2-input)))
  69     (setf (v4l2-input-index vidin) idx)
  70     (ioctl fd vidioc-enuminput (v4l2-input-raw vidin))
  71     vidin))
  72
  73 (defun v4l2-get-input-standard (fd idx)
  74   "Get input standard."
  75   (let ((std (make-instance 'v4l2-standard)))
  76     (setf (v4l2-standard-index std) idx)
  77     (ioctl fd vidioc-enumstd (v4l2-standard-raw std))
  78     std))
  79
  80 (defmacro with-wrapped-slots (slots inst class-name &body body)
  81   `(with-accessors
  82          ,(loop for slot in slots collect
  83                `(,slot ,(cffi::format-symbol t "~A-~A" class-name slot)))
  84        ,inst
  85      ,@body))
  86
  87 (defun v4l2-get-format (fd idx)
  88   "Get pixel format."
  89   (let ((fmt (make-instance 'v4l2-fmtdesc)))
  90     (with-slots (index type) fmt
  91       (setf index idx
  92             type :buf-type-video-capture))
  93     (ioctl fd vidioc-enum-fmt (v4l2-fmtdesc-raw fmt))
  94     fmt))
  95
  96 (defun v4l2-%device-info (caps)
  97   (format nil "Driver: ~A~%Card: ~A~%Bus: ~A~%Version: ~A~%"
  98           (v4l2-capability-driver caps)
  99           (v4l2-capability-card caps)
 100           (v4l2-capability-bus-info caps)
 101           (v4l2-capability-version caps)))
 102
 103 (defun v4l2-device-info (fd)
 104   "Get basic information about device."
 105   (let ((caps (v4l2-query-capabilities fd)))
 106     (v4l2-%device-info caps)))
 107
 108 (defun v4l2-set-input (fd idx)
 109   "Set device input."
 110   (with-foreign-object (in :int)
 111     (setf (mem-ref in :int) idx)
 112     (ioctl fd vidioc-s-input in)))
 113
 114 (defun v4l2-set-image-format (fd w h pixfmt)
 115   "Set dimenstions and pixel format."
 116   (let ((format (make-instance 'v4l2-format)))
 117     (with-slots (type pix) format
 118       (with-slots (width height pixelformat field colorspace) pix
 119         (setf type :buf-type-video-capture
 120               width w
 121               height h
 122               pixelformat pixfmt
 123               field :field-any
 124               colorspace :colorspace-srgb)))
 125     (ioctl fd vidioc-s-fmt (v4l2-format-raw format))
 126     format))
 127
 128 (defun v4l2-get-image-format (fd)
 129   "Get current format."
 130   (let ((format (make-instance 'v4l2-format)))
 131     (setf (v4l2-format-type format) :buf-type-video-capture)
 132     (ioctl fd vidioc-g-fmt (v4l2-format-raw format))
 133     format))
 134
 135 (defun v4l2-request-buffers (fd n map-type)
 136   "Request `n' buffers of type `map-type'."
 137   (with-foreign-object (req 'v4l2-requestbuffers)
 138     (with-foreign-slots ((count type memory) req v4l2-requestbuffers)
 139       (setf count n
 140             type :buf-type-video-capture
 141             memory map-type)
 142       (ioctl fd vidioc-reqbufs req)
 143       count)))
 144
 145 (defun v4l2-query-buffer (fd n map-type)
 146   "Query buffer number `n' of type `map-type'"
 147   (let ((buf (make-instance 'v4l2-buffer)))
 148     (with-slots (index type memory) buf
 149       (setf index n
 150             type :buf-type-video-capture
 151             memory map-type))
 152     (ioctl fd vidioc-querybuf (v4l2-buffer-raw buf))
 153     buf))
 154
 155 (defun v4l2-query-buffers (fd n map-type)
 156   "Query `n' buffers `n' of type `map-type'"
 157   (loop for buf from 0 below n
 158        collect (v4l2-query-buffer fd buf map-type)))
 159
 160 (defun v4l2-map-buffers (fd n)
 161   (let* ((count (v4l2-request-buffers fd n :memory-mmap))
 162          (buffers (v4l2-query-buffers fd count :memory-mmap)))
 163     (loop for buf in buffers
 164        collect
 165          (with-slots (index length m) buf
 166            (format t "map buffer ~D of length ~X~%" index length)
 167            (list buf
 168             (%sys-mmap (make-pointer 0) length prot-read map-shared fd
 169                        (v4l2-buffer-union-offset m))
 170             length)))))
 171
 172 (defun v4l2-unmap-buffers (buffers)
 173   (loop for buf in buffers do
 174        (multiple-value-bind (buf addr length)
 175            (values-list buf)
 176          (%sys-munmap addr length))))
 177
 178 (defun v4l2-stream (fd req)
 179   (with-foreign-object (type 'v4l2-buf-type 2)
 180     (setf (mem-ref type 'v4l2-buf-type) :buf-type-video-capture)
 181     (ioctl fd req type)))
 182
 183 (defun v4l2-stream-on (fd buffers)
 184   (loop for buffer in buffers do
 185        (ioctl fd vidioc-qbuf (v4l2-buffer-raw (car buffer))))
 186   (v4l2-stream fd vidioc-streamon))
 187
 188 (defun v4l2-stream-off (fd)
 189   (v4l2-stream fd vidioc-streamoff))
 190
 191 (defun v4l2-get-frame (fd)
 192   (with-foreign-object (buf 'v4l2-buffer)
 193     (with-foreign-slots ((index type memory) buf v4l2-buffer)
 194       (setf type :buf-type-video-capture
 195             memory :memory-mmap)
 196       (ioctl fd vidioc-dqbuf buf)
 197       (convert-from-foreign index :uint32))))
 198
 199 (defun v4l2-put-frame (fd n)
 200   (with-foreign-object (buf 'v4l2-buffer)
 201     (with-foreign-slots ((index type memory) buf v4l2-buffer)
 202       (setf index n
 203             type :buf-type-video-capture
 204             memory :memory-mmap))
 205     (ioctl fd vidioc-qbuf buf))
 206   n)
 207
 208 (defun v4l2-set-control (fd ctrl-id level)
 209   (with-foreign-object (query 'v4l2-queryctrl)
 210     (with-foreign-slots ((id minimum maximum) query v4l2-queryctrl)
 211       (setf id ctrl-id)
 212       (ioctl fd vidioc-queryctrl query)
 213       (with-foreign-object (control 'v4l2-control)
 214         (with-foreign-slots ((id value) control v4l2-control)
 215           (setf id ctrl-id
 216                 value (+ minimum (round (* level (- maximum minimum))))))
 217         (ioctl fd vidioc-s-ctrl control)))))