New example.
[cl-v4l2.git] / v4l2.lisp
blobc706b0831e4b1676e73cc1523fde428e08892177
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/>.
31 (in-package :cl-v4l2)
33 (define-wrapper format ())
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)))
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))
48 (defun capable (caps cap)
49 "Check if device supports given capability."
50 (not (zerop (logand (capability-capabilities caps) cap))))
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))
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))
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))
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))
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))
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)))
96 (defun device-info (fd)
97 "Get basic information about device."
98 (let ((caps (query-capabilities fd)))
99 (%device-info caps)))
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)))
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))
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))
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)))
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))
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)))
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)))))
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))))
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)))
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))
182 (defun stream-off (fd)
183 (stream-action fd vidioc-streamoff))
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))))
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))
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)))))