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