1 ;;;; Copyright 2009 Vitaly Mayatskikh <v.mayatskih@gmail.com>
3 ;;;; This file is a part of CL-Video4Linux2
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.
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.
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/>.
20 (define-wrapper format
())
23 (defun ioctl (fd req arg
)
24 (let ((req! (if (> req
(ash 1 31))
27 (%sys-ioctl fd req
! arg
)))
29 (defun query-capabilities (fd)
30 "Query for device capabilities."
31 (let ((caps (make-instance 'capability
)))
32 (ioctl fd vidioc-querycap
(capability-raw caps
))
35 (defun capable (caps cap
)
36 "Check if device supports given capability."
37 (not (zerop (logand (capability-capabilities caps
) cap
))))
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
))
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
))
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
))
57 (defun get-input-standard (fd idx
)
59 (let ((std (make-instance 'standard
:index idx
)))
60 (ioctl fd vidioc-enumstd
(standard-raw std
))
63 (defun get-format (fd idx
)
65 (let ((fmt (make-instance 'fmtdesc
:index idx
:type
:buf-type-video-capture
)))
66 (ioctl fd vidioc-enum-fmt
(fmtdesc-raw fmt
))
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
)))
76 (defun device-info (fd)
77 "Get basic information about device."
78 (let ((caps (query-capabilities fd
)))
81 (defun set-input (fd idx
)
83 (with-foreign-object (in :int
)
84 (setf (mem-ref in
:int
) idx
)
85 (ioctl fd vidioc-s-input in
)))
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
)
95 colorspace
:colorspace-srgb
))
96 (ioctl fd vidioc-s-fmt
(format-raw format
))
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
))
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
)
110 type
:buf-type-video-capture
112 (ioctl fd vidioc-reqbufs req
)
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
120 (ioctl fd vidioc-querybuf
(buffer-raw buf
))
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
)))
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
134 (with-slots (index length m
) buf
136 (%sys-mmap
(make-pointer 0) length prot-read map-shared fd
137 (buffer-union-offset m
))
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
)
145 (declare (ignore buffer
))
146 (%sys-munmap addr length
))))
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
)))
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
))
159 (defun stream-off (fd)
160 "Stop video streaming."
161 (stream-action fd vidioc-streamoff
))
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
169 (ioctl fd vidioc-dqbuf buf
)
170 (convert-from-foreign index
:uint32
))))
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
)
177 type
:buf-type-video-capture
178 memory
:memory-mmap
))
179 (ioctl fd vidioc-qbuf buf
))
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
)
187 (ioctl fd vidioc-queryctrl query
)
188 (with-foreign-object (control 'control
)
189 (with-foreign-slots ((id value
) control control
)
191 value
(+ minimum
(round (* level
(- maximum minimum
))))))
192 (ioctl fd vidioc-s-ctrl control
)))))
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
)
199 (ioctl fd vidioc-queryctrl query
)
200 (with-foreign-object (control 'control
)
201 (with-foreign-slots ((id value
) control control
)
203 (ioctl fd vidioc-g-ctrl control
)
204 (/ (- value minimum
) (- maximum minimum
)))))))