v4l2.lisp

   1 ;;;; Copyright 2009 Vitaly Mayatskikh <v.mayatskih@gmail.com>
   2 ;;;;
   3 ;;;; This file is a part of CL-Video4Linux2
   4 ;;;;
   5 ;;;; CL-Video4Linux2 is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; CL-Video4Linux2 is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (in-package :cl-v4l2)
  19
  20 (define-wrapper format ())
  21
  22 ;; hack uint32->int32
  23 (defun ioctl (fd req arg)
  24   ;; CFFI grovels C constants as int64, and that mangles V4L2 ioctl requests.
  25   ;; There was a need in a hack, which is commented out below. But current
  26   ;; IOLIB (0.7.1) handles mangled requests ok.
  27   ;;
  28   ;; (let ((req! (if (> req (ash 1 31))
  29   ;;                 (- req (ash 1 32))
  30   ;;                 req)))
  31     (isys:ioctl fd req arg))
  32
  33 (defun query-capabilities (fd)
  34   "Query for device capabilities."
  35   (let ((caps (make-instance 'capability)))
  36     (ioctl fd vidioc-querycap (capability-raw caps))
  37     caps))
  38
  39 (defun capable (caps cap)
  40   "Check if device supports given capability."
  41   (not (zerop (logand (capability-capabilities caps) cap))))
  42
  43 (defun get-stream-params (fd buf-type)
  44   "Get stream parameters."
  45   (let ((parms (make-instance 'streamparm :type buf-type)))
  46     (ioctl fd vidioc-g-parm (streamparm-raw parms))
  47     parms))
  48
  49 (defun get-tuner-params (fd idx)
  50   "Get tuner parameters."
  51   (let ((tuner (make-instance 'tuner :index idx)))
  52     (ioctl fd vidioc-g-tuner (tuner-raw tuner))
  53     tuner))
  54
  55 (defun get-input-params (fd idx)
  56   "Get input parameters."
  57   (let ((vidin (make-instance 'input :index idx)))
  58     (ioctl fd vidioc-enuminput (input-raw vidin))
  59     vidin))
  60
  61 (defun get-input-standard (fd idx)
  62   "Get input standard."
  63   (let ((std (make-instance 'standard :index idx)))
  64     (ioctl fd vidioc-enumstd (standard-raw std))
  65     std))
  66
  67 (defun get-format (fd idx)
  68   "Get pixel format."
  69   (let ((fmt (make-instance 'fmtdesc :index idx :type :buf-type-video-capture)))
  70     (ioctl fd vidioc-enum-fmt (fmtdesc-raw fmt))
  71     fmt))
  72
  73 (defun %device-info (caps)
  74   (cl:format nil "Driver: ~A~%Card: ~A~%Bus: ~A~%Version: ~A~%"
  75              (capability-driver caps)
  76              (capability-card caps)
  77              (capability-bus-info caps)
  78              (capability-version caps)))
  79
  80 (defun device-info (fd)
  81   "Get basic information about device."
  82   (let ((caps (query-capabilities fd)))
  83     (%device-info caps)))
  84
  85 (defun set-input (fd idx)
  86   "Set device input."
  87   (with-foreign-object (in :int)
  88     (setf (mem-ref in :int) idx)
  89     (ioctl fd vidioc-s-input in)))
  90
  91 (defun set-image-format (fd w h pixfmt)
  92   "Set dimensions and pixel format."
  93   (let ((format (make-instance 'format :type :buf-type-video-capture)))
  94     (with-slots (width height pixelformat field colorspace) (format-pix format)
  95       (setf width w
  96             height h
  97             pixelformat pixfmt
  98             field :field-any
  99             colorspace :colorspace-srgb))
 100     (ioctl fd vidioc-s-fmt (format-raw format))
 101     format))
 102
 103 (defun get-image-format (fd)
 104   "Get current format."
 105   (let ((format (make-instance 'format :type :buf-type-video-capture)))
 106     (ioctl fd vidioc-g-fmt (format-raw format))
 107     format))
 108
 109 (defun request-buffers (fd n map-type)
 110   "Request `n' buffers of type `map-type'."
 111   (with-foreign-object (req 'requestbuffers)
 112     (with-foreign-slots ((count type memory) req requestbuffers)
 113       (setf count n
 114             type :buf-type-video-capture
 115             memory map-type)
 116       (ioctl fd vidioc-reqbufs req)
 117       count)))
 118
 119 (defun query-buffer (fd n map-type)
 120   "Query buffer number `n' of type `map-type'."
 121   (let ((buf (make-instance 'buffer :index n
 122                             :type :buf-type-video-capture
 123                             :memory map-type)))
 124     (ioctl fd vidioc-querybuf (buffer-raw buf))
 125     buf))
 126
 127 (defun query-buffers (fd n map-type)
 128   "Query `n' buffers `n' of type `map-type'"
 129   (loop for buf from 0 below n
 130        collect (query-buffer fd buf map-type)))
 131
 132 (defun map-buffers (fd n)
 133   "Map `n' buffers into memory."
 134   (let* ((count (request-buffers fd n :memory-mmap))
 135          (buffers (query-buffers fd count :memory-mmap)))
 136     (loop for buf in buffers
 137        collect
 138          (with-slots (index length m) buf
 139            (list buf
 140             (isys:mmap (make-pointer 0) length isys:prot-read isys:map-shared fd
 141                        (buffer-union-offset m))
 142             length)))))
 143
 144 (defun unmap-buffers (buffers)
 145   "Unmap given buffers from memory."
 146   (loop for buf in buffers do
 147        (multiple-value-bind (buffer addr length)
 148            (values-list buf)
 149          (declare (ignore buffer))
 150          (isys:munmap addr length))))
 151
 152 (defun stream-action (fd req)
 153   (with-foreign-object (type 'buf-type 2) ;; 2 - hack to create `type' as pointer
 154     (setf (mem-ref type 'buf-type) :buf-type-video-capture)
 155     (ioctl fd req type)))
 156
 157 (defun stream-on (fd buffers)
 158   "Start video streaming."
 159   (loop for buffer in buffers do
 160        (ioctl fd vidioc-qbuf (buffer-raw (car buffer))))
 161   (stream-action fd vidioc-streamon))
 162
 163 (defun stream-off (fd)
 164   "Stop video streaming."
 165   (stream-action fd vidioc-streamoff))
 166
 167 (defun get-frame (fd)
 168   "Get next frame from device."
 169   (with-foreign-object (buf 'buffer)
 170     (with-foreign-slots ((index type memory) buf buffer)
 171       (setf type :buf-type-video-capture
 172             memory :memory-mmap)
 173       (ioctl fd vidioc-dqbuf buf)
 174       (convert-from-foreign index :uint32))))
 175
 176 (defun put-frame (fd n)
 177   "Return frame buffer back to driver."
 178   (with-foreign-object (buf 'buffer)
 179     (with-foreign-slots ((index type memory) buf buffer)
 180       (setf index n
 181             type :buf-type-video-capture
 182             memory :memory-mmap))
 183     (ioctl fd vidioc-qbuf buf))
 184   n)
 185
 186 (defun set-control (fd ctrl-id level)
 187   "Set control to given level. Level should be in range of 0.0-1.0."
 188   (with-foreign-object (query 'queryctrl)
 189     (with-foreign-slots ((id minimum maximum) query queryctrl)
 190       (setf id ctrl-id)
 191       (ioctl fd vidioc-queryctrl query)
 192       (with-foreign-object (control 'control)
 193         (with-foreign-slots ((id value) control control)
 194           (setf id ctrl-id
 195                 value (+ minimum (round (* level (- maximum minimum))))))
 196         (ioctl fd vidioc-s-ctrl control)))))
 197
 198 (defun get-control (fd ctrl-id)
 199   "Get control level (in range of 0.0-1.0)."
 200   (with-foreign-object (query 'queryctrl)
 201     (with-foreign-slots ((id minimum maximum) query queryctrl)
 202       (setf id ctrl-id)
 203       (ioctl fd vidioc-queryctrl query)
 204       (with-foreign-object (control 'control)
 205         (with-foreign-slots ((id value) control control)
 206           (setf id ctrl-id)
 207           (ioctl fd vidioc-g-ctrl control)
 208           (/ (- value minimum) (- maximum minimum)))))))