cl-pack/cl-pack.lisp

668 lines
24 KiB
Common Lisp

;;;; ******************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: cl-pack.lisp
;;;; Purpose: CL-PACK code
;;;; Author: Dan Ballard <http://mindstab.net>
;;;; Created: May 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
;;;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
;;; **** 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
;;; ************* 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 **********************
;;; 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 (+ 1 mod-chars repeater-chars))))
;;; **** 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 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
(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 #
))
(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)))
;;; 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)
(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))))
(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)))
)
(format t "VALUES: !~a >~a <~a #:~a~%" mod-! mod-> mod-< mod-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)
(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))))))))
;;; *********** The Main part ***********
;;; pack
;;; perl compatile pack() function.
;;; form: is a string of characters corresponding to encodings of data
;;; rest: is the data to be 'packed'
;;; 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
(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))))
result
(progn
(format t "~a ~a ~a~%" form result rest)
(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))
(let ((new-result
(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-endian))
((#\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)
""
))
(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)
(apply #'pack (append (list new-form :result (concatenate 'string result new-result)) new-rest))))))))
(defmacro cut-str (str len new-str)
`(let ((ret (subseq ,str 0 ,len)))
(setf ,new-str (subseq ,str ,len))
ret))
;;; perl compatible unpack() function
;;; form: a string of characters corresonding to decodings
;;; string: a string of binary data to be decoded
;;; returns: the decoded data in specified format
(def-form-parser unpack (string)
(<= (length string) 0)
nil
(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))
(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)))
(#\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)
"")))
(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))))
((#\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))))
((#\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))))
(#\x ; null character
(cut-str string 1 new-str)
nil)
(otherwise nil)
))
;; result of recursion
(multiple-value-list (unpack new-form new-str))) :from-end t :count 1))))