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

fixed https://github.com/dballard/cl-pack/issues/4 ; version bump to 1.0

This commit is contained in:
Dan Ballard 2018-04-10 16:52:15 -07:00
parent f079626bcb
commit 8e68493603
4 changed files with 55 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
README.md
View File

@ -3,7 +3,7 @@ cl-pack
[www.cliki.net/cl-pack](http://www.cliki.net/cl-pack) [www.cliki.net/cl-pack](http://www.cliki.net/cl-pack)
cl-pack supplies Perl/PHP/Ruby/Python compatible `pack()` and `unpack()` functions to allow easy use of (binary format) protocols and files with the above mentioned languages and C. cl-pack was released by Dan Ballard under the BSD-3-Clause license. cl-pack supplies Perl/PHP/Ruby/Python compatible `pack()` and `unpack()` functions to allow easy use of (binary format) protocols and files with the above mentioned languages and C. cl-pack was released by Dan Ballard <dan@mindstab.net> under the BSD-3-Clause license.
The purpose of cl-pack is to take native Lisp data like numbers, floats, and strings and encode it in a safe binary format in string that can then be written to a file or exchanged with another program while unpack can extract data from binary formats and protocols. The purpose of cl-pack is to take native Lisp data like numbers, floats, and strings and encode it in a safe binary format in string that can then be written to a file or exchanged with another program while unpack can extract data from binary formats and protocols.
@ -30,6 +30,6 @@ cl-pack is available in [QuickLisp](https://www.quicklisp.org/beta/)
Nearly every feature except a few esoteric ones are supported, check the documentation inside cl-pack.lisp if in doubt and if a feature you need isn't currently supported feel free to contact me and I'll see if I can add it. Nearly every feature except a few esoteric ones are supported, check the documentation inside cl-pack.lisp if in doubt and if a feature you need isn't currently supported feel free to contact me and I'll see if I can add it.
**Note** I think the 0.2 release is about as feature complete as I feel I need to get at the moment so I'm pushing it out. If there are not major complaints, then in a bit it will be re-released as 1.0, and if there are complaints, well more code and another pre-1.0 release :smile: **Note** I think the this release is about as feature complete as I feel I need to get at the moment so I'm pushing it out.
**Cavets** cl-pack was developed on an x86 running Ubuntu with SBCL. It should be endian safe where required and conform to host CPU endianness where required but I haven't been able to test on anything but x86. I would hope that it would work with most Lisps out there. Please feel free to get a hold of me if you have issues that need fixing. **Cavets** cl-pack was developed on an x86 running Ubuntu with SBCL. It should be endian safe where required and conform to host CPU endianness where required but I haven't been able to test on anything but x86. I would hope that it would work with most Lisps out there. Please feel free to get a hold of me if you have issues that need fixing.

2
cl-pack.asd
View File

@ -21,7 +21,7 @@
(defsystem #:cl-pack (defsystem #:cl-pack
:name "cl-pack" :name "cl-pack"
:author "Dan Ballard <dan@mindstab.net>" :author "Dan Ballard <dan@mindstab.net>"
:version "0.2" :version "1.0"
:licence "BSD-3-Clause" :licence "BSD-3-Clause"
:description "Perl compatible binary pack() and unpack() library" :description "Perl compatible binary pack() and unpack() library"
:depends-on (:ieee-floats) :depends-on (:ieee-floats)

83
cl-pack.lisp
View File

@ -380,7 +380,7 @@
(let ((offset 1) (let ((offset 1)
(inner-length 0) (inner-length 0)
(repeater-star nil) (repeater-star nil)
(repeater 0) (repeater nil)
(mod-! nil) (mod-! nil)
(mod-> nil) (mod-> nil)
(mod-< nil) (mod-< nil)
@ -403,14 +403,14 @@
(multiple-value-bind (repeater-count repeater-chars) (multiple-value-bind (repeater-count repeater-chars)
(if (>= (length str) 1) (if (>= (length str) 1)
(parse-integer str :junk-allowed t) (parse-integer str :junk-allowed t)
(values 0 0)) (values nil 0))
(if (eql repeater-count nil) (if (and (>= (length str) 1) (eql repeater-count nil))
;; no repeater #, check for other modifiers ( * ! < > ) ;; no repeater #, check for other modifiers ( * ! < > )
(case (char str 0) (case (char str 0)
(#\! (progn (setf mod-! t) (incf offset))) (#\! (progn (setf mod-! t) (incf offset)))
(#\> (progn (setf mod-> t) (incf offset))) (#\> (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 repeater-star t) (incf offset)))
(#\/ (progn (#\/ (progn
(setf /-pos offset) (setf /-pos offset)
;; a/N... we need offset to point to after N... ;; a/N... we need offset to point to after N...
@ -419,10 +419,8 @@
)) ))
) )
(progn ; repeater-count == # (progn ; repeater-count == #
(if (> repeater-count 0) (setf repeater repeater-count)) (if repeater-count (setf repeater repeater-count))
(incf offset repeater-chars)) (incf offset repeater-chars))
))) )))
@ -430,7 +428,7 @@
(let ((new-form form)) (let ((new-form form))
(inc-form) (inc-form)
(if (or repeater-star (> repeater 1)) (if (or repeater-star (and repeater (> repeater 1)))
(setf new-form (concatenate 'string (setf new-form (concatenate 'string
(subseq form 0 (if (> inner-length 0) (+ 2 inner-length) 1)) (subseq form 0 (if (> inner-length 0) (+ 2 inner-length) 1))
(if mod-! "!" "") (if mod-! "!" "")
@ -441,7 +439,8 @@
(write-to-string (1- repeater))) (write-to-string (1- repeater)))
(subseq form offset)))) (subseq form offset))))
(progn ,@body)))))) (progn
,@body))))))
(defmacro gen-modifiers-list () (defmacro gen-modifiers-list ()
@ -478,7 +477,6 @@
(second rest) (second rest)
"") "")
;;; BODY ;;; BODY
;; Extra optional keyed parameters ;; Extra optional keyed parameters
;; :result result is the result so far of the pack operation ;; :result result is the result so far of the pack operation
@ -504,15 +502,13 @@
(setf rest (rest (rest rest))))) (setf rest (rest (rest rest)))))
(otherwise (setf end? t)))) (otherwise (setf end? t))))
;; Instead of passing a series of arguments, you can call it with a destructable list of arguments ;; Instead of passing a series of arguments, you can call it with a destructable list of arguments
(let ((dlist-arg-style nil)) (let ((dlist-arg-style nil))
(if (and (>= 1 (length rest)) (listp (first rest))) (if (and (>= 1 (length rest)) (listp (first rest)))
(progn (progn
(setf dlist-arg-style t) (setf dlist-arg-style t)
(setf rest (first rest)))) (setf rest (first rest))
))
;; second end test (redundant a little, can we merge? ;; 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)))) (if (and (or (eql nil rest) (equal '(nil) rest)) (and (not (eql (strhead form) #\x)) (not (eql (strhead form) #\X))))
@ -522,15 +518,23 @@
;; set up of required endian functions ;; set up of required endian functions
(let ((bytes-to-string-fn #'bytes-to-string-rev) ; LITTLE ENDIAN (let ((bytes-to-string-fn #'bytes-to-string-rev) ; LITTLE ENDIAN
(item (first rest)) (item (first rest))
(new-rest (rest rest))) ; default rest for numbers (new-result nil)
(new-rest rest))
#+big-endian(setf bytes-to-string-fn #'bytes-to-string) ; BIG ENDIAN #+big-endian(setf bytes-to-string-fn #'bytes-to-string) ; BIG ENDIAN
(if mod-> (if mod->
(setf bytes-to-string-fn #'bytes-to-string)) (setf bytes-to-string-fn #'bytes-to-string))
(if mod-< (if mod-<
(setf bytes-to-string-fn #'bytes-to-string-rev)) (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 ;; pack case satement
(let ((new-result (setf new-result
;; FORM of: sequence length / sequence items ;; FORM of: sequence length / sequence items
(if (> /-pos 0) (if (> /-pos 0)
@ -556,7 +560,6 @@
(inc-form) (inc-form)
(concatenate 'string (pack (subseq form 0 /-pos) consumed-length) ret))) (concatenate 'string (pack (subseq form 0 /-pos) consumed-length) ret)))
;; ALL other FORMS ;; ALL other FORMS
(case (strhead form) (case (strhead form)
(#\n ;Unsigned Short 16bit Big Endian AB=AB (#\n ;Unsigned Short 16bit Big Endian AB=AB
@ -585,7 +588,6 @@
;; crash :( ;; crash :(
;; (string (code-char item ))) ;; (string (code-char item )))
((#\s #\S) ;signed/unsigned short 16bit ((#\s #\S) ;signed/unsigned short 16bit
(pack-int 2 :native)) (pack-int 2 :native))
@ -662,7 +664,7 @@
"" ""
)) ))
((#\. #\@) ((#\. #\@)
;; . consume a numerical arg - null fill or truncate to that position ;; . consume a numerical arg - null fill or truncate to that position
;; @ null fill or truncate to repeater specified position ;; @ null fill or truncate to repeater specified position
(let ((position item)) ; . (let ((position item)) ; .
@ -682,28 +684,24 @@
(setf new-rest rest) ; for dlist-style carry on (setf new-rest rest) ; for dlist-style carry on
ret)) ret))
(otherwise (progn (otherwise (progn
(setf new-rest rest) ; didn't do anything, don't consume anything (setf new-rest rest) ; didn't do anything, don't consume anything
""))))) ""))))
) ;; let () ) ;; (setf new-result)
;(format t "~a~%" new-result)
;; if using a descructable arg list ;; if using a descructable arg list
(if dlist-arg-style (if dlist-arg-style
(progn (progn
(if (not (equal rest new-rest)) ; consumed an arg (if (not (equal rest new-rest)) ; consumed an arg
(progn (progn
;; so remove the arg from the arg list ;; so remove the arg from the arg list
(setf (car rest) (second rest)) (setf (car rest) (second rest))
(setf (cdr rest) (rest (rest rest))))) (setf (cdr rest) (rest (rest rest)))))
;; regardless, continue using the dlist style ;; regardless, continue using the dlist style
(setf new-rest (list rest)))) (setf new-rest (list rest))))))
;; Recursion for the rest of pack ;; Recursion for the rest of pack
(apply #'pack (append (list new-form :result (concatenate 'string result new-result) :modifiers modifiers) new-rest))))))))) (apply #'pack (append (list new-form :result (concatenate 'string result new-result) :modifiers modifiers) new-rest))))))))
;; macro for unpack. ;; macro for unpack.
;; cuts out and returns part of a string to be used for processing while setting ;; cuts out and returns part of a string to be used for processing while setting
@ -718,7 +716,7 @@
;;; form: a string of characters corresonding to decodings ;;; form: a string of characters corresonding to decodings
;;; string: a string of binary data to be decoded ;;; string: a string of binary data to be decoded
;;; consumed: optional key parameter. If nil (default) nothing happens ;;; consumed: optional key parameter. If nil (default) nothing happens
;;; if an integer, ever byte consumed increments consumed ;;; if an integer, every byte consumed increments consumed
;;; and it is the last value return in the values list ;;; and it is the last value return in the values list
;;; returns: the decoded data in specified format ;;; returns: the decoded data in specified format
(def-form-parser unpack (string &key (consumed nil) (modifiers nil)) (def-form-parser unpack (string &key (consumed nil) (modifiers nil))
@ -742,13 +740,16 @@
(if mod-< (if mod-<
(setf string-to-bytes-fn #'string-to-bytes-rev)) (setf string-to-bytes-fn #'string-to-bytes-rev))
;; pack case statement and recursive call to unpack ;; unpack case statement and recursive call to unpack
;; note: not tail optiomized :fix ? ;; note: not tail optiomized :fix ?
(apply #'values (apply #'values
(remove nil (append (remove nil (append
(if (or (not repeater) (> repeater 0))
(progn
(if (not repeater) (setf repeater 0))
(if (> /-pos 0) (if (> /-pos 0)
(progn (progn
(let* ((length-item (subseq form 0 /-pos)) (let* ((length-item (subseq form 0 /-pos))
(sequence-item (subseq form (1+ /-pos) offset)) (sequence-item (subseq form (1+ /-pos) offset))
@ -803,7 +804,6 @@
(coerce '(#\null #\space) 'string) (coerce '(#\null #\space) 'string)
""))) "")))
(unpack-string (repeater repeater-star) (unpack-string (repeater repeater-star)
(string-trim special-chars (cut-str string (length string) new-str)) (string-trim special-chars (cut-str string (length string) new-str))
(string-trim special-chars (cut-str string (min repeater (length string)) new-str)) (string-trim special-chars (cut-str string (min repeater (length string)) new-str))
@ -835,8 +835,7 @@
) )
(otherwise nil) (otherwise nil)
))) )))))
;; result of recursion ;; result of recursion
(multiple-value-list (unpack new-form new-str :consumed consumed :modifiers modifiers))) :from-end t :count 1)))) (multiple-value-list (unpack new-form new-str :consumed consumed :modifiers modifiers))) :from-end t :count 1))))

5
tests.lisp
View File

@ -164,6 +164,10 @@
(equal (multiple-value-list (unpack "c*" "ABC")) '(#x41 #x42 #x43)) ; basic * repeater (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 "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 (equal (multiple-value-list (unpack "c2N" "ABCDEF")) '(#x41 #x42 #x43444546)) ; pick up after repeater
(equal (multiple-value-list (unpack "aa0aa" "ABCD")) '("A" "B" "C")) ; 0 means it skips
; https://github.com/dballard/cl-pack/issues/4
; test that unpack 0 consume 0
(equal (multiple-value-list (unpack "a0" "abc" :consumed 0)) '(0))
)) ))
(deftest unpack-strings () (deftest unpack-strings ()
@ -269,5 +273,4 @@
(equal (multiple-value-list (unpack "a/c" "3AB")) '(65 66)) (equal (multiple-value-list (unpack "a/c" "3AB")) '(65 66))
(equal (multiple-value-list (unpack "n/c" (concatenate 'string (string #\null) (string (code-char 3)) "ABC"))) '(65 66 67)) (equal (multiple-value-list (unpack "n/c" (concatenate 'string (string #\null) (string (code-char 3)) "ABC"))) '(65 66 67))
(equal (multiple-value-list (unpack "a/ac" "2ABC")) '("AB" 67)) (equal (multiple-value-list (unpack "a/ac" "2ABC")) '("AB" 67))
)) ))