Skip to content
Newer
Older
100644 103 lines (93 sloc) 4.91 KB
dcb3cf2 @Ramarren Identify header.
authored
1 (in-package :png-read)
2
5adfedf @Ramarren Add some error handling, add filename to png-state.
authored
3 (defvar *png-file* nil)
5ae29ad @Ramarren Add more noticable crc failure handling.
authored
4 (defvar *crc-fail-behaviour* :error)
5
6 (define-condition crc-failure (warning)
7 ((file :initarg :file :reader file-of)
8 (crc-is :initarg :crc-is :reader crc-is-of)
9 (crc-read :initarg :crc-read :reader crc-read-of))
10 (:report (lambda (c stream)
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
11 (if (file-of c)
12 (format stream "Checksum failure in file ~a. Computed: #x~x, read: #x~x."
13 (file-of c) (crc-is-of c) (crc-read-of c))
14 (format stream "Checksum failure in datastream. Computed: #x~x, read: #x~x."
15 (crc-is-of c) (crc-read-of c))))))
5adfedf @Ramarren Add some error handling, add filename to png-state.
authored
16
dcb3cf2 @Ramarren Identify header.
authored
17 (defun read-png-file (file)
5adfedf @Ramarren Add some error handling, add filename to png-state.
authored
18 (let ((*png-file* file))
19 (with-open-file (png-stream file :direction :input :element-type '(unsigned-byte 8))
20 (read-png-datastream png-stream))))
dcb3cf2 @Ramarren Identify header.
authored
21
22 (defvar *png-header* #(137 80 78 71 13 10 26 10))
23
24 (defun read-png-datastream (png-stream)
25 (let ((header (make-array (length *png-header*) :element-type '(unsigned-byte 8))))
26 (read-sequence header png-stream)
27 (cond
28 ((every #'eql *png-header* header)
29 (read-png-chunks png-stream))
5adfedf @Ramarren Add some error handling, add filename to png-state.
authored
30 (t (if *png-file*
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
31 (error "File ~a is not a PNG file." *png-file*)
32 (error "Not PNG datastream."))))))
8ffd462 @Ramarren Read chunks, identify their types and check crc.
authored
33
34 (defun big-endian-vector-to-integer (byte-vector)
35 (iter (for i from (1- (length byte-vector)) downto 0)
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
36 (for j from 0)
37 (summing (ash (aref byte-vector j) (* 8 i)))))
8ffd462 @Ramarren Read chunks, identify their types and check crc.
authored
38
7801489 @Ramarren Remove check-type and add compiler macro for big-endian-integer-from-…
authored
39 (define-compiler-macro big-endian-vector-to-integer (&whole form byte-vector-form)
40 (if (and (listp byte-vector-form)
41 (eql (car byte-vector-form) 'subseq))
42 (destructuring-bind (subseq seq start &optional (end nil)) byte-vector-form
43 (declare (ignore subseq))
44 (let ((seq-gensym (gensym "SEQ-"))
45 (start-gensym (gensym "START-"))
46 (end-gensym (gensym "END-")))
47 `(let ((,seq-gensym ,seq)
48 (,start-gensym ,start))
49 (let ((,end-gensym
50 ,(if end
51 end
81d0682 @Ramarren Fix typo
authored
52 `(length ,seq-gensym))))
7801489 @Ramarren Remove check-type and add compiler macro for big-endian-integer-from-…
authored
53 (iter (for i from (- ,end-gensym ,start-gensym 1) downto 0)
54 (for j from ,start-gensym)
55 (summing (ash (aref ,seq-gensym j) (* 8 i))))))))
56 form))
8ffd462 @Ramarren Read chunks, identify their types and check crc.
authored
57
58 (defun read-png-chunks (png-stream)
59 (let ((length-field (make-array 4 :element-type '(unsigned-byte 8)))
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
60 (type-field (make-array 4 :element-type '(unsigned-byte 8)))
61 (crc-field (make-array 4 :element-type '(unsigned-byte 8)))
62 (*png-state* (make-instance 'png-state)))
5adfedf @Ramarren Add some error handling, add filename to png-state.
authored
63 (if *png-file* (setf (png-file *png-state*) *png-file*))
8fddc2b @Ramarren Cleanup.
authored
64 (let ((crc-ok
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
65 (iter
66 (for read-status next (read-sequence length-field png-stream))
67 (for type-status next (read-sequence type-field png-stream))
68 (until (zerop read-status))
69 (assert (eql read-status 4))
70 (assert (eql type-status 4))
71 (let ((chunk-length (big-endian-vector-to-integer length-field))
72 (type-string (map 'string #'code-char type-field)))
73 (let ((chunk-data (make-array chunk-length :element-type '(unsigned-byte 8))))
74 (let ((data-status (read-sequence chunk-data png-stream)))
75 (assert (eql data-status chunk-length))
76 (let ((crc-status (read-sequence crc-field png-stream)))
77 (assert (eql crc-status 4))
78 (let ((read-crc (big-endian-vector-to-integer crc-field))
79 (computed-crc (finish-crc (updated-crc (start-crc type-field) chunk-data))))
80 (parse-chunk type-string chunk-data)
81 (unless (eql read-crc computed-crc)
82 (let ((condition (make-condition 'crc-failure
83 :file *png-file*
84 :crc-is computed-crc
85 :crc-read read-crc)))
86 (with-simple-restart (ignore-crc-failure "Ignore checksum failure.")
87 (ecase *crc-fail-behaviour*
88 (:error (error condition))
89 (:warn (warn condition ))
90 ((:no-action nil) nil)))))
91 (collect (eql read-crc computed-crc))))))))))
5adfedf @Ramarren Add some error handling, add filename to png-state.
authored
92 (unless (finished *png-state*)
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
93 (if (png-file *png-state*)
94 (error "No IEND chunk in file ~a." (png-file *png-state*))
95 (error "No IEND chunk in stream.")))
8fddc2b @Ramarren Cleanup.
authored
96 (values *png-state* (every #'identity crc-ok)))))
5a489dd @Ramarren Start implementing specific chunks.
authored
97
c2a9a34 @Ramarren Finish top level parse-chunk.
authored
98 (defun parse-chunk (chunk-type chunk-data)
99 (let ((criticalp (char= (char chunk-type 0) (char (string-upcase chunk-type :end 1) 0))))
100 (if criticalp
d3c4254 @Ramarren Untabify and whitespace-cleanup
authored
101 (parse-critical-chunk (intern chunk-type (find-package :png-read)) chunk-data)
102 (parse-ancillary-chunk (intern chunk-type (find-package :png-read)) chunk-data))))
Something went wrong with that request. Please try again.