From 497ada925360e5d907947ff9e8d05e433f420264 Mon Sep 17 00:00:00 2001 From: Dan Ballard Date: Mon, 10 Aug 2009 10:00:45 -0700 Subject: [PATCH] - 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 --- CHANGES | 8 +- cl-pack.lisp | 458 ++++++++++++++++++++++++++++++++++----------------- tests.lisp | 144 ++++++++++------ 3 files changed, 411 insertions(+), 199 deletions(-) diff --git a/CHANGES b/CHANGES index 019962f..ff21315 100644 --- a/CHANGES +++ b/CHANGES @@ -1,13 +1,19 @@ 0.2 2009-07 - added support for signed numbers that mirrors perl's - fixed native endian selection bug + - added w (BER: Binary Encoded Representation) + - added X (backup) in pack - added support for <> modifiers on native endian directives (sSiIlLqQdf) they can be forced to big or small endian with < > modifiers - added support for ! modifier 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 0.1.1 2009-07-04 diff --git a/cl-pack.lisp b/cl-pack.lisp index 1e780d5..7ca206e 100644 --- a/cl-pack.lisp +++ b/cl-pack.lisp @@ -5,6 +5,7 @@ ;;;; Purpose: CL-PACK code ;;;; Author: Dan Ballard ;;;; Created: May 2009 +;;;; Modified: August 2009 ;;;; License: BSD ;;;; Description: CL-PACK supplies perl/php/ruby compatible ;;;; pack() and unpack() functions to allow @@ -52,6 +53,9 @@ ;;;x null 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) ;;;v unsigned short (16bit little endian) ;;;N unsigned long (32bit big endian) @@ -77,6 +81,9 @@ ;;; > sSiIlLqQfd Force big 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 ***** @@ -85,41 +92,16 @@ ;;; N2 or NN ;;; because there is no endian safe handling of 64 bit quads ;;; specified +;;; in cl-pack you can also use q< , q> , Q< and Q> ;;; ************* 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 specified by value. -;;;( Start of a ()-group. ;;; ;;;! MODIFIER, different uses in context -;;; < > use host endian ;;; / 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 ********************** @@ -151,7 +133,7 @@ (defmacro inc-form () "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 **** @@ -236,9 +218,9 @@ ;;; **** String data stuff **** -(defmacro pack-string ((repeater repeater-star) star-body count-body else-body) - "macro for building string type bodies for case statements in pack()" - `(if ,repeater-star +(defmacro handle-string ((repeater repeater-star) star-body count-body else-body) + "macro for building string type bodies for case statements in pack() or unpack()" + `(if ,repeater-star (progn ;(setf ,new-form (subseq ,new-form 2)) (inc-form) @@ -251,6 +233,18 @@ (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))))) "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" @@ -357,6 +351,17 @@ (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 ;;; parses form and generates variables @@ -364,59 +369,90 @@ ;;; and then executes body (defmacro def-form-parser (fn-name (&rest extra-args) end-test final-item &rest body) `(defun ,fn-name (form ,@extra-args) + ;(format t "parser: form:'~a'~%" form) + + ;; if termination tests, return final item (if (or (string= form "") ,end-test) ,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)))) + + ;; parsing variables and init + (let ((offset 1) + (inner-length 0) + (repeater-star nil) + (repeater 0) + (mod-! nil) + (mod-> nil) + (mod-< nil) + (/-pos 0)) - (let ((mod-! nil) - (mod-> nil) - (mod-< nil) - (mod-chars 0)) - (do ((next-char (+ 2 repeater-chars) (1+ next-char)) ; +2 init because the variables dont set till atfer all are proccessed - (ch (next-char form (1+ repeater-chars)) - (next-char form next-char))) - - ((and (char/= ch #\!) (char/= ch #\<) (char/= ch #\>))) - (format t "char: ~a " ch) - (incf mod-chars) - (case ch - (#\! (setf mod-! t)) - (#\> (setf mod-> t)) - (#\< (setf mod-< t))) + (if (char= #\( (char form 0)) + (progn + (setf inner-length (find-matching-paren (strtail form))) + (if (= inner-length (- 1)) + (error "cl-pack: Syntax error in 'form': unmatched bracket at '~a'~%" form) + (setf offset (+ 2 inner-length))))) + + ;; 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 == # + (if (> repeater-count 0) (setf repeater repeater-count)) + (incf offset repeater-chars)) + ))) - ;; (format t "r:~a rc:~a~%" repeater repeater-chars) - (let ((new-form form)) - (inc-form) - (format t "form'~a' new-form:'~a'~%" form new-form) + (let ((new-form form)) + (inc-form) + + (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)))))) - (if (or repeater-star (> repeater 1)) - (setf new-form (concatenate 'string - (string (char form 0)) - (if repeater-star - "*" - (write-to-string (1- repeater))) - (subseq form (1+ repeater-chars))))) - (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 *********** @@ -425,11 +461,15 @@ ;;; pack ;;; perl compatile pack() function. ;;; 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 (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)))) ;; result @@ -439,28 +479,84 @@ ;;; BODY - - (let ((result (if (eql (first rest) :result) - (let ((r (second rest))) - (setf rest (rest (rest rest))) - r) - ""))) - (if (and (eql nil rest) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X)))) + ;; 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)< + + ; (format t "pack: form:'~a' rest:~a~%" form rest) + + (let ((result "") + (modifiers nil)) + + ;; 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 (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 (item (first rest)) (new-rest (rest rest))) ; default rest for numbers #+big-endian(setf bytes-to-string-fn #'bytes-to-string) ; BIG ENDIAN - (if mod-> + (if mod-> (setf bytes-to-string-fn #'bytes-to-string)) (if mod-< (setf bytes-to-string-fn #'bytes-to-string-rev)) + ;; pack case satement (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) (#\n ;Unsigned Short 16bit Big Endian AB=AB (pack-int 2 :big)) @@ -490,7 +586,7 @@ ((#\s #\S) ;signed/unsigned short 16bit - (pack-int 2 native-endian)) + (pack-int 2 :native)) ((#\l #\L) ;signed/unsigned short 32bit (pack-int 4 :native)) @@ -561,31 +657,82 @@ (setf result (subseq result 0 (- (length result) (min (length result) delta))))) (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 - "")))) + ""))))) ) ;; 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) `(let ((ret (subseq ,str 0 ,len))) (setf ,new-str (subseq ,str ,len)) + (if consumed (incf consumed ,len)) ret)) ;;; perl compatible unpack() function ;;; form: a string of characters corresonding to decodings ;;; 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 -(def-form-parser unpack (string) +(def-form-parser unpack (string &key (consumed nil) (modifiers nil)) + + ;; extra end test (<= (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 (new-str string)) #+big-endian(setf string-to-bytes-fn #'string-to-bytes) @@ -594,74 +741,85 @@ (if mod-< (setf string-to-bytes-fn #'string-to-bytes-rev)) + ;; pack case statement and recursive call to unpack + ;; note: not tail optiomized :fix ? (apply #'values (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 - (#\C (unpack-uint 1 :big)) ; 1 byte unsigned character - (#\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))) + (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 - (#\I (let ((int-size 4)) ; native unsigned int size and endian - #+long-integer(setf int-size 8) - (unpack-int int-size :native))) + (#\c (unpack-int 1 :big)) ; 1 byte signed character + (#\C (unpack-uint 1 :big)) ; 1 byte unsigned character + (#\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))) + + (#\I (let ((int-size 4)) ; native unsigned 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))) + (#\w (ber-decode (cut-str string (ber-str-length string) new-str))) - (#\e (ieee-floats:decode-float32 (string-to-bytes-rev (cut-str string 4 new-str) 4))) ; 4 byte floating point little endian - (#\E (ieee-floats:decode-float64 (string-to-bytes-rev (cut-str string 8 new-str) 8))) ; 8 byte floating point little endian + (#\e (ieee-floats:decode-float32 (string-to-bytes-rev (cut-str string 4 new-str) 4))) ; 4 byte floating point little endian + (#\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 - (#\G (ieee-floats:decode-float64 (string-to-bytes (cut-str string 8 new-str) 8))) ; 8 byte floating point big endian + (#\g (ieee-floats:decode-float32 (string-to-bytes (cut-str string 4 new-str) 4))) ; 4 byte floating point big endian + (#\G (ieee-floats:decode-float64 (string-to-bytes (cut-str string 8 new-str) 8))) ; 8 byte floating point big endian - (#\f (ieee-floats:decode-float32 (funcall string-to-bytes-fn (cut-str string 4 new-str) 4))) ; 4 byte floating point native endian - (#\d (ieee-floats:decode-float64 (funcall string-to-bytes-fn (cut-str string 8 new-str) 8))) ; 8 byte floating point native endian + (#\f (ieee-floats:decode-float32 (funcall string-to-bytes-fn (cut-str string 4 new-str) 4))) ; 4 byte floating point native endian + (#\d (ieee-floats:decode-float64 (funcall string-to-bytes-fn (cut-str string 8 new-str) 8))) ; 8 byte floating point native endian - ((#\a #\A #\Z) ; chatacter string with various paddings - (let ((special-chars - (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) - (string-trim special-chars (cut-str string (length string) new-str)) - (string-trim special-chars (cut-str string (min repeater (length string)) new-str)) - (cut-str string 1 new-str)))) + (unpack-string (repeater repeater-star) + (string-trim special-chars (cut-str string (length string) new-str)) + (string-trim special-chars (cut-str string (min repeater (length string)) new-str)) + (cut-str string 1 new-str)))) - ((#\b #\B) ; bit string - (let ((bit-unpack-fn (if (char= (strhead form) #\b) #'byte-to-8bits-rev #'byte-to-8bits))) - (pack-string (repeater repeater-star) - (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 1 new-str) bit-unpack-fn) 0 1)))) + ((#\b #\B) ; bit string + (let ((bit-unpack-fn (if (char= (strhead form) #\b) #'byte-to-8bits-rev #'byte-to-8bits))) + (unpack-string (repeater repeater-star) + (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 1 new-str) bit-unpack-fn) 0 1)))) - ((#\h #\H) ; hex string - (let ((hex-unpack-fn (if (char= (strhead form) #\h) #'byte-to-2hex-rev #'byte-to-2hex))) - (pack-string (repeater repeater-star) - (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 1 new-str) hex-unpack-fn) 0 1)))) + ((#\h #\H) ; hex string + (let ((hex-unpack-fn (if (char= (strhead form) #\h) #'byte-to-2hex-rev #'byte-to-2hex))) + (unpack-string (repeater repeater-star) + (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 1 new-str) hex-unpack-fn) 0 1)))) - (#\x ; null character - (cut-str string 1 new-str) - nil) + (#\x ; null character + (cut-str string 1 new-str) + 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 - (multiple-value-list (unpack new-form new-str))) :from-end t :count 1)))) + (otherwise nil) + )) + + + ;; result of recursion + (multiple-value-list (unpack new-form new-str :consumed consumed :modifiers modifiers))) :from-end t :count 1)))) diff --git a/tests.lisp b/tests.lisp index e7e676e..c2958db 100644 --- a/tests.lisp +++ b/tests.lisp @@ -5,6 +5,7 @@ ;;;; Purpose: Tests for CL-PACK ;;;; Author: Dan Ballard ;;;; Created: May 2009 +;;;; Modified: August 2009 ;;;; License: BSD ;;;; Description: CL-PACK supplies perl/php/ruby compatible ;;;; pack() and unpack() functions to allow @@ -16,17 +17,19 @@ (defpackage :cl-pack-test (:use #:common-lisp #:cl-pack) - (:export #:test)) + (:export #:test #:test-silent)) (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) `(let ,(loop for n in names collect `(,n (gensym))) ,@body)) (defvar *test-name* nil) +(defvar *silent* nil) (defmacro deftest (name parameters &body body) "Define a test function. Within a test function we can call @@ -52,15 +55,15 @@ (incf ,total-count (if ,tot ,tot 1)) (incf ,pass-count (if ,pas ,pas (if ,res 1 0))) (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)))) (defun report-result (result form) "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) -;;;; ********************************************************** +;;;; ********************** Unit Tests **************************** (deftest test () @@ -76,7 +79,14 @@ (pack-form) (unpack-form) (mod-!) - (mod-<>))) + (mod-<>) + (grouping) + (pack-/) + )) + +(deftest test-silent () + (let ((*silent* t)) + (test))) (defun gen-null-string (len) (apply #'concatenate 'string (loop for i from 0 to (1- len) collecting (string #\null)))) @@ -98,31 +108,36 @@ (deftest pack-combinations () (check - (string= (pack "c2" #x41 #x42 #x43) "AB") ;; basic repeater (with extra data dropped) - (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 "c2N" #x41 #x42 #x43444546) "ABCDEF") ;; pick up after repeater + (string= (pack "c2" #x41 #x42 #x43) "AB") ; basic repeater (with extra data dropped) + (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 "c2N" #x41 #x42 #x43444546) "ABCDEF") ; pick up after repeater (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 () (check - (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 "A10" "Test") "Test ") ;; numeric repeater with string data and padding - (string= (pack "a*N" "String" #x41424344) "StringABCD") ;; pick up after string/* - (string= (pack "A10V" "Test" #x41424344) "Test DCBA") ;; 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 "B*" "010000010100001001000011") "ABC") ;; binary string - (string= (pack "B16" "010000010100001001000011") "AB") ;; binary string only consumes what's asked of it - (string= (pack "B*" "010000010100001") "AB") ;; AB string short a bit - (string= (pack "b*" "100000101000010") "A!") ;; AB string short a bit - (string= (pack "H4" "414243") "AB") ;; basic hex string (ignoring extra chars) - (string= (pack "H*" "414") "A@") ;; padding right? - (string= (pack "h*" "1424") "AB") ;; other byte ordering - (string= (pack "Z*" "dan") (concatenate 'string "dan" (string #\null))) ;; null padded 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 + (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 "a*" 65) "65") ; pack a string converting a number + (string= (pack "A10" "Test") "Test ") ; numeric repeater with string data and padding + (string= (pack "a*N" "String" #x41424344) "StringABCD") ; pick up after string/* + (string= (pack "A10V" "Test" #x41424344) "Test DCBA") ; 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 "B*" "010000010100001001000011") "ABC") ; binary string + (string= (pack "B16" "010000010100001001000011") "AB") ; binary string only consumes what's asked of it + (string= (pack "B*" "010000010100001") "AB") ; AB string short a bit + (string= (pack "b*" "100000101000010") "A!") ; AB string short a bit + (string= (pack "H4" "414243") "AB") ; basic hex string (ignoring extra chars) + (string= (pack "H*" "414") "A@") ; padding right? + (string= (pack "h*" "1424") "AB") ; other byte ordering + (string= (pack "Z*" "dan") (concatenate 'string "dan" (string #\null))) ; null padded 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 () (check - (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 "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 "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 "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 )) (deftest unpack-strings () (check - (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 "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 "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 + (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 "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 "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 - (string= (unpack "B*" "ABC") "010000010100001001000011") ;; binary string - (string= (unpack "B15" "ABC") "010000010100001") ;; binary string only consumes what's asked of it - (string= (unpack "b*" "AB") "1000001001000010") ;; other ordering - (string= (unpack "B9" "A") "01000001") ;; Not enough data - (string= (unpack "H3" "AB") "414") ;; basic hex string (ignoring extra chars) - (string= (unpack "H*" "A@") "4140") ;; padding right? - (string= (unpack "h*" "AB") "1424") ;; other byte ordering - (string= (unpack "H3" "A") "41") ;; not enough data + (string= (unpack "B*" "ABC") "010000010100001001000011") ; binary string + (string= (unpack "B15" "ABC") "010000010100001") ; binary string only consumes what's asked of it + (string= (unpack "b*" "AB") "1000001001000010") ; other ordering + (string= (unpack "B9" "A") "01000001") ; Not enough data + (string= (unpack "H3" "AB") "414") ; basic hex string (ignoring extra chars) + (string= (unpack "H*" "A@") "4140") ; padding right? + (string= (unpack "h*" "AB") "1424") ; other byte ordering + (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 )) +;; Test both < > mod features and that they play nice with repeaters (deftest mod-<> () (check - (string= (pack "l>" #x41424344) "ABCD") - (string= (pack "l<" #x41424344) "DCBA") + (string= (pack "l>" #x41424344 #x45464748) "ABCD") + (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 "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)" #x4142 #x4344 #x4546 #x4748 #x494a) "ABDCEFHGIJ") ; modifiers work over whole groups, and locality of modifier precidence + (equal (multiple-value-list (unpack "(s(ss>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 * + )) \ No newline at end of file