You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

841 lines
30 KiB

;;;; ******************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: cl-pack.lisp
;;;; Purpose: CL-PACK code
;;;; Author: Dan Ballard <http://mindstab.net>
;;;; 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))
(if (eql 0 n) (incf num_bytes))
(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 nil)
(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 nil 0))
(if (and (>= (length str) 1) (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 (setf repeater repeater-count))
(incf offset repeater-chars))
)))
(let ((new-form form))
(inc-form)
(if (or repeater-star (and repeater (> 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-result nil)
(new-rest rest))
#+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))
(if (or (not repeater) (> repeater 0))
(progn
(if (not repeater) (setf repeater 0))
(setf new-rest (rest rest)) ;consume here - default rest for numbers
;; pack case satement
(setf 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
""))))
) ;; (setf 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, every 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))
;; unpack case statement and recursive call to unpack
;; note: not tail optiomized :fix ?
(apply #'values
(remove nil (append
(if (or (not repeater) (> repeater 0))
(progn
(if (not repeater) (setf repeater 0))
(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))))