;;;; ****************************************************** ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: cl-pack.lisp ;;;; 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 ;;;; easy use of binary protocols with the above ;;;; mentioned languages and C. ;;;;******************************************************* (in-package #:cl-pack) ;;; ************* DOCUMENTATION AND NOTES ************** ;;; mostly from http://perldoc.perl.org/functions/pack.html ;;; Characters accpeted in FORM by pack and unpack ;;; as defined by the perl documentation for pack() ;;; and unpack() ;;; **** SUPPORTED TEMPLATE COMMANDS**** ;;;a A string with arbitrary binary data, null padded ;;;A A text (ASCII) string, space padded ;;;Z A null termnated (ASCII) string, null paddded ;;;b A bit string (ascending bit order inside each byte, like vec()). ;;;B A bit string (descending bit order inside each byte). ;;; ;;;h A hex string (low nybble first). ;;;H A hex string (high nybble first). ;;;c signed char 8 bit ;;;C unsigned char (octet) ;;;s signed short 16bit ;;;S unsigned short 16bit ;;;l signed long 32bit ;;;L unsighed long 32bit ;;;q signed quad ;;;Q unsigned quad ;;;i signed integer (at least 32, depends on what compiler calls 'int') ;;;I unsigned integer (machine dependant size & order) ;;;f single precision float ;;;d double precision float ;;;x null byte ;;;X Backup a byte (pack only) ;;; (pack only) ;;;@ 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) ;;;V unsigned long (32bit little endian) ;;;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. ;;; ***** FROM RUBY ****** ;;;e single precision float (little endian) ;;;g single precision float (big endian) ;;;E double precision float (little endian) ;;;G double precision float (big endian) ;;; ***** MODIFIERS ****** ;;; # form# repeats the form operation # times ;;; * form* repeats the form operation on all available arguments ;;; ! nNvV Treat as signed integer instead of unsigned ;;; > 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) ;;; ***** / Template ***** ;;; sequence length / sequence item ;;; in pack, writes out how ever many sequence items PRECEDED by the length ;;; in the form of sequence length ;;; example: (pack "a/c3" 65 66 67) => "3ABC" ;;; in unpack, reads the length and unpacks that many ;;; example: (unpack "a/c" "3ABC") => (65 66 67) ;;; **** NOTE ***** ;;; A lot use users of pack() and unpack() in other languages ;;; split 64 bit values into two longs and send them as ;;; 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> ;;; ***************** CL-PACK ********************** ;;; Determine as best we can the endian-ness of the host system ;;; for all the function that map to the host endian-ness #+(or x86 x86-64)(push :little-endian *features*) #+(or sparc powerpc ppc) (push :big-endian *features*) ;;;BI? what to do with: (alpha arm)? ;;; If we dont have an endian yet, we need one, so just default to one and hope ;; has to be done as find, not - feature because that's done at compile time ;; and we need this to be done at run time (if (not (or (find :little-endian *features*) (find :big-endian *features*))) (push :big-endian *features*)) ;;; The int encoding maps to host size of integer so try to determine that #+(or x86-64 64bit)(push :long-integer *features*) ;;; **** Utils **** (defun strhead (str) "returns a char that is the first char of str" (char str 0)) (defun strtail (str) "returns the rest of str" (subseq str 1)) (defmacro inc-form () "create a subseq of form that skips the current syntax object" `(setf new-form (subseq form offset))) ;;; **** Basic byte conversion stuff **** (defun twos-complement (number max-size) (if (< number 0) ;;(> number (expt 2 (1- max-size))) (1+ (lognot (min (expt 2 (1- (* 8 max-size))) (abs number)))) (min (1- (expt 2 (* 8 max-size))) number))) (defun un-twos-complement (number max-size) (if (>= number (expt 2 (1- (* 8 max-size)))) (- number (expt 2 (* 8 max-size))) (min (expt 2 (1- (* 8 max-size))) number))) (defun ber-encode (number) "function to encode a BER number into a binary byte string" (let ((num_bytes (ceiling (/ (log (1+ number) 2) 7))) (n number)) (coerce (loop for i from (1- num_bytes) downto 0 collect (code-char (+ (if (> i 0) 128 0) (let ((base (* i 7))) (loop for j from 6 downto 0 sum (let ((exp (expt 2 (+ base j)))) (if (>= n exp) (progn (decf n exp) (expt 2 j)) 0))))))) 'string))) (defun ber-decode (string) "Take a BER number as a binary string and returns a number" (loop for i from 0 to (1- (length string)) sum (* (expt 2 (* 7 (- (length string) 1 i))) (- (char-code (char string i)) (if (< i (1- (length string))) 128 0))))) (defun ber-str-length (string) (if (>= (char-code (char string 0)) 128) (1+ (ber-str-length (strtail string))) 1)) (defun bytes-to-list (bytes length) "bytes: Some binary data in lisp number form that ldb can access bytes-to-list pulls out 8bit bytes from bytes and turns them into their corresponding characters and returns the list of them" (loop for i from (- length 1) downto 0 collect (code-char (ldb (byte 8 (* 8 i)) bytes)))) ;;; BIG ENDIAN (defun bytes-to-string (bytes length) "puts length bytes from bytes into a string" (coerce (bytes-to-list bytes length) 'string)) ;;; LITTLE ENDIAN (defun bytes-to-string-rev (bytes length) "puts length bytes from bytes into a reversed string" (coerce (reverse (bytes-to-list bytes length)) 'string)) (defun unpack-bytes (string length) "takes length bytes from string and returns an int" (let ((int 0)) (loop for i from 0 to (1- length) do (setf (ldb (byte 8 (* 8 i)) int) (char-code (char string i)))) int)) ;;; BIG ENDIAN (defun string-to-bytes (string length) (unpack-bytes (reverse string) length)) ;;; LITTLE ENDIAN (defun string-to-bytes-rev (string length) (unpack-bytes string length)) ;;; **** String data stuff **** (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) ,star-body) (if (> ,repeater 0) ;; no *, a #? (let ((result (progn ,count-body))) ;(setf new-form (subseq form (1+ ,repeater-chars))) (inc-form) result) (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 (write-to-string 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" (let ((byte 0)) (loop for i from 0 to (min 7 (1- (length 8bits))) do (if (char= (char 8bits i) #\1) (incf byte (dpb 1 (funcall byte-form i) 0)))) (code-char byte))) (defun byte-to-8bits (byte) "turns a byte into a string of bits" (format nil "~8,'0B" byte)) (defun byte-to-8bits-rev (byte) "convert a byte to a bit string, lowest bit first" (reverse (byte-to-8bits byte))) (defun bit-pack (bit-str &optional (byte-form (lambda (i) (byte 8 (- 7 i))))) "pack a bit string into a byte string, decending order by default" (coerce (loop for i from 0 to (1- (length bit-str)) by 8 collecting (8bits-to-byte (subseq bit-str i (min (length bit-str) (+ i 8))) byte-form)) 'string)) (defun bit-unpack (byte-str &optional (unpack-fn #'byte-to-8bits)) "turn a string of bytes into an extended string of bits unpacked by unpack-fn" (apply #'concatenate 'string (loop for i from 0 to (1- (length byte-str)) collecting (funcall unpack-fn (char-code (char byte-str i)))))) (defun hex-to-number (hex) "turn a character of 0-9 or a-f or A-F into a hex digit of 0-15" (digit-char-p hex 16)) ;;; Not needed any more ;;(defun number-to-hex (num) ;; "convert a number 0-15 to a hex character" ;; (digit-char num 16)) (defun 2hex-to-byte (2hex &optional (mapper (lambda (2hex) (values (char 2hex 0) (char 2hex 1))))) "Turn a 2 hex digit string into a number unpacked by mapper" (multiple-value-bind (a b) (funcall mapper 2hex) (+ (* 16 (hex-to-number (coerce a 'character))) (hex-to-number (coerce b 'character))))) (defun byte-to-2hex (byte) "Turn a byte into a string of 2 hex characters" (format nil "~2,0X" byte)) (defun byte-to-2hex-rev (byte) (reverse (byte-to-2hex byte))) (defun hex-pack (hex-str &optional (mapper (lambda (2hex) (values (char 2hex 0) (char 2hex 1))))) "turn a string of hex digits into a string of packed bytes, unpacking 2 hex digits at a time by mapper" (let ((str (if (= (mod (length hex-str) 2) 1) (concatenate 'string hex-str "0" ) hex-str))) (coerce (loop for i from 0 to (1- (length str)) by 2 collecting (code-char (2hex-to-byte (subseq str i (+ i 2)) mapper))) 'string))) (defun hex-unpack (byte-str &optional (hex-unpack-fn #'byte-to-2hex)) "Turn a string of bytes into a string of hex digits" (apply #'concatenate 'string (loop for i from 0 to (1- (length byte-str)) collecting (funcall hex-unpack-fn (char-code (char byte-str i)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun endian-type-to-func (endian) (if (eql endian :big) '#'bytes-to-string (if (eql endian :native) 'bytes-to-string-fn '#'bytes-to-string-rev)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun un-endian-type-to-func (endian) (if (eql endian :big) '#'string-to-bytes (if (eql endian :native) 'string-to-bytes-fn '#'string-to-bytes-rev)))) (defmacro pack-int (size endian) "Macro to define the pack function for an int" (let ((pack-fn (endian-type-to-func endian))) `(funcall ,pack-fn (twos-complement item ,size) ,size))) (defmacro unpack-int (size endian) "Macro to define the unpack function for a signed int" (let ((unpack-fn (un-endian-type-to-func endian))) `(un-twos-complement (funcall ,unpack-fn (cut-str string ,size new-str) ,size) ,size))) (defmacro unpack-uint (size endian) "Macro to define the unpack function for an unsigned int" (let ((unpack-fn (un-endian-type-to-func endian))) `(funcall ,unpack-fn (cut-str string ,size new-str) ,size))) (defmacro unpack-mod!-uint (size endian) "macro to define a normal uint that with the ! modifier is a signed int" `(if mod-! (unpack-int ,size ,endian) (unpack-uint ,size ,endian))) (defun next-char (form offset) "Get the next char from a string of null if offset is past end of string" (if (>= offset (length form)) #\null (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 ;;; repeater, repeater-star repeater-chars new-form ;;; 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 ;; parsing variables and init (let ((offset 1) (inner-length 0) (repeater-star nil) (repeater 0) (mod-! nil) (mod-> nil) (mod-< nil) (/-pos 0)) (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) )) ) (progn ; repeater-count == # (if (> repeater-count 0) (setf repeater repeater-count)) (incf offset repeater-chars)) ))) (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)))))) (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 *********** ;;; pack ;;; perl compatile pack() function. ;;; form: is a string of characters corresponding to encodings of data ;;; 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 (and (eql nil rest) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X)))) ;; result (if (and (>= (length rest) 2) (eql (first rest) :result)) (second rest) "") ;;; 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)< ; (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 ;; 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-> (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 (write-to-string 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)) (#\N ; Unsigned Long 32bit Big Endian ABCD=ABCD (pack-int 4 :big)) (#\v ;Unsigned Short 16bit Litte Endian AB=BA (pack-int 2 :little)) (#\V ; Unsigned Long 32bit Little Endian ABCD=DCBA (pack-int 4 :little)) (#\g ; single precision float Bit Endian (bytes-to-string (ieee-floats:encode-float32 (float item)) 4)) (#\G ; double precision float Bit Endian (bytes-to-string (ieee-floats:encode-float64 (float item)) 8)) (#\e ; single precision float Little Endian (bytes-to-string-rev (ieee-floats:encode-float32 (float item)) 4)) (#\E ; double precision float Little Endian (bytes-to-string-rev (ieee-floats:encode-float64 (float item)) 8)) (#\w ; ~BER encoded number (ber-encode item)) (#\c ;signed 8bit char (pack-int 1 :big)) (#\C ;unsigned 8bit char (pack-int 1 :big)) ;;(#\W ;wide char ;; Wide chars in strings in concatenate seems to ;; crash :( ;; (string (code-char item ))) ((#\s #\S) ;signed/unsigned short 16bit (pack-int 2 :native)) ((#\l #\L) ;signed/unsigned short 32bit (pack-int 4 :native)) ((#\q #\Q) ;signed/unsigned quad 64bit (pack-int 8 :native)) ((#\i #\I) ; signed/unsigned integer machine size (let ((int-size 4)) #+long-integer(setf int-size 8) (pack-int int-size :native))) (#\f ;single precision float (funcall bytes-to-string-fn (ieee-floats:encode-float32 (float item)) 4)) (#\d ;double precision float (funcall bytes-to-string-fn (ieee-floats:encode-float64 (float item)) 8)) ((#\a #\A) ;string with binary data, null padded/space padded (pack-string (repeater repeater-star) item (concatenate 'string (subseq item 0 (min (length item) repeater)) (if (> repeater (length item)) (make-list (- repeater (length item)):initial-element (if (char= #\a (strhead form)) #\null #\space)) "")) (string (char item 0)))) (#\Z ; null terminated /padded string (pack-string (repeater repeater-star) (concatenate 'string item (string #\null)) (concatenate 'string (subseq item 0 (min (length item) (1- repeater))) (if (> (1- repeater) (length item)) (make-list (- repeater (length item)) :initial-element #\null) (string #\null))) (string #\null))) ((#\b #\B) ; bit strings (let ((bit-mapper (if (char= #\b (strhead form)) (lambda (i) (byte 8 i)) ; ascending (lambda (i) (byte 8 (- 7 i)))))) ;decending (pack-string (repeater repeater-star) (bit-pack item bit-mapper) (bit-pack (subseq item 0 (min repeater (length item))) bit-mapper) (bit-pack (subseq item 0 1) bit-mapper)))) ((#\h #\H) ; hex strings (let ((byte-mapper (if (char= #\H (strhead form)) (lambda (2hex) (values (char 2hex 0) (char 2hex 1))) ;high nybble first (lambda (2hex) (values (char 2hex 1) (char 2hex 0)))))) ; low nybble first (pack-string (repeater repeater-star) (hex-pack item byte-mapper) (hex-pack (subseq item 0 (min repeater (length item))) byte-mapper) (hex-pack (subseq item 0 1) byte-mapper)))) (#\x ; null character (progn (setf new-rest rest) ; this function doesn't consume (string #\null))) (#\X ;backup a byte (progn (let ((delta 1)) (if repeater-star (setf delta (length result)) (if (>= repeater 1) (setf delta repeater))) (setf result (subseq result 0 (- (length result) (min (length result) delta))))) (inc-form) (setf new-rest rest) "" )) ((#\. #\@) ;; . 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 () ;(format t "~a~%" new-result) ;; 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 &key (consumed nil) (modifiers nil)) ;; extra end test (<= (length string) 0) ;; 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) (if mod-> (setf string-to-bytes-fn #'string-to-bytes)) (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 (if (> /-pos 0) (progn (let* ((length-item (subseq form 0 /-pos)) (sequence-item (subseq form (1+ /-pos) offset)) (lengths (multiple-value-list (unpack length-item string :consumed 0 :modifiers modifiers))) (seq-len (if (numberp (first lengths)) (write-to-string (first lengths)) (first lengths))) (ret (multiple-value-list (unpack (concatenate 'string sequence-item seq-len) (subseq string (second lengths)) :consumed 0 :modifiers modifiers))) (consumed-len (+ (first (last ret)) (second lengths)))) (cut-str string consumed-len new-str) (inc-form) (nbutlast ret) )) (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))) (#\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))) (#\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 (#\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) ""))) (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))) (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))) (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) (#\( ; 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)) ) (otherwise nil) ))) ;; result of recursion (multiple-value-list (unpack new-form new-str :consumed consumed :modifiers modifiers))) :from-end t :count 1))))