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 ;; hack uint32->int32
  34 (defun ioctl (fd req arg)
  35   (let ((req! (if (> req (ash 1 31))
  36                   (- (- (ash 1 32) req))
  37                   req)))
  38     (%sys-ioctl fd req! arg)))
  39
  40 (defun make-ref (type)
  41   (let ((obj (tg:make-weak-pointer (cffi:foreign-alloc type))))
  42     (tg:finalize obj #'cffi:foreign-free)
  43     obj))
  44
  45 (defun ref (foreign)
  46   (tg:weak-pointer-value foreign))
  47
  48 (defun read-ref (foreign type)
  49   (cffi:mem-ref (ref foreign) type))
  50
  51 (defmacro with-ref ((name type) &body body)
  52   `(let ((,name (make-ref ,type)))
  53      ,@body))
  54
  55 (defmacro with-ref-slots ((args ptr type) &body body)
  56   `(with-foreign-slots (,args (ref ,ptr) ,type)
  57      ,@body))
  58
  59 (defmacro thef (type value)
  60   `(convert-from-foreign ,value ,type))
  61
  62 (defun v4l2-query-capabilities (fd)
  63   "Query for device capabilities."
  64   (with-ref (caps 'v4l2-capability)
  65     (ioctl fd vidioc-querycap (ref caps))
  66     caps))
  67
  68 (defun v4l2-capable (caps cap)
  69   "Check if device supports given capability."
  70   (with-ref-slots ((capabilities) caps v4l2-capability)
  71     (not (zerop (logand (thef :uint32 capabilities) cap)))))
  72
  73 (defun v4l2-get-stream-params (fd buf-type)
  74   "Get stream parameters."
  75   (with-ref (parms 'v4l2-streamparm)
  76     (with-ref-slots ((type) parms v4l2-streamparm)
  77       (setf type buf-type))
  78     (ioctl fd vidioc-get-parm (ref parms))
  79     parms))
  80
  81 (defun v4l2-get-tuner-params (fd idx)
  82   "Get tuner parameters."
  83   (with-ref (tuner 'v4l2-tuner)
  84     (with-ref-slots ((index) tuner v4l2-tuner)
  85       (setf index idx))
  86     (ioctl fd vidioc-get-tuner (ref tuner))
  87     tuner))
  88
  89 (defun v4l2-get-input-params (fd idx)
  90   "Get input parameters."
  91   (with-ref (vidin 'v4l2-input)
  92     (with-ref-slots ((index) vidin v4l2-input)
  93       (setf index idx))
  94     (ioctl fd vidioc-enuminput (ref vidin))
  95     vidin))
  96
  97 (defun v4l2-get-input-standard (fd idx)
  98   "Get input standard."
  99   (with-ref (std 'v4l2-standard)
 100     (with-ref-slots ((index) std v4l2-standard)
 101       (setf index idx))
 102     (ioctl fd vidioc-enumstd (ref std))
 103     std))
 104
 105 (defun v4l2-get-format (fd idx)
 106   "Get pixel format."
 107   (with-ref (fmt 'v4l2-fmtdesc)
 108     (with-ref-slots ((index type) fmt v4l2-fmtdesc)
 109       (setf index idx
 110             type :buf-type-video-capture))
 111     (ioctl fd vidioc-enum-fmt (ref fmt))
 112     fmt))
 113
 114 (defun v4l2-capability-driver (caps)
 115   (with-foreign-slots ((driver) caps v4l2-capability)
 116     (thef :string driver)))
 117
 118 (defun v4l2-capability-card (caps)
 119   (with-foreign-slots ((card) caps v4l2-capability)
 120     (thef :string card)))
 121
 122 (defun v4l2-capability-bus (caps)
 123   (with-foreign-slots ((bus-info) caps v4l2-capability)
 124     (thef :string bus-info)))
 125
 126 (defun v4l2-capability-version (caps)
 127   (with-foreign-slots ((version) caps v4l2-capability)
 128     (let ((v (thef :uint32 version)))
 129       (format nil "~D.~D.~D" (ldb (byte 8 16) v) (ldb (byte 8 8) v)
 130               (ldb (byte 0 8) v)))))
 131
 132 (defun v4l2-%device-info (caps)
 133   (let ((c (ref caps)))
 134     (format nil "Driver: ~A~%Card: ~A~%Bus: ~A~%Version: ~A~%"
 135             (v4l2-capability-driver c)
 136             (v4l2-capability-card c)
 137             (v4l2-capability-bus c)
 138             (v4l2-capability-version c))))
 139
 140 (defun v4l2-device-info (fd)
 141   "Get basic information about device."
 142   (let ((caps (v4l2-query-capabilities fd)))
 143     (v4l2-%device-info caps)))
 144
 145 (defun v4l2-set-input (fd idx)
 146   "Set device input."
 147   (with-foreign-object (in :int)
 148     (setf (mem-ref in :int) idx)
 149     (ioctl fd vidioc-set-input in)))
 150
 151 (defun v4l2-set-image-format (fd w h pixfmt)
 152   "Set dimenstions and pixel format."
 153   (with-ref (format 'v4l2-format)
 154     (with-ref-slots ((type pix) format v4l2-format)
 155       (with-foreign-slots ((width height pixelformat field) pix v4l2-pix-format)
 156         (setf type :buf-type-video-capture
 157               width w
 158               height h
 159               pixelformat pixfmt
 160               field :field-any)))
 161     (ioctl fd vidioc-set-fmt (ref format))
 162     format))
 163
 164 (defun v4l2-get-image-format (fd)
 165   "Get current format."
 166   (with-ref (format 'v4l2-format)
 167     (with-ref-slots ((type) format v4l2-format)
 168       (setf type :buf-type-video-capture))
 169     (ioctl fd vidioc-get-fmt (ref format))
 170     format))
 171
 172 (defun v4l2-request-buffers (fd n map-type)
 173   "Request `n' buffers of type `map-type'."
 174   (with-foreign-object (req 'v4l2-requestbuffers)
 175     (with-foreign-slots ((count type memory) req v4l2-requestbuffers)
 176       (setf count n
 177             type :buf-type-video-capture
 178             memory map-type)
 179       (ioctl fd vidioc-reqbufs req)
 180       count)))
 181
 182 (defun v4l2-query-buffer (fd n map-type)
 183   "Query buffer number `n' of type `map-type'"
 184   (with-ref (buf 'v4l2-buffer)
 185     (with-ref-slots ((index type memory) buf v4l2-buffer)
 186       (setf index n
 187             type :buf-type-video-capture
 188             memory map-type))
 189     (ioctl fd vidioc-querybuf (ref buf))
 190     buf))
 191
 192 (defun v4l2-query-buffers (fd n map-type)
 193   "Query `n' buffers `n' of type `map-type'"
 194   (loop for buf from 0 below n
 195        collect (v4l2-query-buffer fd buf map-type)))
 196
 197
 198 (defun v4l2-map-buffers (fd n)
 199   (let* ((count (v4l2-request-buffers fd n :memory-mmap))
 200          (buffers (v4l2-query-buffers fd count :memory-mmap)))
 201     (loop for buf in buffers
 202        collect
 203          (with-ref-slots ((length m) buf v4l2-buffer)
 204            (list buf
 205             (%sys-mmap (make-pointer 0) length prot-read map-shared fd
 206                        (foreign-slot-value m 'v4l2-buffer-union 'offset))
 207             length)))))
 208
 209 (defun v4l2-unmap-buffers (buffers)
 210   (loop for buf in buffers do
 211        (multiple-value-bind (buf addr length)
 212            (values-list buf)
 213          (%sys-munmap addr length))))
 214
 215 (defun v4l2-stream (fd req buffers)
 216   (multiple-value-bind (buf addr length)
 217       (values-list (car buffers))
 218     (ioctl fd req (foreign-slot-pointer (ref buf) 'v4l2-buffer 'type))))
 219
 220 (defun v4l2-stream-on (fd buffers)
 221   (loop for buffer in buffers do
 222        (ioctl fd vidioc-qbuf (ref (car buffer))))
 223   (v4l2-stream fd vidioc-stream-on buffers))
 224
 225 (defun v4l2-stream-off (fd buffers)
 226   (v4l2-stream fd vidioc-stream-off buffers))
 227
 228 (defun v4l2-get-frame (fd)
 229   (with-foreign-object (buf 'v4l2-buffer)
 230     (with-foreign-slots ((index type memory) buf v4l2-buffer)
 231       (setf type :buf-type-video-capture
 232             memory :memory-mmap)
 233       (ioctl fd vidioc-dqbuf buf)
 234       (thef :uint32 index))))
 235
 236 (defun v4l2-put-frame (fd n)
 237   (with-foreign-object (buf 'v4l2-buffer)
 238     (with-foreign-slots ((index type memory) buf v4l2-buffer)
 239       (setf index n
 240             type :buf-type-video-capture
 241             memory :memory-mmap))
 242     (ioctl fd vidioc-qbuf buf))
 243   n)