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