dan
/
cl-pack
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

- added . to pack and fixed a bug in X in pack 

- @ support in pack
- improvments on parser so that ! < > and repeaters are handled better in combination and parser understanding of ( ) groups
- Basic grouping support. Groups work, and work with repeaters, but not modifiers
- modifiers work over groups in pack and follow most local
- group modifiers work in unpack now too
- packing of strings now accepts a number and on the fly converts it to a string (proper)
- / template support in pack
This commit is contained in:
Dan Ballard 2009-08-10 10:00:45 -07:00
parent 99d017e8dd
commit 497ada9253
3 changed files with 411 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
CHANGES
View File

@ -1,13 +1,19 @@
0.2 2009-07 0.2 2009-07
- added support for signed numbers that mirrors perl's - added support for signed numbers that mirrors perl's
- fixed native endian selection bug - fixed native endian selection bug
- added w (BER: Binary Encoded Representation)
- added X (backup) in pack
- added support for <> modifiers - added support for <> modifiers
on native endian directives (sSiIlLqQdf) on native endian directives (sSiIlLqQdf)
they can be forced to big or small endian with < > modifiers they can be forced to big or small endian with < > modifiers
- added support for ! modifier - added support for ! modifier
on nNvV it turns them to signed integers on nNvV it turns them to signed integers
- added . and @ support to pack
- added full group support to pack and unpack
- fixed string types to accept numvers and cast them to strings on the fly (ala perl)
- added / template to pack
- more test cases to cover all this - added more test cases to cover all the new additions and bug fixes
- Setup a git repository at git.mindstab.net/git/cl-pack - Setup a git repository at git.mindstab.net/git/cl-pack
0.1.1 2009-07-04 0.1.1 2009-07-04

446
cl-pack.lisp
View File

@ -5,6 +5,7 @@
;;;; Purpose: CL-PACK code ;;;; Purpose: CL-PACK code
;;;; Author: Dan Ballard <http://mindstab.net> ;;;; Author: Dan Ballard <http://mindstab.net>
;;;; Created: May 2009 ;;;; Created: May 2009
;;;; Modified: August 2009
;;;; License: BSD ;;;; License: BSD
;;;; Description: CL-PACK supplies perl/php/ruby compatible ;;;; Description: CL-PACK supplies perl/php/ruby compatible
;;;; pack() and unpack() functions to allow ;;;; pack() and unpack() functions to allow
@ -52,6 +53,9 @@
;;;x null byte ;;;x null byte
;;;X Backup a byte ;;;X Backup a byte
;;;@ Null fill or truncate to absolute position specified by repeater
;;;. Null fill or truncate to absolute position specified by value/argument
;;;n unsighed short (16bit big endian) ;;;n unsighed short (16bit big endian)
;;;v unsigned short (16bit little endian) ;;;v unsigned short (16bit little endian)
;;;N unsigned long (32bit big endian) ;;;N unsigned long (32bit big endian)
@ -77,6 +81,9 @@
;;; > sSiIlLqQfd Force big endian ;;; > sSiIlLqQfd Force big endian
;;; < sSiIlLqQfd Force little endian ;;; < sSiIlLqQfd Force little endian
;;; ***** GROUPING *****
;;; () Example: (pack "(cc)3" 65 66 67 68 69 70) => "ABCDEF"
;;; Example: (unpack "(cc)3") "ABCDEF") => (65 66) (67 68) (69 70)
;;; **** NOTE ***** ;;; **** NOTE *****
@ -85,41 +92,16 @@
;;; N2 or NN ;;; N2 or NN
;;; because there is no endian safe handling of 64 bit quads ;;; because there is no endian safe handling of 64 bit quads
;;; specified ;;; specified
;;; in cl-pack you can also use q< , q> , Q< and Q>
;;; ************* TODO *************** ;;; ************* TODO ***************
;;;W unsigned char value, can be greater than 255 ; problms with unicode slime strings
;;;@ Null fill or truncate to absolute position, counted from the start of the innermost ()-group. ;;;@ Null fill or truncate to absolute position, counted from the start of the innermost ()-group.
;;;. Null fill or truncate to absolute position specified by value. ;;;. Null fill or truncate to absolute position specified by value.
;;;( Start of a ()-group.
;;; ;;;
;;;! MODIFIER, different uses in context ;;;! MODIFIER, different uses in context
;;; < > use host endian
;;; / template ;;; / template
;;; j A Perl internal signed integer value (IV).
;;; J A Perl internal unsigned integer value (UV).
;;;
;;; F A Perl internal floating point value (NV) in the native format
;;; D A long double-precision float in the native format.
;;; (Long doubles are available only if your system supports long
;;; double values _and_ if Perl has been compiled to support those.
;;; Causes a fatal error otherwise.)
;;;
;;; p A pointer to a null-terminated string.
;;; P A pointer to a structure (fixed-length string).
;;;
;;; u A uuencoded string.
;;; U A Unicode character number. Encodes to a character in character mode
;;; and UTF-8 (or UTF-EBCDIC in EBCDIC platforms) in byte mode.
;;;
;;; w A BER compressed integer (not an ASN.1 BER, see perlpacktut for
;;; details). Its bytes represent an unsigned integer in base 128,
;;; most significant digit first, with as few digits as possible. Bit
;;; eight (the high bit) is set on each byte except the last.
;;; ***************** CL-PACK ********************** ;;; ***************** CL-PACK **********************
@ -151,7 +133,7 @@
(defmacro inc-form () (defmacro inc-form ()
"create a subseq of form that skips the current syntax object" "create a subseq of form that skips the current syntax object"
`(setf new-form (subseq form (+ 1 mod-chars repeater-chars)))) `(setf new-form (subseq form offset)))
;;; **** Basic byte conversion stuff **** ;;; **** Basic byte conversion stuff ****
@ -236,9 +218,9 @@
;;; **** String data stuff **** ;;; **** String data stuff ****
(defmacro pack-string ((repeater repeater-star) star-body count-body else-body) (defmacro handle-string ((repeater repeater-star) star-body count-body else-body)
"macro for building string type bodies for case statements in pack()" "macro for building string type bodies for case statements in pack() or unpack()"
`(if ,repeater-star `(if ,repeater-star
(progn (progn
;(setf ,new-form (subseq ,new-form 2)) ;(setf ,new-form (subseq ,new-form 2))
(inc-form) (inc-form)
@ -251,6 +233,18 @@
(progn ,else-body)) ;; no repeater # (progn ,else-body)) ;; no repeater #
)) ))
(defmacro pack-string ((repeater repeater-star) star-body count-body else-body)
"macro for building string type bodies for case statements in pack()"
`(progn
(if (numberp item)
(setf item (format nil "~d" item)))
(handle-string (,repeater ,repeater-star) ,star-body ,count-body ,else-body)))
(defmacro unpack-string ((repeater repeater-star) star-body count-body else-body)
"macro for building string type bodies for case statements in unpack()"
`(handle-string (,repeater ,repeater-star) ,star-body ,count-body ,else-body))
(defun 8bits-to-byte (8bits &optional (byte-form (lambda (i) (byte 8 (- 7 i))))) (defun 8bits-to-byte (8bits &optional (byte-form (lambda (i) (byte 8 (- 7 i)))))
"turns a string of 8 or less bits into a byte "turns a string of 8 or less bits into a byte
byte-form specifies the packing order of bits into the byte, deaulting to decending order" byte-form specifies the packing order of bits into the byte, deaulting to decending order"
@ -357,6 +351,17 @@
(char form offset))) (char form offset)))
(defun find-matching-paren (str)
;; takes a string returns the offset of the closing parenthesis, return -1 on fail
(let ((depth 0))
(do ((i 0 (incf i)))
((or (< depth 0) (>= i (length str))) (if (< depth 0) (1- i) -1))
(if (char= (char str i) #\()
(incf depth)
(if (char= (char str i) #\))
(decf depth))))))
;;; The header of a function (pack or unpack) that parses a form as defined above ;;; The header of a function (pack or unpack) that parses a form as defined above
;;; parses form and generates variables ;;; parses form and generates variables
@ -364,59 +369,90 @@
;;; and then executes body ;;; and then executes body
(defmacro def-form-parser (fn-name (&rest extra-args) end-test final-item &rest body) (defmacro def-form-parser (fn-name (&rest extra-args) end-test final-item &rest body)
`(defun ,fn-name (form ,@extra-args) `(defun ,fn-name (form ,@extra-args)
;(format t "parser: form:'~a'~%" form)
;; if termination tests, return final item
(if (or (string= form "") ,end-test) (if (or (string= form "") ,end-test)
,final-item ,final-item
(let ((repeater-star nil))
;; try to get a number and how long it is from form
(multiple-value-bind (repeater repeater-chars)
(if (> (length form) 1)
(parse-integer (strtail form) :junk-allowed t)
(values 0 0))
(if (eql repeater nil)
(if (char= #\* (char form 1))
(progn
(setf repeater-star t)
(setf repeater 0)
(setf repeater-chars 1)) ; hack, new-form = form
(progn (setf repeater 0)
(setf repeater-chars 0))))
(let ((mod-! nil) ;; parsing variables and init
(mod-> nil) (let ((offset 1)
(mod-< nil) (inner-length 0)
(mod-chars 0)) (repeater-star nil)
(do ((next-char (+ 2 repeater-chars) (1+ next-char)) ; +2 init because the variables dont set till atfer all are proccessed (repeater 0)
(ch (next-char form (1+ repeater-chars)) (mod-! nil)
(next-char form next-char))) (mod-> nil)
(mod-< nil)
(/-pos 0))
((and (char/= ch #\!) (char/= ch #\<) (char/= ch #\>))) (if (char= #\( (char form 0))
(format t "char: ~a " ch) (progn
(incf mod-chars) (setf inner-length (find-matching-paren (strtail form)))
(case ch (if (= inner-length (- 1))
(#\! (setf mod-! t)) (error "cl-pack: Syntax error in 'form': unmatched bracket at '~a'~%" form)
(#\> (setf mod-> t)) (setf offset (+ 2 inner-length)))))
(#\< (setf mod-< t)))
;; parse repeaters and modifiers
(do ((str (subseq form offset) (subseq form offset))
(offset1 offset offset)
(offset2 0 offset1))
((= offset offset2))
;; try to get a number and how long it is from form
(multiple-value-bind (repeater-count repeater-chars)
(if (>= (length str) 1)
(parse-integer str :junk-allowed t)
(values 0 0))
(if (eql repeater-count nil)
;; no repeater #, check for other modifiers ( * ! < > )
(case (char str 0)
(#\! (progn (setf mod-! t) (incf offset)))
(#\> (progn (setf mod-> t) (incf offset)))
(#\< (progn (setf mod-< t) (incf offset)))
(#\* (progn (setf repeater-star t)(incf offset)))
(#\/ (progn
(setf /-pos offset)
;; a/N... we need offset to point to after N...
;; so we need to parse it so inc offset to after 'N'
(incf offset 2)
))
) )
(format t "VALUES: !~a >~a <~a #:~a~%" mod-! mod-> mod-< mod-chars)
(progn ; repeater-count == #
;; (format t "r:~a rc:~a~%" repeater repeater-chars) (if (> repeater-count 0) (setf repeater repeater-count))
(let ((new-form form)) (incf offset repeater-chars))
(inc-form) )))
(format t "form'~a' new-form:'~a'~%" form new-form)
(if (or repeater-star (> repeater 1)) (let ((new-form form))
(setf new-form (concatenate 'string (inc-form)
(string (char form 0))
(if repeater-star
"*"
(write-to-string (1- repeater)))
(subseq form (1+ repeater-chars)))))
(progn ,@body))))))))
(if (or repeater-star (> repeater 1))
(setf new-form (concatenate 'string
(subseq form 0 (if (> inner-length 0) (+ 2 inner-length) 1))
(if mod-! "!" "")
(if mod-> ">" "")
(if mod-< "<" "")
(if repeater-star
"*"
(write-to-string (1- repeater)))
(subseq form offset))))
(progn ,@body))))))
(defmacro gen-modifiers-list ()
`(list (if mod-> :mod->) (if mod-< :mod-<) (if mod-! :mod-!)))
(defmacro set-modifiers (modifiers)
`(loop for m in ,modifiers do
(case m
;; < > in modifiers are secondary to those already set in local form syntax
(:mod-> (if (not mod-<) (setf mod-> t)))
(:mod-< (if (not mod->) (setf mod-< t)))
(:mod-! (setf mod-! t)))))
;;; *********** The Main part *********** ;;; *********** The Main part ***********
@ -425,11 +461,15 @@
;;; pack ;;; pack
;;; perl compatile pack() function. ;;; perl compatile pack() function.
;;; form: is a string of characters corresponding to encodings of data ;;; form: is a string of characters corresponding to encodings of data
;;; rest: is the data to be 'packed' ;;; rest: the data to be 'packed'
;;; there are two ways of calling pack with arguments
;;; 1) reguarly with a series of arguments
;;; 2) with a single list of the arguments.
;;; Pack will remove each argument it uses destructively from this list
;;; returns: a string of 'packed' data ;;; returns: a string of 'packed' data
(def-form-parser pack (&rest rest) (def-form-parser pack (&rest rest)
;; extra end test
;; extra end test
(and (eql nil rest) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X)))) (and (eql nil rest) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X))))
;; result ;; result
@ -439,17 +479,46 @@
;;; BODY ;;; BODY
;; Extra optional keyed parameters
;; :result result is the result so far of the pack operation
;; :modifiers modifiers are global modifiers such as those set on a
;; grouping like: (ss)<
(let ((result (if (eql (first rest) :result) ; (format t "pack: form:'~a' rest:~a~%" form rest)
(let ((r (second rest)))
(setf rest (rest (rest rest))) (let ((result "")
r) (modifiers nil))
"")))
(if (and (eql nil rest) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X)))) ;; parse extra optional keyed parameters
(do ((end? nil)
(i 0))
((or end? (>= i (length rest))) )
(case (elt rest i)
(:result (progn
(setf result (second rest))
(setf rest (rest (rest rest)))))
(:modifiers (progn
(setf modifiers (second rest))
(set-modifiers (second rest))
(setf rest (rest (rest rest)))))
(otherwise (setf end? t))))
;; Instead of passing a series of arguments, you can call it with a destructable list of arguments
(let ((dlist-arg-style nil))
(if (and (>= 1 (length rest)) (listp (first rest)))
(progn
(setf dlist-arg-style t)
(setf rest (first rest))))
;; second end test (redundant a little, can we merge?
(if (and (or (eql nil rest) (equal '(nil) rest)) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X))))
result result
(progn (progn
(format t "~a ~a ~a~%" form result rest) ;; set up of required endian functions
(let ((bytes-to-string-fn #'bytes-to-string-rev) ; LITTLE ENDIAN (let ((bytes-to-string-fn #'bytes-to-string-rev) ; LITTLE ENDIAN
(item (first rest)) (item (first rest))
(new-rest (rest rest))) ; default rest for numbers (new-rest (rest rest))) ; default rest for numbers
@ -459,8 +528,35 @@
(if mod-< (if mod-<
(setf bytes-to-string-fn #'bytes-to-string-rev)) (setf bytes-to-string-fn #'bytes-to-string-rev))
;; pack case satement
(let ((new-result (let ((new-result
;; FORM of: sequence length / sequence items
(if (> /-pos 0)
(progn ;; length item / sequence item
(let ((sequence-type (char form (1+ /-pos)))
(rest-len (length rest))
(consumed-length 0)
(ret (pack (subseq form (1+ /-pos) offset ) :modifiers (gen-modifiers-list) rest)))
(setf consumed-length (- rest-len (if (eql nil (first rest)) 0 (length rest))))
;; if its a string determine consumed length differently
(if (member sequence-type '(#\a #\A #\Z #\b #\B #\h #\H))
(let ((item-length
(if (numberp item)
(length (format nil "~d" item))
(length item))))
(setf consumed-length
(if repeater-star
item-length
(min repeater item-length)))))
(inc-form)
(concatenate 'string (pack (subseq form 0 /-pos) consumed-length) ret)))
;; ALL other FORMS
(case (strhead form) (case (strhead form)
(#\n ;Unsigned Short 16bit Big Endian AB=AB (#\n ;Unsigned Short 16bit Big Endian AB=AB
(pack-int 2 :big)) (pack-int 2 :big))
@ -490,7 +586,7 @@
((#\s #\S) ;signed/unsigned short 16bit ((#\s #\S) ;signed/unsigned short 16bit
(pack-int 2 native-endian)) (pack-int 2 :native))
((#\l #\L) ;signed/unsigned short 32bit ((#\l #\L) ;signed/unsigned short 32bit
(pack-int 4 :native)) (pack-int 4 :native))
@ -561,31 +657,82 @@
(setf result (subseq result 0 (- (length result) (setf result (subseq result 0 (- (length result)
(min (length result) delta))))) (min (length result) delta)))))
(inc-form) (inc-form)
(setf new-rest rest)
"" ""
)) ))
(otherwise (progn ((#\. #\@)
;; . consume a numerical arg - null fill or truncate to that position
;; @ null fill or truncate to repeater specified position
(let ((position item)) ; .
(if (char= #\@ (strhead form))
(progn
(setf position repeater)
(setf new-rest rest)
(inc-form)))
(setf result (subseq result 0 (min (length result) position)))
(make-list (max 0 (- position (length result))) :initial-element #\null)
))
(#\( ; Grouping
(let ((ret
(pack (subseq form 1 (1+ inner-length)) :modifiers (gen-modifiers-list) rest)))
(setf new-rest rest) ; for dlist-style carry on
ret))
(otherwise (progn
(setf new-rest rest) ; didn't do anything, don't consume anything (setf new-rest rest) ; didn't do anything, don't consume anything
"")))) "")))))
) ;; let () ) ;; let ()
;; Concatenate current form and the result of recursive calls ;(format t "~a~%" new-result)
(format t "~a~%" new-result)
(apply #'pack (append (list new-form :result (concatenate 'string result new-result)) new-rest)))))))) ;; if using a descructable arg list
(if dlist-arg-style
(progn
(if (not (equal rest new-rest)) ; consumed an arg
(progn
;; so remove the arg from the arg list
(setf (car rest) (second rest))
(setf (cdr rest) (rest (rest rest)))))
;; regardless, continue using the dlist style
(setf new-rest (list rest))))
;; Recursion for the rest of pack
(apply #'pack (append (list new-form :result (concatenate 'string result new-result) :modifiers modifiers) new-rest)))))))))
;; macro for unpack.
;; cuts out and returns part of a string to be used for processing while setting
;; new-str to the remainder
(defmacro cut-str (str len new-str) (defmacro cut-str (str len new-str)
`(let ((ret (subseq ,str 0 ,len))) `(let ((ret (subseq ,str 0 ,len)))
(setf ,new-str (subseq ,str ,len)) (setf ,new-str (subseq ,str ,len))
(if consumed (incf consumed ,len))
ret)) ret))
;;; perl compatible unpack() function ;;; perl compatible unpack() function
;;; form: a string of characters corresonding to decodings ;;; form: a string of characters corresonding to decodings
;;; string: a string of binary data to be decoded ;;; string: a string of binary data to be decoded
;;; consumed: optional key parameter. If nil (default) nothing happens
;;; if an integer, ever byte consumed increments consumed
;;; and it is the last value return in the values list
;;; returns: the decoded data in specified format ;;; returns: the decoded data in specified format
(def-form-parser unpack (string) (def-form-parser unpack (string &key (consumed nil) (modifiers nil))
;; extra end test
(<= (length string) 0) (<= (length string) 0)
nil
;; final item
(if consumed
(values consumed nil)
nil)
(set-modifiers modifiers)
;; setting up of endian specific functions
(let ((string-to-bytes-fn #'string-to-bytes-rev) ; LITTLE ENDIAN (let ((string-to-bytes-fn #'string-to-bytes-rev) ; LITTLE ENDIAN
(new-str string)) (new-str string))
#+big-endian(setf string-to-bytes-fn #'string-to-bytes) #+big-endian(setf string-to-bytes-fn #'string-to-bytes)
@ -594,74 +741,85 @@
(if mod-< (if mod-<
(setf string-to-bytes-fn #'string-to-bytes-rev)) (setf string-to-bytes-fn #'string-to-bytes-rev))
;; pack case statement and recursive call to unpack
;; note: not tail optiomized :fix ?
(apply #'values (apply #'values
(remove nil (append (remove nil (append
(list
(case (strhead form)
(#\n (unpack-mod!-uint 2 :big)) ; unsigned short 16bit big endian
(#\N (unpack-mod!-uint 4 :big)) ; unsigned long 32bit big endian
(#\v (unpack-mod!-uint 2 :little)) ; unsigned short 16bit little endian
(#\V (unpack-mod!-uint 4 :little)) ; unsigned long 32bit little endian
(#\c (unpack-int 1 :big)) ; 1 byte signed character (list
(#\C (unpack-uint 1 :big)) ; 1 byte unsigned character (case (strhead form)
(#\s (unpack-int 2 :native)) ; 2 byte signed native endian (#\n (unpack-mod!-uint 2 :big)) ; unsigned short 16bit big endian
(#\S (unpack-uint 2 :native)) ; 2 byte signed native endian (#\N (unpack-mod!-uint 4 :big)) ; unsigned long 32bit big endian
(#\l (unpack-int 4 :native)) ; 4 byte signed native endan (#\v (unpack-mod!-uint 2 :little)) ; unsigned short 16bit little endian
(#\L (unpack-uint 4 :native)) ; 4 byte unsigned native endian (#\V (unpack-mod!-uint 4 :little)) ; unsigned long 32bit little endian
(#\q (unpack-int 8 :natice)) ; 8 byte signed native endian
(#\Q (unpack-uint 8 :native)) ; 8 byte unsigned native endian
(#\i (let ((int-size 4)) ; native signed int size and endian
#+long-integer(setf int-size 8)
(unpack-int int-size :native)))
(#\I (let ((int-size 4)) ; native unsigned int size and endian (#\c (unpack-int 1 :big)) ; 1 byte signed character
#+long-integer(setf int-size 8) (#\C (unpack-uint 1 :big)) ; 1 byte unsigned character
(unpack-int int-size :native))) (#\s (unpack-int 2 :native)) ; 2 byte signed native endian
(#\S (unpack-uint 2 :native)) ; 2 byte signed native endian
(#\l (unpack-int 4 :native)) ; 4 byte signed native endan
(#\L (unpack-uint 4 :native)) ; 4 byte unsigned native endian
(#\q (unpack-int 8 :natice)) ; 8 byte signed native endian
(#\Q (unpack-uint 8 :native)) ; 8 byte unsigned native endian
(#\i (let ((int-size 4)) ; native signed int size and endian
#+long-integer(setf int-size 8)
(unpack-int int-size :native)))
(#\w (ber-decode (cut-str string (ber-str-length string) new-str))) (#\I (let ((int-size 4)) ; native unsigned int size and endian
#+long-integer(setf int-size 8)
(unpack-int int-size :native)))
(#\e (ieee-floats:decode-float32 (string-to-bytes-rev (cut-str string 4 new-str) 4))) ; 4 byte floating point little endian (#\w (ber-decode (cut-str string (ber-str-length string) new-str)))
(#\E (ieee-floats:decode-float64 (string-to-bytes-rev (cut-str string 8 new-str) 8))) ; 8 byte floating point little endian
(#\g (ieee-floats:decode-float32 (string-to-bytes (cut-str string 4 new-str) 4))) ; 4 byte floating point big endian (#\e (ieee-floats:decode-float32 (string-to-bytes-rev (cut-str string 4 new-str) 4))) ; 4 byte floating point little endian
(#\G (ieee-floats:decode-float64 (string-to-bytes (cut-str string 8 new-str) 8))) ; 8 byte floating point big endian (#\E (ieee-floats:decode-float64 (string-to-bytes-rev (cut-str string 8 new-str) 8))) ; 8 byte floating point little endian
(#\f (ieee-floats:decode-float32 (funcall string-to-bytes-fn (cut-str string 4 new-str) 4))) ; 4 byte floating point native endian (#\g (ieee-floats:decode-float32 (string-to-bytes (cut-str string 4 new-str) 4))) ; 4 byte floating point big endian
(#\d (ieee-floats:decode-float64 (funcall string-to-bytes-fn (cut-str string 8 new-str) 8))) ; 8 byte floating point native endian (#\G (ieee-floats:decode-float64 (string-to-bytes (cut-str string 8 new-str) 8))) ; 8 byte floating point big endian
((#\a #\A #\Z) ; chatacter string with various paddings (#\f (ieee-floats:decode-float32 (funcall string-to-bytes-fn (cut-str string 4 new-str) 4))) ; 4 byte floating point native endian
(let ((special-chars (#\d (ieee-floats:decode-float64 (funcall string-to-bytes-fn (cut-str string 8 new-str) 8))) ; 8 byte floating point native endian
(if (char= #\A (strhead form))
(coerce '(#\null #\space) 'string) ((#\a #\A #\Z) ; chatacter string with various paddings
""))) (let ((special-chars
(if (char= #\A (strhead form))
(coerce '(#\null #\space) 'string)
"")))
(pack-string (repeater repeater-star) (unpack-string (repeater repeater-star)
(string-trim special-chars (cut-str string (length string) new-str)) (string-trim special-chars (cut-str string (length string) new-str))
(string-trim special-chars (cut-str string (min repeater (length string)) new-str)) (string-trim special-chars (cut-str string (min repeater (length string)) new-str))
(cut-str string 1 new-str)))) (cut-str string 1 new-str))))
((#\b #\B) ; bit string ((#\b #\B) ; bit string
(let ((bit-unpack-fn (if (char= (strhead form) #\b) #'byte-to-8bits-rev #'byte-to-8bits))) (let ((bit-unpack-fn (if (char= (strhead form) #\b) #'byte-to-8bits-rev #'byte-to-8bits)))
(pack-string (repeater repeater-star) (unpack-string (repeater repeater-star)
(bit-unpack (cut-str string (length string) new-str) bit-unpack-fn) (bit-unpack (cut-str string (length string) new-str) bit-unpack-fn)
(subseq (bit-unpack (cut-str string (min (ceiling (/ repeater 8)) (length string)) new-str) bit-unpack-fn) 0 (min repeater (* 8 (length string)))) (subseq (bit-unpack (cut-str string (min (ceiling (/ repeater 8)) (length string)) new-str) bit-unpack-fn) 0 (min repeater (* 8 (length string))))
(subseq (bit-unpack (cut-str string 1 new-str) bit-unpack-fn) 0 1)))) (subseq (bit-unpack (cut-str string 1 new-str) bit-unpack-fn) 0 1))))
((#\h #\H) ; hex string ((#\h #\H) ; hex string
(let ((hex-unpack-fn (if (char= (strhead form) #\h) #'byte-to-2hex-rev #'byte-to-2hex))) (let ((hex-unpack-fn (if (char= (strhead form) #\h) #'byte-to-2hex-rev #'byte-to-2hex)))
(pack-string (repeater repeater-star) (unpack-string (repeater repeater-star)
(hex-unpack (cut-str string (length string) new-str) hex-unpack-fn) (hex-unpack (cut-str string (length string) new-str) hex-unpack-fn)
(subseq (hex-unpack (cut-str string (min (ceiling (/ repeater 2)) (length string)) new-str) hex-unpack-fn) 0 (min repeater (* 2 (length string)))) (subseq (hex-unpack (cut-str string (min (ceiling (/ repeater 2)) (length string)) new-str) hex-unpack-fn) 0 (min repeater (* 2 (length string))))
(subseq (hex-unpack (cut-str string 1 new-str) hex-unpack-fn) 0 1)))) (subseq (hex-unpack (cut-str string 1 new-str) hex-unpack-fn) 0 1))))
(#\x ; null character (#\x ; null character
(cut-str string 1 new-str) (cut-str string 1 new-str)
nil) nil)
(otherwise nil) (#\( ; grouping ()
)) (let* ((ret (multiple-value-list (unpack (subseq form 1 (1+ inner-length)) string :consumed 0 :modifiers (gen-modifiers-list))))
(sub-cons (first (last ret))))
(cut-str string sub-cons new-str)
(nbutlast ret))
)
;; result of recursion (otherwise nil)
(multiple-value-list (unpack new-form new-str))) :from-end t :count 1)))) ))
;; result of recursion
(multiple-value-list (unpack new-form new-str :consumed consumed :modifiers modifiers))) :from-end t :count 1))))

144
tests.lisp
View File

@ -5,6 +5,7 @@
;;;; Purpose: Tests for CL-PACK ;;;; Purpose: Tests for CL-PACK
;;;; Author: Dan Ballard <http://mindstab.net> ;;;; Author: Dan Ballard <http://mindstab.net>
;;;; Created: May 2009 ;;;; Created: May 2009
;;;; Modified: August 2009
;;;; License: BSD ;;;; License: BSD
;;;; Description: CL-PACK supplies perl/php/ruby compatible ;;;; Description: CL-PACK supplies perl/php/ruby compatible
;;;; pack() and unpack() functions to allow ;;;; pack() and unpack() functions to allow
@ -16,17 +17,19 @@
(defpackage :cl-pack-test (defpackage :cl-pack-test
(:use #:common-lisp #:cl-pack) (:use #:common-lisp #:cl-pack)
(:export #:test)) (:export #:test #:test-silent))
(in-package :cl-pack-test) (in-package :cl-pack-test)
;;;; ***** Shamelessly ripped from Practical Common Lisp ***** ;;;; ***** Unit Test Framework shamelessly ripped from *****
;;;; Practical Common Lisp (and slightly modified)
(defmacro with-gensyms ((&rest names) &body body) (defmacro with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (gensym))) `(let ,(loop for n in names collect `(,n (gensym)))
,@body)) ,@body))
(defvar *test-name* nil) (defvar *test-name* nil)
(defvar *silent* nil)
(defmacro deftest (name parameters &body body) (defmacro deftest (name parameters &body body)
"Define a test function. Within a test function we can call "Define a test function. Within a test function we can call
@ -52,15 +55,15 @@
(incf ,total-count (if ,tot ,tot 1)) (incf ,total-count (if ,tot ,tot 1))
(incf ,pass-count (if ,pas ,pas (if ,res 1 0))) (incf ,pass-count (if ,pas ,pas (if ,res 1 0)))
(if (not ,res) (setf ,result nil)))) (if (not ,res) (setf ,result nil))))
(format t "~a ~d/~d passed~%" *test-name* ,pass-count ,total-count) (if (not *silent*) (format t "~a ~d/~d passed~%" *test-name* ,pass-count ,total-count))
(values ,result ,pass-count ,total-count)))) (values ,result ,pass-count ,total-count))))
(defun report-result (result form) (defun report-result (result form)
"Report the results of a single test case. Called by 'check'." "Report the results of a single test case. Called by 'check'."
(format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form) (if (not *silent*) (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form))
result) result)
;;;; ********************************************************** ;;;; ********************** Unit Tests ****************************
(deftest test () (deftest test ()
@ -76,7 +79,14 @@
(pack-form) (pack-form)
(unpack-form) (unpack-form)
(mod-!) (mod-!)
(mod-<>))) (mod-<>)
(grouping)
(pack-/)
))
(deftest test-silent ()
(let ((*silent* t))
(test)))
(defun gen-null-string (len) (defun gen-null-string (len)
(apply #'concatenate 'string (loop for i from 0 to (1- len) collecting (string #\null)))) (apply #'concatenate 'string (loop for i from 0 to (1- len) collecting (string #\null))))
@ -98,31 +108,36 @@
(deftest pack-combinations () (deftest pack-combinations ()
(check (check
(string= (pack "c2" #x41 #x42 #x43) "AB") ;; basic repeater (with extra data dropped) (string= (pack "c2" #x41 #x42 #x43) "AB") ; basic repeater (with extra data dropped)
(string= (pack "c*" #x41 #x42 #x43) "ABC") ;; basic * repeater (string= (pack "c*" #x41 #x42 #x43) "ABC") ; basic * repeater
(string= (pack "c3" #x41 #x42) "AB") ;; only use avail data -- ! should ERROR be raised? (string= (pack "c3" #x41 #x42) "AB") ; only use avail data -- ! should ERROR be raised?
(string= (pack "c2N" #x41 #x42 #x43444546) "ABCDEF") ;; pick up after repeater (string= (pack "c2N" #x41 #x42 #x43444546) "ABCDEF") ; pick up after repeater
(string= (pack "NX2" #x41424344) "AB") ;delete chars (string= (pack "NX2" #x41424344) "AB") ;delete chars
(string= (pack "c.c" 65 0 66 ) "B") ; truncate
(string= (pack "c.c" 65 2 66) (concatenate 'string "A" (string #\null) "B")) ; null pad
(string= (pack "c@0c" 65 66) "B") ;truncate
(string= (pack "c@2c" 65 66) (concatenate 'string "A" (string #\null) "B")) ; null pad
)) ))
(deftest pack-strings () (deftest pack-strings ()
(check (check
(string= (pack "a*" "Test String") "Test String") ;; * repeater with string data (string= (pack "a*" "Test String") "Test String") ; * repeater with string data
(string= (pack "a5" "1234") (concatenate 'string "1234" (string #\null))) ;; test null of 'a' (string= (pack "a5" "1234") (concatenate 'string "1234" (string #\null))) ; test null of 'a'
(string= (pack "A10" "Test") "Test ") ;; numeric repeater with string data and padding (string= (pack "a*" 65) "65") ; pack a string converting a number
(string= (pack "a*N" "String" #x41424344) "StringABCD") ;; pick up after string/* (string= (pack "A10" "Test") "Test ") ; numeric repeater with string data and padding
(string= (pack "A10V" "Test" #x41424344) "Test DCBA") ;; pick up after string/# (string= (pack "a*N" "String" #x41424344) "StringABCD") ; pick up after string/*
(string= (pack "c2xa*" #x41 #x42 "Test") (concatenate 'string "AB" (string #\null) "Test")) ;; non consuming 'x' plays nicely with others (string= (pack "A10V" "Test" #x41424344) "Test DCBA") ; pick up after string/#
(string= (pack "B*" "010000010100001001000011") "ABC") ;; binary string (string= (pack "c2xa*" #x41 #x42 "Test") (concatenate 'string "AB" (string #\null) "Test")) ; non consuming 'x' plays nicely with others
(string= (pack "B16" "010000010100001001000011") "AB") ;; binary string only consumes what's asked of it (string= (pack "B*" "010000010100001001000011") "ABC") ; binary string
(string= (pack "B*" "010000010100001") "AB") ;; AB string short a bit (string= (pack "B16" "010000010100001001000011") "AB") ; binary string only consumes what's asked of it
(string= (pack "b*" "100000101000010") "A!") ;; AB string short a bit (string= (pack "B*" "010000010100001") "AB") ; AB string short a bit
(string= (pack "H4" "414243") "AB") ;; basic hex string (ignoring extra chars) (string= (pack "b*" "100000101000010") "A!") ; AB string short a bit
(string= (pack "H*" "414") "A@") ;; padding right? (string= (pack "H4" "414243") "AB") ; basic hex string (ignoring extra chars)
(string= (pack "h*" "1424") "AB") ;; other byte ordering (string= (pack "H*" "414") "A@") ; padding right?
(string= (pack "Z*" "dan") (concatenate 'string "dan" (string #\null))) ;; null padded string * (string= (pack "h*" "1424") "AB") ; other byte ordering
(string= (pack "Z5" "dan") (concatenate 'string "dan" (string #\null) (string #\null))) ;; padding of Z (string= (pack "Z*" "dan") (concatenate 'string "dan" (string #\null))) ; null padded string *
(string= (pack "Z3" "dan") (concatenate 'string "da" (string #\null))) ;; proper ending in NULL for under length string (string= (pack "Z5" "dan") (concatenate 'string "dan" (string #\null) (string #\null))) ; padding of Z
(string= (pack "Z3" "dan") (concatenate 'string "da" (string #\null))) ; proper ending in NULL for under length string
)) ))
@ -142,31 +157,31 @@
(deftest unpack-combinations () (deftest unpack-combinations ()
(check (check
(equal (multiple-value-list (unpack "c2" "ABC")) '(#x41 #x42)) ;; basic repeater (with extra data dropped) (equal (multiple-value-list (unpack "c2" "ABC")) '(#x41 #x42)) ; basic repeater (with extra data dropped)
(equal (multiple-value-list (unpack "c*" "ABC")) '(#x41 #x42 #x43)) ;; basic * repeater (equal (multiple-value-list (unpack "c*" "ABC")) '(#x41 #x42 #x43)) ; basic * repeater
(equal (multiple-value-list (unpack "c3" "AB")) '(#x41 #x42)) ;; only use avail data -- ! should ERROR be raised? (equal (multiple-value-list (unpack "c3" "AB")) '(#x41 #x42)) ; only use avail data -- ! should ERROR be raised?
(equal (multiple-value-list (unpack "c2N" "ABCDEF")) '(#x41 #x42 #x43444546)) ;; pick up after repeater (equal (multiple-value-list (unpack "c2N" "ABCDEF")) '(#x41 #x42 #x43444546)) ; pick up after repeater
)) ))
(deftest unpack-strings () (deftest unpack-strings ()
(check (check
(string= (unpack "a*" "Test String") "Test String") ;; * repeater with string data (string= (unpack "a*" "Test String") "Test String") ; * repeater with string data
(string= (unpack "a5" (concatenate 'string "1234" (string #\null))) (concatenate 'string "1234" (string #\null))) ;; test null of 'a' (string= (unpack "a5" (concatenate 'string "1234" (string #\null))) (concatenate 'string "1234" (string #\null))) ; test null of 'a'
(string= (unpack "A10" "Test ") "Test");; numeric repeater with string data and padding (string= (unpack "A10" "Test ") "Test"); numeric repeater with string data and padding
(equal (multiple-value-list (unpack "A*N" "String ABCD ")) '("String ABCD")) ;; it doesn't pick up after string/* (equal (multiple-value-list (unpack "A*N" "String ABCD ")) '("String ABCD")) ; it doesn't pick up after string/*
(equal (multiple-value-list (unpack "A10V" "Test DCBA")) '("Test" #x41424344)) ;; pick up after string/# (equal (multiple-value-list (unpack "A10V" "Test DCBA")) '("Test" #x41424344)) ; pick up after string/#
(equal (multiple-value-list (unpack "c2xa*" (concatenate 'string "AB" (string #\null) "Test"))) '(#x41 #x42 "Test")) ;; non consuming 'x' plays nicely with others (equal (multiple-value-list (unpack "c2xa*" (concatenate 'string "AB" (string #\null) "Test"))) '(#x41 #x42 "Test")) ; non consuming 'x' plays nicely with others
(string= (unpack "B*" "ABC") "010000010100001001000011") ;; binary string (string= (unpack "B*" "ABC") "010000010100001001000011") ; binary string
(string= (unpack "B15" "ABC") "010000010100001") ;; binary string only consumes what's asked of it (string= (unpack "B15" "ABC") "010000010100001") ; binary string only consumes what's asked of it
(string= (unpack "b*" "AB") "1000001001000010") ;; other ordering (string= (unpack "b*" "AB") "1000001001000010") ; other ordering
(string= (unpack "B9" "A") "01000001") ;; Not enough data (string= (unpack "B9" "A") "01000001") ; Not enough data
(string= (unpack "H3" "AB") "414") ;; basic hex string (ignoring extra chars) (string= (unpack "H3" "AB") "414") ; basic hex string (ignoring extra chars)
(string= (unpack "H*" "A@") "4140") ;; padding right? (string= (unpack "H*" "A@") "4140") ; padding right?
(string= (unpack "h*" "AB") "1424") ;; other byte ordering (string= (unpack "h*" "AB") "1424") ; other byte ordering
(string= (unpack "H3" "A") "41") ;; not enough data (string= (unpack "H3" "A") "41") ; not enough data
(string= (unpack "Z*" (concatenate 'string "dan" (string #\null))) (concatenate 'string "dan" (string #\null))) ;; null padded string * (string= (unpack "Z*" (concatenate 'string "dan" (string #\null))) (concatenate 'string "dan" (string #\null))) ; null padded string *
)) ))
@ -205,10 +220,43 @@
(= (unpack "n!" (pack "n" -1)) -1) ; n! is signed (= (unpack "n!" (pack "n" -1)) -1) ; n! is signed
)) ))
;; Test both < > mod features and that they play nice with repeaters
(deftest mod-<> () (deftest mod-<> ()
(check (check
(string= (pack "l>" #x41424344) "ABCD") (string= (pack "l>" #x41424344 #x45464748) "ABCD")
(string= (pack "l<" #x41424344) "DCBA") (string= (pack "l<*" #x41424344 #x45464748) "DCBAHGFE")
(string= (pack "s<" #x4142) "BA") ; check s
(string= (pack "s>" #x4142) "AB") ; check s
(= (unpack "l<" (pack "V" #x41424344)) #x41424344) (= (unpack "l<" (pack "V" #x41424344)) #x41424344)
(= (unpack "l>" (pack "N" #x41424344)) #x41424344) (equal (multiple-value-list (unpack "l>2" (pack "N*" #x41424344 #x45464748))) '(#x41424344 #x45464748))
(= (unpack "s<" "AB") #x4241) ;test s
(= (unpack "s>" "AB") #x4142) ; test s
))
(deftest grouping ()
(check
(string= (pack "(ccx(cx)2)2" #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48)
(concatenate 'string "AB" (string #\null) "C" (string #\null) "D" (string #\null) "EF" (string #\null) "G" (string #\null) "H" (string #\null))) ; Complex nested grouping with non consuming elements
(string= (pack "(ccx(cx)2)2" #x41 #x42 #x43 #x44 #x45 #x46 #x47)
(concatenate 'string "AB" (string #\null) "C" (string #\null) "D" (string #\null) "EF" (string #\null) "G" (string #\null))) ; same as above except missing a data item
(equal (multiple-value-list (unpack "(cc(c)2)2" "ABCDEFGH"))
'((65 66 (67) (68)) (69 70 (71) (72)))) ;unpack complex nested group
(equal (multiple-value-list (unpack "(ccx(cx)2)2" "ABCDEFGHIJKLMNOP"))
'((65 66 (68) (70)) (72 73 (75) (77)))) ;unpack complex nested group with skips
(equal (multiple-value-list (unpack "(ccx(cx)2)2" "ABCDEFGH"))
'((65 66 (68) (70)) (72))) ;unpack complex nested group with skips missing elements
(string= (pack "(s(ss>s)<s)>" #x4142 #x4344 #x4546 #x4748 #x494a) "ABDCEFHGIJ") ; modifiers work over whole groups, and locality of modifier precidence
(equal (multiple-value-list (unpack "(s(ss>s)<s)>" "ABCDEFGHIJ"))
'((#x4142 (#x4443 #x4546 #x4847) #x494a)))
))
(deftest pack-/ ()
(check
(string= (pack "a/c3" 65 66) "2AB") ; basic pack (missing an element, into a string type
(string= (pack "n/c*" 65 66 67) (concatenate 'string (string #\null) (string (code-char 3)) "ABC")) ;basic pack into a number with a *
(string= (pack "a/a3" "ABC") "3ABC") ;string pack
(string= (pack "a/a*" "ABC") "3ABC") ;string pack with *
)) ))