Skip to content

Instantly share code, notes, and snippets.

@mishoo
Last active August 31, 2023 07:14
Show Gist options
  • Save mishoo/40ab584d0fa0d011ea3a4ca7cd1cde34 to your computer and use it in GitHub Desktop.
Save mishoo/40ab584d0fa0d011ea3a4ca7cd1cde34 to your computer and use it in GitHub Desktop.
Get image dimensions by parsing file headers
(defgeneric image-size (input)
(:method ((input pathname))
(with-open-file (input input :element-type 'unsigned-byte)
(image-size input)))
(:method ((input string))
(with-open-file (input input :element-type 'unsigned-byte)
(image-size input)))
(:method ((input stream))
(labels ((read-num (count &key pos little)
(when pos (file-position input pos))
(loop with num = 0
for i = 0 then (+ i 8)
for j = (* 8 (1- count)) then (- j 8)
repeat count
do (setf (ldb (byte 8 (if little i j)) num)
(read-byte input))
finally (return num)))
(pos (&optional pos)
(if pos
(file-position input pos)
(file-position input)))
(skip (count)
(pos (+ count (pos))))
(maybe-png ()
(ignore-errors
(file-position input 0)
(when (and (= #x89 (read-byte input))
(= #x50 (read-byte input))
(= #x4E (read-byte input))
(= #x47 (read-byte input))
(= #x0D (read-byte input))
(= #x0A (read-byte input))
(= #x1A (read-byte input))
(= #x0A (read-byte input)))
(list (read-num 4 :pos 16) (read-num 4 :pos 20)))))
(maybe-gif ()
(ignore-errors
(file-position input 0)
(when (and (= #x47 (read-byte input))
(= #x49 (read-byte input))
(= #x46 (read-byte input))
(= #x38 (read-byte input))
(let ((b (read-byte input)))
(or (= #x37 b)
(= #x39 b)))
(= #x61 (read-byte input)))
(list (read-num 2 :pos 6 :little t)
(read-num 2 :pos 8 :little t)))))
(tiff-orientation ()
;; TIFF starts with two bytes specifying the byte order
;; 0x4949 means little-endian.
(let* ((start-of-tiff (pos))
(le (= #x4949 (read-num 2))))
;; two bytes encoding the number 42 follow
(when (= 42 (read-num 2 :little le))
;; four bytes encoding the image file directory offset,
;; relative to start-of-tiff, so jump to that location.
(pos (+ start-of-tiff (read-num 4 :little le)))
;; two bytes count the number of directory entries
(let ((count-entries (read-num 2 :little le)))
(loop repeat count-entries
for pos = (pos)
for tag = (read-num 2 :little le)
for type = (read-num 2 :little le)
for count = (read-num 4 :little le)
for value = (read-num (case type
(1 1)
(3 2)
(otherwise 4))
:little le)
;; do (format t "~4,'0X ~D ~D ~8,'0X~%" tag type count value)
when (= tag #x0112)
do (return value)
do (pos (+ 12 pos)))))))
(maybe-jpeg ()
(let (width height orientation)
(ignore-errors
(file-position input 0)
(when (and (= #xFF (read-byte input))
(= #xD8 (read-byte input)))
(loop do
(unless (= #xFF (read-byte input))
(return))
(let* ((marker (read-byte input))
(index (pos))
(length (read-num 2)))
(case marker
((#xC0 #xC1 #xC2 #xC3 #xC5 #xC6 #xC7 #xC9 #xCA #xCB #xCD #xCE #xCF)
(skip 1)
(setf height (read-num 2)
width (read-num 2))
(return))
((#xE1)
(when (= #x45786966 (read-num 4)) ; Exif
(skip 2) ; two nulls
(setf orientation (tiff-orientation)))))
(pos (+ index length))))))
(when (and width height)
(if (and orientation (or (= 6 orientation)
(= 8 orientation)))
(list height width)
(list width height)))))
(maybe-webp ()
(ignore-errors
(file-position input 0)
(when (and (= #x52 (read-byte input)) ; R
(= #x49 (read-byte input)) ; I
(= #x46 (read-byte input)) ; F
(= #x46 (read-byte input)) ; F
(skip 4)
(= #x57 (read-byte input)) ; W
(= #x45 (read-byte input)) ; E
(= #x42 (read-byte input)) ; B
(= #x50 (read-byte input))) ; P
(let ((seq (make-array 4 :element-type 'unsigned-byte)))
(when (= (read-sequence seq input)
(length seq))
(let ((format (map 'string #'code-char seq)))
(when (string= format "VP8 ")
(return-from maybe-webp (list (read-num 2 :pos 26 :little t)
(read-num 2 :pos 28 :little t))))
(when (string= format "VP8X")
(return-from maybe-webp (list (1+ (read-num 3 :pos 24 :little t))
(1+ (read-num 3 :pos 27 :little t))))))))))))
(or (maybe-jpeg)
(maybe-png)
(maybe-gif)
(maybe-webp)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment