dan
/
cl-pack
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial git commit

This commit is contained in:
Dan Ballard 2009-07-26 20:53:42 -07:00
commit f75c6ca2e2
12 changed files with 1366 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
CHANGES Normal file
View File

@ -0,0 +1,20 @@
0.2 2009-07
- added support for signed numbers that mirrors perl's
- fixed native endian selection bug
- added support for <> modifiers
on native endian directives (sSiIlLqQdf)
they can be forced to big or small endian with < > modifiers
- added support for ! modifier
on nNvV it turns them to signed integers
- more test cases to cover all this
- git repo seems to have taken
0.1.1 2009-07-04
simple speed increase and code reduction improvements suggested by Zach
0.1 2009-06-16
initial release
Basic packing/unpacking for most data types (numbers, strings,
floats) and repeater syntax supported.

10
COPYING Normal file
View File

@ -0,0 +1,10 @@
Copyright (c) 2009, Dan Ballard
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
* Neither the name of the Mindstab nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

7
README Normal file
View File

@ -0,0 +1,7 @@
CL-PACK
Dan Ballard <http://mindstab.net>
June 2009
CL-PACK supplier perl/php/ruby compatible pack() and unpack() functions to allow easy use of binary protocols with the above mentioned languages and C.
Documentation inside cl-pack.lisp

52
cl-pack.asd Normal file
View File

@ -0,0 +1,52 @@
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; ******************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: cl-pack.asd
;;;; Purpose: System definition for CL-PACK
;;;; 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.
;;;;*******************************************************
(defpackage #:cl-pack-system (:use #:asdf #:cl))
(in-package #:cl-pack-system)
; Try to find ieee-floats in the system,
; otherwise we'll load the copy we ship with
;(eval-when (:compile-toplevel :load-toplevel :execute)
(handler-case
(unless (find-package 'ieee-floats)
(progn
(asdf:operate 'asdf:load-op 'ieee-floats)
(push :native-ieee-floats *features*)))
(MISSING-COMPONENT (e) nil))
(defsystem #:cl-pack
:name "cl-pack"
:author "Dan Ballard <haplo@mindstab.net>"
:version "0.1"
:licence "BSD"
:description "perl compatible binary pack() and unpack() library"
:depends-on #+native-ieee-floats(:ieee-floats)
#-native-ieee-floats()
:components (#-native-ieee-floats
(:module ieee-floats
:components ((:file "ieee-floats")))
(:file "package"
:depends-on (ieee-floats))
(:file "cl-pack"
:depends-on ("package" ieee-floats))))
(defsystem #:cl-pack-test
:depends-on (:cl-pack)
:components ((:file "tests")))

667
cl-pack.lisp Normal file
View File

@ -0,0 +1,667 @@
;;;; ******************************************************
;;;; 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))))

90
ieee-floats/doc/index.html Normal file
View File

@ -0,0 +1,90 @@
<?xml version="1.0"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title>IEEE Floats</title>
<link rel="stylesheet" type="text/css" href="style.css"/>
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
</head>
<body>
<div class="header">
<h1>IEEE Floats</h1>
</div>
<p>IEEE-Floats provides a way of converting values of type
<tt>float</tt> and <tt>double-float</tt> to and from their binary
representation as defined by IEEE 754 (which is commonly used by
processors and network protocols).</p>
<p>The library defines encoding and decoding functions for the common
32-bit and 64-bit formats, and a macro for defining similar functions
for other formats. The default functions do not detect the special
cases for NaN or infinity, but functions can be generated which do, in
which case the keywords <tt>:not-a-number</tt>,
<tt>:positive-infinity</tt>, and <tt>:negative-infinity</tt> are used
to represent them.</p>
<h2>Download and installation</h2>
<p>IEEE-Floats is released under a BSD-style license. The latest
release can be downloaded from <a
href="http://common-lisp.net/project/ieee-floats/ieee-floats.tgz">http://common-lisp.net/project/ieee-floats/ieee-floats.tgz</a>,
or installed with <a
href="http://www.cliki.net/ASDF-Install">asdf-install</a>.</p>
<p>A <a href="http://www.darcs.net/">darcs</a> repository with the most recent changes can be checked out with:</p>
<pre>&gt; darcs get http://common-lisp.net/project/ieee-floats/darcs/ieee-floats</pre>
<p>Or look at it <a
href="http://common-lisp.net/cgi-bin/darcsweb/darcsweb.cgi?r=ieee-floats-ieee-floats;a=summary">online</a>.</p>
<h2>Support and mailing lists</h2>
<p>The <a
href="http://common-lisp.net/mailman/listinfo/ieee-floats-devel">ieee-floats-devel</a>
mailing list can be used for any questions, discussion, bug-reports,
patches, or anything else relating to this library. You can also e-mail the author/maintainer, <a href="mailto:marijnh@gmail.com">Marijn Haverbeke</a>, directly.</p>
<h2>Reference</h2>
<p class="def">function <tt>encode-float32</tt> (float) => integer</p>
<p class="desc">Convert a float into its 32-bit binary
representation.</p>
<p class="def">function <tt>decode-float32</tt> (integer) => float</p>
<p class="desc">Create a float from a 32-bit binary representation.</p>
<p class="def">function <tt>encode-float64</tt> (float) => integer</p>
<p class="desc">Convert a float into its 64-bit binary
representation.</p>
<p class="def">function <tt>decode-float64</tt> (integer) => double-float</p>
<p class="desc">Create a float from a 64-bit binary representation.</p>
<p class="def">macro <tt>make-float-converters</tt> (encoder-name decoder-name exponent-bits significand-bits support-nan-and-infinity-p)</p>
<p class="desc">Writes an encoder and decoder function for floating
point numbers with the given amount of exponent and significand bits
(plus an extra sign bit). If support-nan-and-infinity-p is true, the
decoders will also understand these special cases. NaN is represented
as :not-a-number, and the infinities as :positive-infinity and
:negative-infinity. Note that this means that the in- or output of
these functions is not just floating point numbers anymore, but also
keywords.</p>
<hr/>
<p>Back to <a href="http://common-lisp.net/">Common-lisp.net</a>.</p>
<div class="check">
<a href="http://validator.w3.org/check/referer">Valid XHTML 1.0 Strict</a>
</div>
</body>
</html>

72
ieee-floats/doc/style.css Normal file
View File

@ -0,0 +1,72 @@
.header {
font-size: medium;
background-color:#336699;
color:#ffffff;
border-style:solid;
border-width: 5px;
border-color:#002244;
padding: 1mm 1mm 1mm 5mm;
}
.footer {
font-size: small;
font-style: italic;
text-align: right;
background-color:#336699;
color:#ffffff;
border-style:solid;
border-width: 2px;
border-color:#002244;
padding: 1mm 1mm 1mm 1mm;
}
.footer a:link {
font-weight:bold;
color:#ffffff;
text-decoration:underline;
}
.footer a:visited {
font-weight:bold;
color:#ffffff;
text-decoration:underline;
}
.footer a:hover {
font-weight:bold;
color:#002244;
text-decoration:underline; }
.check {font-size: x-small;
text-align:right;}
.check a:link { font-weight:bold;
color:#a0a0ff;
text-decoration:underline; }
.check a:visited { font-weight:bold;
color:#a0a0ff;
text-decoration:underline; }
.check a:hover { font-weight:bold;
color:#000000;
text-decoration:underline; }
tt {
font-size: 1.1em;
font-weight: bold;
}
.def {
margin-top: 1.5em;
font-family: tahoma, arial, sans-serif;
}
.desc {
padding-left: .6em;
}
h2 {
font-size: 14pt;
}

10
ieee-floats/ieee-floats.asd Normal file
View File

@ -0,0 +1,10 @@
(defpackage :ieee-floats-system
(:use :common-lisp :asdf))
(in-package :ieee-floats-system)
(defsystem :ieee-floats
:components ((:file "ieee-floats")))
(defsystem :ieee-floats-tests
:depends-on (:ieee-floats :fiveam)
:components ((:file "tests")))

138
ieee-floats/ieee-floats.lisp Normal file
View File

@ -0,0 +1,138 @@
;;; Functions for converting floating point numbers represented in
;;; IEEE 754 style to lisp numbers.
;;;
;;; See http://common-lisp.net/project/ieee-floats/
(in-package :common-lisp)
(defpackage :ieee-floats
(:use :common-lisp)
(:export :make-float-converters
:encode-float32
:decode-float32
:encode-float64
:decode-float64))
(in-package :ieee-floats)
;; The following macro may look a bit overcomplicated to the casual
;; reader. The main culprit is the fact that NaN and infinity can be
;; optionally included, which adds a bunch of conditional parts.
;;
;; Assuming you already know more or less how floating point numbers
;; are typically represented, I'll try to elaborate a bit on the more
;; confusing parts, as marked by letters:
;;
;; (A) Exponents in IEEE floats are offset by half their range, for
;; example with 8 exponent bits a number with exponent 2 has 129
;; stored in its exponent field.
;;
;; (B) The maximum possible exponent is reserved for special cases
;; (NaN, infinity).
;;
;; (C) If the exponent fits in the exponent-bits, we have to adjust
;; the significand for the hidden bit. Because decode-float will
;; return a significand between 0 and 1, and we want one between 1
;; and 2 to be able to hide the hidden bit, we double it and then
;; subtract one (the hidden bit) before converting it to integer
;; representation (to adjust for this, 1 is subtracted from the
;; exponent earlier). When the exponent is too small, we set it to
;; zero (meaning no hidden bit, exponent of 1), and adjust the
;; significand downward to compensate for this.
;;
;; (D) Here the hidden bit is added. When the exponent is 0, there is
;; no hidden bit, and the exponent is interpreted as 1.
;;
;; (E) Here the exponent offset is subtracted, but also an extra
;; factor to account for the fact that the bits stored in the
;; significand are supposed to come after the 'decimal dot'.
(defmacro make-float-converters (encoder-name
decoder-name
exponent-bits
significand-bits
support-nan-and-infinity-p)
"Writes an encoder and decoder function for floating point
numbers with the given amount of exponent and significand
bits (plus an extra sign bit). If support-nan-and-infinity-p is
true, the decoders will also understand these special cases. NaN
is represented as :not-a-number, and the infinities as
:positive-infinity and :negative-infinity. Note that this means
that the in- or output of these functions is not just floating
point numbers anymore, but also keywords."
(let* ((total-bits (+ 1 exponent-bits significand-bits))
(exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A)
(sign-part `(ldb (byte 1 ,(1- total-bits)) bits))
(exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits))
(significand-part `(ldb (byte ,significand-bits 0) bits))
(nan support-nan-and-infinity-p)
(max-exponent (1- (expt 2 exponent-bits)))) ; (B)
`(progn
(defun ,encoder-name (float)
,@(unless nan `((declare (type float float))))
(multiple-value-bind (sign significand exponent)
(cond ,@(when nan `(((eq float :not-a-number)
(values 0 1 ,max-exponent))
((eq float :positive-infinity)
(values 0 0 ,max-exponent))
((eq float :negative-infinity)
(values 1 0 ,max-exponent))))
((zerop float)
(values 0 0 0))
(t
(multiple-value-bind (significand exponent sign) (decode-float float)
(let ((exponent (+ (1- exponent) ,exponent-offset))
(sign (if (= sign 1.0) 0 1)))
(unless (< exponent ,(expt 2 exponent-bits))
(error "Floating point overflow when encoding ~A." float))
(if (< exponent 0) ; (C)
(values sign (ash (round (* ,(expt 2 significand-bits) significand)) exponent) 0)
(values sign (round (* ,(expt 2 significand-bits) (1- (* significand 2)))) exponent))))))
(let ((bits 0))
(declare (type (unsigned-byte ,total-bits) bits))
(setf ,sign-part sign
,exponent-part exponent
,significand-part significand)
bits)))
(defun ,decoder-name (bits)
(declare (type (unsigned-byte ,total-bits) bits))
(let* ((sign ,sign-part)
(exponent ,exponent-part)
(significand ,significand-part))
,@(when nan `((when (= exponent ,max-exponent)
(return-from ,decoder-name
(cond ((not (zerop significand)) :not-a-number)
((zerop sign) :positive-infinity)
(t :negative-infinity))))))
(if (zerop exponent) ; (D)
(setf exponent 1)
(setf (ldb (byte 1 ,significand-bits) significand) 1))
(unless (zerop sign)
(setf significand (- significand)))
(scale-float (float significand ,(if (> total-bits 32) 1.0d0 1.0))
(- exponent ,(+ exponent-offset significand-bits)))))))) ; (E)
;; And instances of the above for the common forms of floats.
(make-float-converters encode-float32 decode-float32 8 23 nil)
(make-float-converters encode-float64 decode-float64 11 52 nil)
;;; Copyright (c) 2006 Marijn Haverbeke
;;;
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the authors be held liable for any
;;; damages arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any
;;; purpose, including commercial applications, and to alter it and
;;; redistribute it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;; not claim that you wrote the original software. If you use this
;;; software in a product, an acknowledgment in the product
;;; documentation would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;; not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;; distribution.

66
ieee-floats/tests.lisp Normal file
View File

@ -0,0 +1,66 @@
(defpackage :ieee-floats-tests
(:use :common-lisp :ieee-floats :fiveam))
(in-package :ieee-floats-tests)
;; After loading, run the tests with (fiveam:run! :ieee-floats)
;; The tiny-XX tests will error on systems that do not support 64-bit
;; floats, CLISP is one of those.
(def-suite :ieee-floats)
(in-suite :ieee-floats)
(defmacro pairs-correspond (decode encode &body pairs)
`(progn ,@(loop :for (float bits) :in pairs
:collect `(is (eql ,float (,decode ,bits)))
:collect `(is (eql ,bits (,encode ,float))))))
(def-fixture special-converters ()
(make-float-converters encode-float64* decode-float64* 11 52 t)
(make-float-converters encode-float32* decode-float32* 8 23 t))
(test sanity-32
(pairs-correspond decode-float32 encode-float32
(0.0 #b00000000000000000000000000000000)
(5.0 #b01000000101000000000000000000000)
(-5.0 #b11000000101000000000000000000000)
(3.3333333e20 #b01100001100100001000111101101111)
(-.44e-30 #b10001101000011101100100111000101)))
(test tiny-32
(pairs-correspond decode-float32 encode-float32
(9.949219e-44 #b00000000000000000000000001000111)))
(test overflow-32
(signals error
(encode-float32 1.0d60)))
(test specials-32
(with-fixture special-converters ()
(pairs-correspond decode-float32* encode-float32*
(5.0e2 #b01000011111110100000000000000000)
(-5.0e-2 #b10111101010011001100110011001101)
(:not-a-number #b01111111100000000000000000000001)
(:positive-infinity #b01111111100000000000000000000000)
(:negative-infinity #b11111111100000000000000000000000))))
(test sanity-64
(pairs-correspond decode-float64 encode-float64
(0.0d0 #b0000000000000000000000000000000000000000000000000000000000000000)
(42d42 #b0100100011111110001000100010111010000010011001101101001001111111)
(-42d42 #b1100100011111110001000100010111010000010011001101101001001111111)
(.555555555d-30 #b0011100110100110100010010011011111111110011011000100011010001000)))
(test tiny-64
(pairs-correspond decode-float64 encode-float64
(4.1995579896505956d-322 #b0000000000000000000000000000000000000000000000000000000001010101)))
(test specials-64
(with-fixture special-converters ()
(pairs-correspond decode-float64* encode-float64*
(42d42 #b0100100011111110001000100010111010000010011001101101001001111111)
(-42d42 #b1100100011111110001000100010111010000010011001101101001001111111)
(:not-a-number #b0111111111110000000000000000000000000000000000000000000000000001)
(:positive-infinity #b0111111111110000000000000000000000000000000000000000000000000000)
(:negative-infinity #b1111111111110000000000000000000000000000000000000000000000000000))))

20
package.lisp Normal file
View File

@ -0,0 +1,20 @@
;;;; ******************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: package.lisp
;;;; Purpose: Package definition for CL-PACK
;;;; 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 :common-lisp)
(defpackage #:cl-pack
(:use #:common-lisp #:ieee-floats)
(:export #:pack
#:unpack))

214
tests.lisp Normal file
View File

@ -0,0 +1,214 @@
;;;; ******************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: tests.lisp
;;;; Purpose: Tests for CL-PACK
;;;; 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 :common-lisp)
(defpackage :cl-pack-test
(:use #:common-lisp #:cl-pack)
(:export #:test))
(in-package :cl-pack-test)
;;;; ***** Shamelessly ripped from Practical Common Lisp *****
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (gensym)))
,@body))
(defvar *test-name* nil)
(defmacro deftest (name parameters &body body)
"Define a test function. Within a test function we can call
other test functions or use 'check' to run individual test
cases."
`(defun ,name ,parameters
(let ((*test-name* (append *test-name* (list ',name))))
,@body)))
(defmacro check (&body forms)
"Run each expression in 'forms' as a test case."
`(combine-results
,@(loop for f in forms collect `(report-result ,f ',f))))
(defmacro combine-results (&body forms)
"Combine the results (as booleans) of evaluating 'forms' in order."
(with-gensyms (result pass-count total-count res pas tot)
`(let ((,result t)
(,pass-count 0)
(,total-count 0))
,@(loop for f in forms collect
`(multiple-value-bind (,res ,pas ,tot) ,f
(incf ,total-count (if ,tot ,tot 1))
(incf ,pass-count (if ,pas ,pas (if ,res 1 0)))
(if (not ,res) (setf ,result nil))))
(format t "~a ~d/~d passed~%" *test-name* ,pass-count ,total-count)
(values ,result ,pass-count ,total-count))))
(defun report-result (result form)
"Report the results of a single test case. Called by 'check'."
(format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
result)
;;;; **********************************************************
(deftest test ()
(combine-results
(pack-numbers)
(pack-combinations)
(pack-strings)
(unpack-numbers)
(unpack-combinations)
(unpack-strings)
(pack-signed)
(unpack-signed)
(pack-form)
(unpack-form)
(mod-!)
(mod-<>)))
(defun gen-null-string (len)
(apply #'concatenate 'string (loop for i from 0 to (1- len) collecting (string #\null))))
(deftest pack-numbers ()
(check
(string= (pack "n" #x4142) "AB")
(string= (pack "v" #x4142) "BA")
(string= (pack "N" #x41424344) "ABCD")
(string= (pack "V" #x41424344) "DCBA")
(string= (pack "g" 15) (concatenate 'string "Ap" (string #\null) (string #\null)))
(string= (pack "e" 15) (concatenate 'string (string #\null) (string #\null) "pA"))
(string= (pack "G" 25) (concatenate 'string "@9" (gen-null-string 6)))
(string= (pack "E" 25) (concatenate 'string (gen-null-string 6) "9@"))
(string= (pack "x") (string #\null))
(string= (pack "w" 193) (coerce `(,(code-char 129) #\A) 'string))
))
(deftest pack-combinations ()
(check
(string= (pack "c2" #x41 #x42 #x43) "AB") ;; basic repeater (with extra data dropped)
(string= (pack "c*" #x41 #x42 #x43) "ABC") ;; basic * repeater
(string= (pack "c3" #x41 #x42) "AB") ;; only use avail data -- ! should ERROR be raised?
(string= (pack "c2N" #x41 #x42 #x43444546) "ABCDEF") ;; pick up after repeater
(string= (pack "NX2" #x41424344) "AB") ;delete chars
))
(deftest pack-strings ()
(check
(string= (pack "a*" "Test String") "Test String") ;; * repeater with string data
(string= (pack "a5" "1234") (concatenate 'string "1234" (string #\null))) ;; test null of 'a'
(string= (pack "A10" "Test") "Test ") ;; numeric repeater with string data and padding
(string= (pack "a*N" "String" #x41424344) "StringABCD") ;; pick up after string/*
(string= (pack "A10V" "Test" #x41424344) "Test DCBA") ;; pick up after string/#
(string= (pack "c2xa*" #x41 #x42 "Test") (concatenate 'string "AB" (string #\null) "Test")) ;; non consuming 'x' plays nicely with others
(string= (pack "B*" "010000010100001001000011") "ABC") ;; binary string
(string= (pack "B16" "010000010100001001000011") "AB") ;; binary string only consumes what's asked of it
(string= (pack "B*" "010000010100001") "AB") ;; AB string short a bit
(string= (pack "b*" "100000101000010") "A!") ;; AB string short a bit
(string= (pack "H4" "414243") "AB") ;; basic hex string (ignoring extra chars)
(string= (pack "H*" "414") "A@") ;; padding right?
(string= (pack "h*" "1424") "AB") ;; other byte ordering
(string= (pack "Z*" "dan") (concatenate 'string "dan" (string #\null))) ;; null padded string *
(string= (pack "Z5" "dan") (concatenate 'string "dan" (string #\null) (string #\null))) ;; padding of Z
(string= (pack "Z3" "dan") (concatenate 'string "da" (string #\null))) ;; proper ending in NULL for under length string
))
(deftest unpack-numbers ()
(check
(= (unpack "N" "ABCD") #x41424344)
(= (unpack "V" "DCBA") #x41424344)
(= (unpack "n" "AB") #x4142)
(= (unpack "v" "BA") #x4142)
(= (unpack "g" (concatenate 'string "Ap" (string #\null) (string #\null))) 15)
(= (unpack "e" (concatenate 'string (string #\null) (string #\null) "pA")) 15)
(= (unpack "G" (concatenate 'string "@9" (gen-null-string 6))) 25)
(= (unpack "E" (concatenate 'string (gen-null-string 6) "9@")) 25)
(= (unpack "w" (coerce `(,(code-char 129) #\A) 'string)) 193)
))
(deftest unpack-combinations ()
(check
(equal (multiple-value-list (unpack "c2" "ABC")) '(#x41 #x42)) ;; basic repeater (with extra data dropped)
(equal (multiple-value-list (unpack "c*" "ABC")) '(#x41 #x42 #x43)) ;; basic * repeater
(equal (multiple-value-list (unpack "c3" "AB")) '(#x41 #x42)) ;; only use avail data -- ! should ERROR be raised?
(equal (multiple-value-list (unpack "c2N" "ABCDEF")) '(#x41 #x42 #x43444546)) ;; pick up after repeater
))
(deftest unpack-strings ()
(check
(string= (unpack "a*" "Test String") "Test String") ;; * repeater with string data
(string= (unpack "a5" (concatenate 'string "1234" (string #\null))) (concatenate 'string "1234" (string #\null))) ;; test null of 'a'
(string= (unpack "A10" "Test ") "Test");; numeric repeater with string data and padding
(equal (multiple-value-list (unpack "A*N" "String ABCD ")) '("String ABCD")) ;; it doesn't pick up after string/*
(equal (multiple-value-list (unpack "A10V" "Test DCBA")) '("Test" #x41424344)) ;; pick up after string/#
(equal (multiple-value-list (unpack "c2xa*" (concatenate 'string "AB" (string #\null) "Test"))) '(#x41 #x42 "Test")) ;; non consuming 'x' plays nicely with others
(string= (unpack "B*" "ABC") "010000010100001001000011") ;; binary string
(string= (unpack "B15" "ABC") "010000010100001") ;; binary string only consumes what's asked of it
(string= (unpack "b*" "AB") "1000001001000010") ;; other ordering
(string= (unpack "B9" "A") "01000001") ;; Not enough data
(string= (unpack "H3" "AB") "414") ;; basic hex string (ignoring extra chars)
(string= (unpack "H*" "A@") "4140") ;; padding right?
(string= (unpack "h*" "AB") "1424") ;; other byte ordering
(string= (unpack "H3" "A") "41") ;; not enough data
(string= (unpack "Z*" (concatenate 'string "dan" (string #\null))) (concatenate 'string "dan" (string #\null))) ;; null padded string *
))
;; Apparently in perl land 1 byte and 2 byte values overflow and wrap arround
;; but 4 byte values don't. This is inconsistent and hard to match perfectly.
;; So cl-pack prevents all overflow and underflow pegging numbers at their
;; highest or lowest possible value as per perl's 4 byte behaviour
(deftest pack-signed ()
(check
(string= (unpack "B*" (pack "c" 255)) "11111111")
(string= (unpack "B*" (pack "c" 256)) "11111111")
(string= (unpack "B*" (pack "c" -128)) "10000000")
(string= (unpack "B*" (pack "c" -129)) "10000000")))
(deftest unpack-signed ()
(check
(= (unpack "c" (pack "c" -1)) -1)
(= (unpack "c" (pack "c" -129)) -128)
(= (unpack "c" (pack "c" 127)) 127)
(= (unpack "c" (pack "c" 128)) -128)))
;;; Test that weird things in form are still handled ok
(deftest pack-form ()
(check
(string= (pack "Kc" #x41 #x42) "A"))) ; unknown character
(deftest unpack-form ()
(check
(= (unpack "Kc" "AB") #x41))) ; unknown character
(deftest mod-! ()
(check
(= (unpack "n!" (pack "n" -1)) -1) ; n! is signed
))
(deftest mod-<> ()
(check
(string= (pack "l>" #x41424344) "ABCD")
(string= (pack "l<" #x41424344) "DCBA")
(= (unpack "l<" (pack "V" #x41424344)) #x41424344)
(= (unpack "l>" (pack "N" #x41424344)) #x41424344)
))