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 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 query-capabilities (fd)
  43   "Query for device capabilities."
  44   (let ((caps (make-instance 'capability)))
  45     (ioctl fd vidioc-querycap (capability-raw caps))
  46     caps))
  47
  48 (defun capable (caps cap)
  49   "Check if device supports given capability."
  50   (not (zerop (logand (capability-capabilities caps) cap))))
  51
  52 (defun get-stream-params (fd buf-type)
  53   "Get stream parameters."
  54   (let ((parms (make-instance 'streamparm)))
  55     (setf (streamparm-type parms) buf-type)
  56     (ioctl fd vidioc-g-parm (streamparm-raw parms))
  57     parms))
  58
  59 (defun get-tuner-params (fd idx)
  60   "Get tuner parameters."
  61   (let ((tuner (make-instance 'tuner)))
  62     (setf (tuner-index tuner) idx)
  63     (ioctl fd vidioc-g-tuner (tuner-raw tuner))
  64     tuner))
  65
  66 (defun get-input-params (fd idx)
  67   "Get input parameters."
  68   (let ((vidin (make-instance 'input)))
  69     (setf (input-index vidin) idx)
  70     (ioctl fd vidioc-enuminput (input-raw vidin))
  71     vidin))
  72
  73 (defun get-input-standard (fd idx)
  74   "Get input standard."
  75   (let ((std (make-instance 'standard)))
  76     (setf (standard-index std) idx)
  77     (ioctl fd vidioc-enumstd (standard-raw std))
  78     std))
  79
  80 (defun get-format (fd idx)
  81   "Get pixel format."
  82   (let ((fmt (make-instance 'fmtdesc)))
  83     (with-slots (index type) fmt
  84       (setf index idx
  85             type :buf-type-video-capture))
  86     (ioctl fd vidioc-enum-fmt (fmtdesc-raw fmt))
  87     fmt))
  88
  89 (defun %device-info (caps)
  90   (cl:format nil "Driver: ~A~%Card: ~A~%Bus: ~A~%Version: ~A~%"
  91              (capability-driver caps)
  92              (capability-card caps)
  93              (capability-bus-info caps)
  94              (capability-version caps)))
  95
  96 (defun device-info (fd)
  97   "Get basic information about device."
  98   (let ((caps (query-capabilities fd)))
  99     (%device-info caps)))
 100
 101 (defun set-input (fd idx)
 102   "Set device input."
 103   (with-foreign-object (in :int)
 104     (setf (mem-ref in :int) idx)
 105     (ioctl fd vidioc-s-input in)))
 106
 107 (defun set-image-format (fd w h pixfmt)
 108   "Set dimenstions and pixel format."
 109   (let ((format (make-instance 'format)))
 110     (with-slots (type pix) format
 111       (with-slots (width height pixelformat field colorspace) pix
 112         (setf type :buf-type-video-capture
 113               width w
 114               height h
 115               pixelformat pixfmt
 116               field :field-any
 117               colorspace :colorspace-srgb)))
 118     (ioctl fd vidioc-s-fmt (format-raw format))
 119     format))
 120
 121 (defun get-image-format (fd)
 122   "Get current format."
 123   (let ((format (make-instance 'format)))
 124     (setf (format-type format) :buf-type-video-capture)
 125     (ioctl fd vidioc-g-fmt (format-raw format))
 126     format))
 127
 128 (defun request-buffers (fd n map-type)
 129   "Request `n' buffers of type `map-type'."
 130   (with-foreign-object (req 'requestbuffers)
 131     (with-foreign-slots ((count type memory) req requestbuffers)
 132       (setf count n
 133             type :buf-type-video-capture
 134             memory map-type)
 135       (ioctl fd vidioc-reqbufs req)
 136       count)))
 137
 138 (defun query-buffer (fd n map-type)
 139   "Query buffer number `n' of type `map-type'"
 140   (let ((buf (make-instance 'buffer)))
 141     (with-slots (index type memory) buf
 142       (setf index n
 143             type :buf-type-video-capture
 144             memory map-type))
 145     (ioctl fd vidioc-querybuf (buffer-raw buf))
 146     buf))
 147
 148 (defun query-buffers (fd n map-type)
 149   "Query `n' buffers `n' of type `map-type'"
 150   (loop for buf from 0 below n
 151        collect (query-buffer fd buf map-type)))
 152
 153 (defun map-buffers (fd n)
 154   (let* ((count (request-buffers fd n :memory-mmap))
 155          (buffers (query-buffers fd count :memory-mmap)))
 156     (loop for buf in buffers
 157        collect
 158          (with-slots (index length m) buf
 159 ;          (cl:format t "map buffer ~D of length ~X~%" index length)
 160            (list buf
 161             (%sys-mmap (make-pointer 0) length prot-read map-shared fd
 162                        (buffer-union-offset m))
 163             length)))))
 164
 165 (defun unmap-buffers (buffers)
 166   (loop for buf in buffers do
 167        (multiple-value-bind (buffer addr length)
 168            (values-list buf)
 169          (declare (ignore buffer))
 170          (%sys-munmap addr length))))
 171
 172 (defun stream-action (fd req)
 173   (with-foreign-object (type 'buf-type 2) ;; 2 - hack to create `type' as pointer
 174     (setf (mem-ref type 'buf-type) :buf-type-video-capture)
 175     (ioctl fd req type)))
 176
 177 (defun stream-on (fd buffers)
 178   (loop for buffer in buffers do
 179        (ioctl fd vidioc-qbuf (buffer-raw (car buffer))))
 180   (stream-action fd vidioc-streamon))
 181
 182 (defun stream-off (fd)
 183   (stream-action fd vidioc-streamoff))
 184
 185 (defun get-frame (fd)
 186   (with-foreign-object (buf 'buffer)
 187     (with-foreign-slots ((index type memory) buf buffer)
 188       (setf type :buf-type-video-capture
 189             memory :memory-mmap)
 190       (ioctl fd vidioc-dqbuf buf)
 191       (convert-from-foreign index :uint32))))
 192
 193 (defun put-frame (fd n)
 194   (with-foreign-object (buf 'buffer)
 195     (with-foreign-slots ((index type memory) buf buffer)
 196       (setf index n
 197             type :buf-type-video-capture
 198             memory :memory-mmap))
 199     (ioctl fd vidioc-qbuf buf))
 200   n)
 201
 202 (defun set-control (fd ctrl-id level)
 203   (with-foreign-object (query 'queryctrl)
 204     (with-foreign-slots ((id minimum maximum) query queryctrl)
 205       (setf id ctrl-id)
 206       (ioctl fd vidioc-queryctrl query)
 207       (with-foreign-object (control 'control)
 208         (with-foreign-slots ((id value) control control)
 209           (setf id ctrl-id
 210                 value (+ minimum (round (* level (- maximum minimum))))))
 211         (ioctl fd vidioc-s-ctrl control)))))