1 ;;;; This file implements The MD5 Message-Digest Algorithm, as defined in
2 ;;;; RFC 1321 by R. Rivest, published April 1992.
4 ;;;; It was written by Pierre R. Mai, with copious input from the
5 ;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and
6 ;;;; has been placed into the public domain.
10 ;;;; While the implementation should work on all conforming Common
11 ;;;; Lisp implementations, it has only been optimized for CMU CL,
12 ;;;; where it achieved comparable performance to the standard md5sum
13 ;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc
16 ;;;; Since the implementation makes heavy use of arithmetic on
17 ;;;; (unsigned-byte 32) numbers, acceptable performance is likely only
18 ;;;; on CL implementations that support unboxed arithmetic on such
19 ;;;; numbers in some form. For other CL implementations a 16bit
20 ;;;; implementation of MD5 is probably more suitable.
22 ;;;; The code implements correct operation for files of unbounded size
23 ;;;; as is, at the cost of having to do a single generic integer
24 ;;;; addition for each call to update-md5-state. If you call
25 ;;;; update-md5-state frequently with little data, this can pose a
26 ;;;; performance problem. If you can live with a size restriction of
27 ;;;; 512 MB, then you can enable fast fixnum arithmetic by putting
28 ;;;; :md5-small-length onto *features* prior to compiling this file.
30 ;;;; This software is "as is", and has no warranty of any kind. The
31 ;;;; authors assume no responsibility for the consequences of any use
32 ;;;; of this software.
34 (defpackage :SB-MD5
(:use
:CL
)
36 ;; Low-Level types and functions
37 #:md5-regs
#:initial-md5-regs
#:md5regs-digest
38 #:update-md5-block
#:fill-block
#:fill-block-ub8
#:fill-block-char
39 ;; Mid-Level types and functions
40 #:md5-state
#:md5-state-p
#:make-md5-state
41 #:update-md5-state
#:finalize-md5-state
42 ;; High-Level functions on sequences, streams and files
43 #:md5sum-sequence
#:md5sum-stream
#:md5sum-file
))
48 (eval-when (:compile-toplevel
)
49 (defparameter *old-expansion-limit
* ext
:*inline-expansion-limit
*)
50 (setq ext
:*inline-expansion-limit
* (max ext
:*inline-expansion-limit
* 1000)))
53 (eval-when (:compile-toplevel
:execute
)
54 (defparameter *old-features
* *features
*)
55 (pushnew (c:backend-byte-order c
:*target-backend
*) *features
*))
58 (eval-when (:compile-toplevel
)
59 (defparameter *old-features
* *features
*)
60 (pushnew sb-c
:*backend-byte-order
* *features
*))
62 ;;; Section 2: Basic Datatypes
65 "Corresponds to the 32bit quantity word of the MD5 Spec"
68 (defmacro assemble-ub32
(a b c d
)
69 "Assemble an ub32 value from the given (unsigned-byte 8) values,
70 where a is the intended low-order byte and d the high-order byte."
71 `(the ub32
(logior (ash ,d
24) (ash ,c
16) (ash ,b
8) ,a
)))
73 ;;; Section 3.4: Auxilliary functions
75 (declaim (inline f g h i
)
76 (ftype (function (ub32 ub32 ub32
) ub32
) f g h i
))
79 (declare (type ub32 x y z
)
80 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
82 (kernel:32bit-logical-or
(kernel:32bit-logical-and x y
)
83 (kernel:32bit-logical-andc1 x z
))
85 (logior (logand x y
) (logandc1 x z
)))
88 (declare (type ub32 x y z
)
89 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
91 (kernel:32bit-logical-or
(kernel:32bit-logical-and x z
)
92 (kernel:32bit-logical-andc2 y z
))
94 (logior (logand x z
) (logandc2 y z
)))
97 (declare (type ub32 x y z
)
98 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
100 (kernel:32bit-logical-xor x
(kernel:32bit-logical-xor y z
))
105 (declare (type ub32 x y z
)
106 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
108 (kernel:32bit-logical-xor y
(kernel:32bit-logical-orc2 x z
))
110 (ldb (byte 32 0) (logxor y
(logorc2 x z
))))
112 (declaim (inline mod32
+)
113 (ftype (function (ub32 ub32
) ub32
) mod32
+))
115 (declare (type ub32 a b
) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
116 (ldb (byte 32 0) (+ a b
)))
119 (define-compiler-macro mod32
+ (a b
)
120 `(ext:truly-the ub32
(+ ,a
,b
)))
122 ;;; Dunno why we need this, but without it MOD32+ wasn't being
123 ;;; inlined. Oh well. -- CSR, 2003-09-14
125 (define-compiler-macro mod32
+ (a b
)
126 `(ldb (byte 32 0) (+ ,a
,b
)))
128 (declaim (inline rol32
)
129 (ftype (function (ub32 (unsigned-byte 5)) ub32
) rol32
))
131 (declare (type ub32 a
) (type (unsigned-byte 5) s
)
132 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
134 (kernel:32bit-logical-or
#+little-endian
(kernel:shift-towards-end a s
)
135 #+big-endian
(kernel:shift-towards-start a s
)
138 (sb-rotate-byte:rotate-byte s
(byte 32 0) a
)
140 (logior (ldb (byte 32 0) (ash a s
)) (ash a
(- s
32))))
142 ;;; Section 3.4: Table T
144 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
145 (defparameter *t
* (make-array 64 :element-type
'ub32
147 (loop for i from
1 to
64
151 (abs (sin (float i
0.0d0
)))))))))
153 ;;; Section 3.4: Helper Macro for single round definitions
155 (defmacro with-md5-round
((op block
) &rest clauses
)
156 (loop for
(a b c d k s i
) in clauses
158 `(setq ,a
(mod32+ ,b
(rol32 (mod32+ (mod32+ ,a
(,op
,b
,c
,d
))
159 (mod32+ (aref ,block
,k
)
164 (return `(progn ,@result
))))
166 ;;; Section 3.3: (Initial) MD5 Working Set
169 "The working state of the MD5 algorithm, which contains the 4 32-bit
170 registers A, B, C and D."
171 `(simple-array (unsigned-byte 32) (4)))
173 (defmacro md5-regs-a
(regs)
176 (defmacro md5-regs-b
(regs)
179 (defmacro md5-regs-c
(regs)
182 (defmacro md5-regs-d
(regs)
185 (defconstant +md5-magic-a
+ (assemble-ub32 #x01
#x23
#x45
#x67
)
186 "Initial value of Register A of the MD5 working state.")
187 (defconstant +md5-magic-b
+ (assemble-ub32 #x89
#xab
#xcd
#xef
)
188 "Initial value of Register B of the MD5 working state.")
189 (defconstant +md5-magic-c
+ (assemble-ub32 #xfe
#xdc
#xba
#x98
)
190 "Initial value of Register C of the MD5 working state.")
191 (defconstant +md5-magic-d
+ (assemble-ub32 #x76
#x54
#x32
#x10
)
192 "Initial value of Register D of the MD5 working state.")
194 (declaim (inline initial-md5-regs
))
195 (defun initial-md5-regs ()
196 "Create the initial working state of an MD5 run."
197 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
198 (let ((regs (make-array 4 :element-type
'(unsigned-byte 32))))
199 (declare (type md5-regs regs
))
200 (setf (md5-regs-a regs
) +md5-magic-a
+
201 (md5-regs-b regs
) +md5-magic-b
+
202 (md5-regs-c regs
) +md5-magic-c
+
203 (md5-regs-d regs
) +md5-magic-d
+)
206 ;;; Section 3.4: Operation on 16-Word Blocks
208 (defun update-md5-block (regs block
)
209 "This is the core part of the MD5 algorithm. It takes a complete 16
210 word block of input, and updates the working state in A, B, C, and D
212 (declare (type md5-regs regs
)
213 (type (simple-array ub32
(16)) block
)
214 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
215 (let ((a (md5-regs-a regs
)) (b (md5-regs-b regs
))
216 (c (md5-regs-c regs
)) (d (md5-regs-d regs
)))
217 (declare (type ub32 a b c d
))
219 (with-md5-round (f block
)
220 (A B C D
0 7 1)(D A B C
1 12 2)(C D A B
2 17 3)(B C D A
3 22 4)
221 (A B C D
4 7 5)(D A B C
5 12 6)(C D A B
6 17 7)(B C D A
7 22 8)
222 (A B C D
8 7 9)(D A B C
9 12 10)(C D A B
10 17 11)(B C D A
11 22 12)
223 (A B C D
12 7 13)(D A B C
13 12 14)(C D A B
14 17 15)(B C D A
15 22 16))
225 (with-md5-round (g block
)
226 (A B C D
1 5 17)(D A B C
6 9 18)(C D A B
11 14 19)(B C D A
0 20 20)
227 (A B C D
5 5 21)(D A B C
10 9 22)(C D A B
15 14 23)(B C D A
4 20 24)
228 (A B C D
9 5 25)(D A B C
14 9 26)(C D A B
3 14 27)(B C D A
8 20 28)
229 (A B C D
13 5 29)(D A B C
2 9 30)(C D A B
7 14 31)(B C D A
12 20 32))
231 (with-md5-round (h block
)
232 (A B C D
5 4 33)(D A B C
8 11 34)(C D A B
11 16 35)(B C D A
14 23 36)
233 (A B C D
1 4 37)(D A B C
4 11 38)(C D A B
7 16 39)(B C D A
10 23 40)
234 (A B C D
13 4 41)(D A B C
0 11 42)(C D A B
3 16 43)(B C D A
6 23 44)
235 (A B C D
9 4 45)(D A B C
12 11 46)(C D A B
15 16 47)(B C D A
2 23 48))
237 (with-md5-round (i block
)
238 (A B C D
0 6 49)(D A B C
7 10 50)(C D A B
14 15 51)(B C D A
5 21 52)
239 (A B C D
12 6 53)(D A B C
3 10 54)(C D A B
10 15 55)(B C D A
1 21 56)
240 (A B C D
8 6 57)(D A B C
15 10 58)(C D A B
6 15 59)(B C D A
13 21 60)
241 (A B C D
4 6 61)(D A B C
11 10 62)(C D A B
2 15 63)(B C D A
9 21 64))
243 (setf (md5-regs-a regs
) (mod32+ (md5-regs-a regs
) a
)
244 (md5-regs-b regs
) (mod32+ (md5-regs-b regs
) b
)
245 (md5-regs-c regs
) (mod32+ (md5-regs-c regs
) c
)
246 (md5-regs-d regs
) (mod32+ (md5-regs-d regs
) d
))
249 ;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks
251 (declaim (inline fill-block fill-block-ub8 fill-block-char
))
252 (defun fill-block (block buffer offset
)
253 "Convert a complete 64 byte input vector segment into the given 16
254 word MD5 block. This currently works on (unsigned-byte 8) and
255 character simple-arrays, via the functions `fill-block-ub8' and
256 `fill-block-char' respectively."
257 (declare (type (integer 0 #.
(- most-positive-fixnum
64)) offset
)
258 (type (simple-array ub32
(16)) block
)
259 (type (simple-array * (*)) buffer
)
260 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
262 ((simple-array (unsigned-byte 8) (*))
263 (fill-block-ub8 block buffer offset
))
265 (fill-block-char block buffer offset
))))
267 (defun fill-block-ub8 (block buffer offset
)
268 "Convert a complete 64 (unsigned-byte 8) input vector segment
269 starting from offset into the given 16 word MD5 block."
270 (declare (type (integer 0 #.
(- most-positive-fixnum
64)) offset
)
271 (type (simple-array ub32
(16)) block
)
272 (type (simple-array (unsigned-byte 8) (*)) buffer
)
273 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
274 #+(and :cmu
:little-endian
)
275 (kernel:bit-bash-copy
276 buffer
(+ (* vm
:vector-data-offset vm
:word-bits
) (* offset vm
:byte-bits
))
277 block
(* vm
:vector-data-offset vm
:word-bits
)
279 #+(and :sbcl
:little-endian
)
280 (sb-kernel:bit-bash-copy
281 buffer
(+ (* sb-vm
:vector-data-offset sb-vm
:n-word-bits
)
282 (* offset sb-vm
:n-byte-bits
))
283 block
(* sb-vm
:vector-data-offset sb-vm
:n-word-bits
)
284 (* 64 sb-vm
:n-byte-bits
))
285 #-
(or (and :sbcl
:little-endian
) (and :cmu
:little-endian
))
286 (loop for i of-type
(integer 0 16) from
0
287 for j of-type
(integer 0 #.most-positive-fixnum
)
288 from offset to
(+ offset
63) by
4
291 (assemble-ub32 (aref buffer j
)
292 (aref buffer
(+ j
1))
293 (aref buffer
(+ j
2))
294 (aref buffer
(+ j
3))))))
296 (defun fill-block-char (block buffer offset
)
297 "Convert a complete 64 character input string segment starting from
298 offset into the given 16 word MD5 block."
299 (declare (type (integer 0 #.
(- most-positive-fixnum
64)) offset
)
300 (type (simple-array ub32
(16)) block
)
301 (type simple-string buffer
)
302 (optimize (speed 3) (safety 0) (space 0) (debug 0)))
303 #+(and :cmu
:little-endian
)
304 (kernel:bit-bash-copy
305 buffer
(+ (* vm
:vector-data-offset vm
:word-bits
) (* offset vm
:byte-bits
))
306 block
(* vm
:vector-data-offset vm
:word-bits
)
308 #+(and :sbcl
:little-endian
)
309 (sb-kernel:bit-bash-copy
310 buffer
(+ (* sb-vm
:vector-data-offset sb-vm
:n-word-bits
)
311 (* offset sb-vm
:n-byte-bits
))
312 block
(* sb-vm
:vector-data-offset sb-vm
:n-word-bits
)
313 (* 64 sb-vm
:n-byte-bits
))
314 #-
(or (and :sbcl
:little-endian
) (and :cmu
:little-endian
))
315 (loop for i of-type
(integer 0 16) from
0
316 for j of-type
(integer 0 #.most-positive-fixnum
)
317 from offset to
(+ offset
63) by
4
320 (assemble-ub32 (char-code (schar buffer j
))
321 (char-code (schar buffer
(+ j
1)))
322 (char-code (schar buffer
(+ j
2)))
323 (char-code (schar buffer
(+ j
3)))))))
325 ;;; Section 3.5: Message Digest Output
327 (declaim (inline md5regs-digest
))
328 (defun md5regs-digest (regs)
329 "Create the final 16 byte message-digest from the MD5 working state
330 in regs. Returns a (simple-array (unsigned-byte 8) (16))."
331 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
332 (type md5-regs regs
))
333 (let ((result (make-array 16 :element-type
'(unsigned-byte 8))))
334 (declare (type (simple-array (unsigned-byte 8) (16)) result
))
335 (macrolet ((frob (reg offset
)
336 (let ((var (gensym)))
338 (declare (type ub32
,var
))
340 (aref result
,offset
) (ldb (byte 8 0) ,var
)
341 (aref result
,(+ offset
1)) (ldb (byte 8 8) ,var
)
342 (aref result
,(+ offset
2)) (ldb (byte 8 16) ,var
)
343 (aref result
,(+ offset
3)) (ldb (byte 8 24) ,var
))))))
344 (frob (md5-regs-a regs
) 0)
345 (frob (md5-regs-b regs
) 4)
346 (frob (md5-regs-c regs
) 8)
347 (frob (md5-regs-d regs
) 12))
350 ;;; Mid-Level Drivers
352 (defstruct (md5-state
353 (:constructor make-md5-state
())
355 (regs (initial-md5-regs) :type md5-regs
:read-only t
)
357 #-md5-small-length
(integer 0 *)
358 #+md5-small-length
(unsigned-byte 29))
359 (block (make-array 16 :element-type
'(unsigned-byte 32)) :read-only t
360 :type
(simple-array (unsigned-byte 32) (16)))
361 (buffer (make-array 64 :element-type
'(unsigned-byte 8)) :read-only t
362 :type
(simple-array (unsigned-byte 8) (64)))
363 (buffer-index 0 :type
(integer 0 63))
366 (declaim (inline copy-to-buffer
))
367 (defun copy-to-buffer (from from-offset count buffer buffer-offset
)
368 "Copy a partial segment from input vector from starting at
369 from-offset and copying count elements into the 64 byte buffer
370 starting at buffer-offset."
371 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
372 (type (unsigned-byte 29) from-offset
)
373 (type (integer 0 63) count buffer-offset
)
374 (type (simple-array * (*)) from
)
375 (type (simple-array (unsigned-byte 8) (64)) buffer
))
377 (kernel:bit-bash-copy
378 from
(+ (* vm
:vector-data-offset vm
:word-bits
) (* from-offset vm
:byte-bits
))
379 buffer
(+ (* vm
:vector-data-offset vm
:word-bits
)
380 (* buffer-offset vm
:byte-bits
))
381 (* count vm
:byte-bits
))
383 (sb-kernel:bit-bash-copy
384 from
(+ (* sb-vm
:vector-data-offset sb-vm
:n-word-bits
)
385 (* from-offset sb-vm
:n-byte-bits
))
386 buffer
(+ (* sb-vm
:vector-data-offset sb-vm
:n-word-bits
)
387 (* buffer-offset sb-vm
:n-byte-bits
))
388 (* count sb-vm
:n-byte-bits
))
392 (loop for buffer-index of-type
(integer 0 64) from buffer-offset
393 for from-index of-type fixnum from from-offset
394 below
(+ from-offset count
)
396 (setf (aref buffer buffer-index
)
397 (char-code (schar (the simple-string from
) from-index
)))))
398 ((simple-array (unsigned-byte 8) (*))
399 (loop for buffer-index of-type
(integer 0 64) from buffer-offset
400 for from-index of-type fixnum from from-offset
401 below
(+ from-offset count
)
403 (setf (aref buffer buffer-index
)
404 (aref (the (simple-array (unsigned-byte 8) (*)) from
)
407 (defun update-md5-state (state sequence
&key
(start 0) (end (length sequence
)))
408 "Update the given md5-state from sequence, which is either a
409 simple-string or a simple-array with element-type (unsigned-byte 8),
410 bounded by start and end, which must be numeric bounding-indices."
411 (declare (type md5-state state
)
412 (type (simple-array * (*)) sequence
)
413 (type fixnum start end
)
414 (optimize (speed 3) #+(or cmu sbcl
) (safety 0) (space 0) (debug 0))
416 (ext:optimize-interface
(safety 1) (debug 1)))
417 (let ((regs (md5-state-regs state
))
418 (block (md5-state-block state
))
419 (buffer (md5-state-buffer state
))
420 (buffer-index (md5-state-buffer-index state
))
421 (length (- end start
)))
422 (declare (type md5-regs regs
) (type fixnum length
)
423 (type (integer 0 63) buffer-index
)
424 (type (simple-array (unsigned-byte 32) (16)) block
)
425 (type (simple-array (unsigned-byte 8) (64)) buffer
))
427 (unless (zerop buffer-index
)
428 (let ((amount (min (- 64 buffer-index
) length
)))
429 (declare (type (integer 0 63) amount
))
430 (copy-to-buffer sequence start amount buffer buffer-index
)
431 (setq start
(the fixnum
(+ start amount
)))
433 (setf (md5-state-buffer-index state
) (+ buffer-index amount
))
434 (return-from update-md5-state state
)))
435 (fill-block-ub8 block buffer
0)
436 (update-md5-block regs block
))
437 ;; Handle main-part and new-rest
439 ((simple-array (unsigned-byte 8) (*))
441 (declare (type (simple-array (unsigned-byte 8) (*)) sequence
))
442 (loop for offset of-type
(unsigned-byte 29) from start below end by
64
443 until
(< (- end offset
) 64)
445 (fill-block-ub8 block sequence offset
)
446 (update-md5-block regs block
)
448 (let ((amount (- end offset
)))
449 (unless (zerop amount
)
450 (copy-to-buffer sequence offset amount buffer
0))
451 (setf (md5-state-buffer-index state
) amount
)))))
454 (declare (type simple-string sequence
))
455 (loop for offset of-type
(unsigned-byte 29) from start below end by
64
456 until
(< (- end offset
) 64)
458 (fill-block-char block sequence offset
)
459 (update-md5-block regs block
)
461 (let ((amount (- end offset
)))
462 (unless (zerop amount
)
463 (copy-to-buffer sequence offset amount buffer
0))
464 (setf (md5-state-buffer-index state
) amount
))))))
465 (setf (md5-state-amount state
)
466 #-md5-small-length
(+ (md5-state-amount state
) length
)
467 #+md5-small-length
(the (unsigned-byte 29)
468 (+ (md5-state-amount state
) length
)))
471 (defun finalize-md5-state (state)
472 "If the given md5-state has not already been finalized, finalize it,
473 by processing any remaining input in its buffer, with suitable padding
474 and appended bit-length, as specified by the MD5 standard.
476 The resulting MD5 message-digest is returned as an array of sixteen
477 (unsigned-byte 8) values. Calling `update-md5-state' after a call to
478 `finalize-md5-state' results in unspecified behaviour."
479 (declare (type md5-state state
)
480 (optimize (speed 3) #+(or cmu sbcl
) (safety 0) (space 0) (debug 0))
482 (ext:optimize-interface
(safety 1) (debug 1)))
483 (or (md5-state-finalized-p state
)
484 (let ((regs (md5-state-regs state
))
485 (block (md5-state-block state
))
486 (buffer (md5-state-buffer state
))
487 (buffer-index (md5-state-buffer-index state
))
488 (total-length (* 8 (md5-state-amount state
))))
489 (declare (type md5-regs regs
)
490 (type (integer 0 63) buffer-index
)
491 (type (simple-array ub32
(16)) block
)
492 (type (simple-array (unsigned-byte 8) (*)) buffer
))
493 ;; Add mandatory bit 1 padding
494 (setf (aref buffer buffer-index
) #x80
)
495 ;; Fill with 0 bit padding
496 (loop for index of-type
(integer 0 64)
497 from
(1+ buffer-index
) below
64
498 do
(setf (aref buffer index
) #x00
))
499 (fill-block-ub8 block buffer
0)
500 ;; Flush block first if length wouldn't fit
501 (when (>= buffer-index
56)
502 (update-md5-block regs block
)
503 ;; Create new fully 0 padded block
504 (loop for index of-type
(integer 0 16) from
0 below
16
505 do
(setf (aref block index
) #x00000000
)))
506 ;; Add 64bit message bit length
507 (setf (aref block
14) (ldb (byte 32 0) total-length
))
509 (setf (aref block
15) (ldb (byte 32 32) total-length
))
511 (update-md5-block regs block
)
512 ;; Done, remember digest for later calls
513 (setf (md5-state-finalized-p state
)
514 (md5regs-digest regs
)))))
516 ;;; High-Level Drivers
518 (defun md5sum-sequence (sequence &key
(start 0) end
)
519 "Calculate the MD5 message-digest of data in sequence. On CMU CL
520 this works for all sequences whose element-type is supported by the
521 underlying MD5 routines, on other implementations it only works for 1d
522 simple-arrays with such element types."
523 (declare (optimize (speed 3) (space 0) (debug 0))
524 (type vector sequence
) (type fixnum start
))
525 (let ((state (make-md5-state)))
526 (declare (type md5-state state
))
528 (lisp::with-array-data
((data sequence
) (real-start start
) (real-end end
))
529 (update-md5-state state data
:start real-start
:end real-end
))
531 (sb-kernel:with-array-data
((data sequence
) (real-start start
) (real-end end
))
532 (update-md5-state state data
:start real-start
:end real-end
))
534 (let ((real-end (or end
(length sequence
))))
535 (declare (type fixnum real-end
))
536 (update-md5-state state sequence
:start start
:end real-end
))
537 (finalize-md5-state state
)))
539 (defconstant +buffer-size
+ (* 128 1024)
540 "Size of internal buffer to use for md5sum-stream and md5sum-file
541 operations. This should be a multiple of 64, the MD5 block size.")
543 (deftype buffer-index
() `(integer 0 ,+buffer-size
+))
545 (defun md5sum-stream (stream)
546 "Calculate an MD5 message-digest of the contents of stream. Its
547 element-type has to be either (unsigned-byte 8) or character."
548 (declare (optimize (speed 3) (space 0) (debug 0)))
549 (let ((state (make-md5-state)))
550 (declare (type md5-state state
))
552 ((equal (stream-element-type stream
) '(unsigned-byte 8))
553 (let ((buffer (make-array +buffer-size
+
554 :element-type
'(unsigned-byte 8))))
555 (declare (type (simple-array (unsigned-byte 8) (#.
+buffer-size
+))
557 (loop for bytes of-type buffer-index
= (read-sequence buffer stream
)
558 do
(update-md5-state state buffer
:end bytes
)
559 until
(< bytes
+buffer-size
+)
561 (return (finalize-md5-state state
)))))
562 ((equal (stream-element-type stream
) 'character
)
563 (let ((buffer (make-string +buffer-size
+)))
564 (declare (type (simple-string #.
+buffer-size
+) buffer
))
565 (loop for bytes of-type buffer-index
= (read-sequence buffer stream
)
566 do
(update-md5-state state buffer
:end bytes
)
567 until
(< bytes
+buffer-size
+)
569 (return (finalize-md5-state state
)))))
571 (error "Unsupported stream element-type ~S for stream ~S."
572 (stream-element-type stream
) stream
)))))
574 (defun md5sum-file (pathname)
575 "Calculate the MD5 message-digest of the file specified by pathname."
576 (declare (optimize (speed 3) (space 0) (debug 0)))
577 (with-open-file (stream pathname
:element-type
'(unsigned-byte 8))
578 (md5sum-stream stream
)))
581 (eval-when (:compile-toplevel
:execute
)
582 (setq *features
* *old-features
*))
585 (eval-when (:compile-toplevel
)
586 (setq ext
:*inline-expansion-limit
* *old-expansion-limit
*))
589 (eval-when (:compile-toplevel
)
590 (setq *features
* *old-features
*))