cl-pack/cl-pack.lisp

;;;; ******************************************************
;;;; 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))))