Added common-lisp/data-encoding/hexadecimal.lisp
[com-informatimago:com-informatimago.git] / common-lisp / data-encoding / hexadecimal.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               hexadecimal.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Encode and decode hexadecimal strings.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2013-10-06 <PJB> Created.
15 ;;;;BUGS
16 ;;;;LEGAL
17 ;;;;    AGPL3
18 ;;;;    
19 ;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
20 ;;;;    
21 ;;;;    This program is free software: you can redistribute it and/or modify
22 ;;;;    it under the terms of the GNU Affero General Public License as published by
23 ;;;;    the Free Software Foundation, either version 3 of the License, or
24 ;;;;    (at your option) any later version.
25 ;;;;    
26 ;;;;    This program is distributed in the hope that it will be useful,
27 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
28 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
29 ;;;;    GNU Affero General Public License for more details.
30 ;;;;    
31 ;;;;    You should have received a copy of the GNU Affero General Public License
32 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
33 ;;;;**************************************************************************
34
35 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.DATA-ENCODING.HEXADECIMAL"
36   (:use "COMMON-LISP")
37   (:export "BYTES-TO-HEXADECIMAL-STRING" "BYTES-FROM-HEXADECIMAL-STRING")
38   (:documentation
39    "
40
41 This package exports functions to encode and decode byte vector buffer
42 into hexadecimal strings.
43
44
45 License:
46
47     AGPL3
48     
49     Copyright Pascal J. Bourguignon 2013 - 2013
50     
51     This program is free software: you can redistribute it and/or modify
52     it under the terms of the GNU Affero General Public License as published by
53     the Free Software Foundation, either version 3 of the License, or
54     (at your option) any later version.
55     
56     This program is distributed in the hope that it will be useful,
57     but WITHOUT ANY WARRANTY; without even the implied warranty of
58     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
59     GNU Affero General Public License for more details.
60     
61     You should have received a copy of the GNU Affero General Public License
62     along with this program.
63     If not, see <http://www.gnu.org/licenses/>
64
65 "))
66 (in-package "COM.INFORMATIMAGO.COMMON-LISP.DATA-ENCODING.HEXADECIMAL")
67
68
69 (defun decode-byte (digit-per-byte byte-sex sex-width base input)
70   (let ((buffer (make-string digit-per-byte)))
71     (ecase byte-sex
72       (:big-endian
73        (loop
74          :for i :below digit-per-byte
75          :do (setf (aref buffer i) (read-char input))))
76       (:little-endian
77
78        ;; ddccbba --> abbccdd
79        (loop
80          :with s = 0
81          :with i = (- digit-per-byte sex-width)
82          :repeat digit-per-byte
83          :do
84          (setf (aref buffer i) (read-char input))
85          (incf i)
86          (incf s)
87          (when (<= sex-width s)
88            (setf s 0)
89            (decf i (* 2 sex-width))
90            (when (minusp i)
91              (setf i 0))))))
92     (parse-integer buffer :radix base :junk-allowed nil)))
93
94 (assert (= (with-input-from-string (input "0123456789abcdef")
95              (decode-byte 4 :big-endian 2 16 input))
96            #x0123))
97
98 (assert (= (with-input-from-string (input "0123456789abcdef")
99              (decode-byte 4 :little-endian 2 16 input))
100            #x2301))
101
102
103 (defun decode (string element-type digit-per-byte byte-sex sex-width base)
104   (let ((bytes (make-array (ceiling (length string) digit-per-byte)
105                            :element-type (or element-type
106                                              (list 'unsigned-byte
107                                                    (integer-length (1- (expt base digit-per-byte))))))))
108     (with-input-from-string (input string)
109       (loop
110         :for i :below (length bytes)
111         :do (setf (aref bytes i) (decode-byte digit-per-byte byte-sex sex-width base input))))
112     bytes))
113
114 (assert (string=
115          (map 'string 'code-char (decode "6b7569706572"
116                                          '(unsigned-byte 8)
117                                          2 :big-endian 1 16))
118          "kuiper"))
119 (assert (string=
120          (map 'string 'code-char (decode "4d49542d4d414749432d434f4f4b49452d31"
121                                          '(unsigned-byte 8)
122                                          2 :big-endian 1 16))
123          "MIT-MAGIC-COOKIE-1"))
124
125
126
127
128
129
130 (defun encode-byte (byte padding byte-sex sex-width base case output)
131   (let ((digits (format nil (if (eq case :downcase)
132                               "~(~V,V,'0R~)"
133                               "~:@(~V,V,'0R~)") base padding byte)))
134     (ecase byte-sex
135       (:big-endian
136        (princ digits output))
137       (:little-endian
138        (loop
139          :for end :from (length digits) :by (- sex-width)
140          :for start = (max 0 (- end sex-width))
141          :while (plusp end)
142          :do (princ (subseq digits start end) output))))))
143
144 (assert (string= (with-output-to-string (output)
145                    (encode-byte #xbabeface00 10 :little-endian 4 16 :upcase output))
146                  "CE00BEFABA"))
147
148
149 (defun encode (byte-vector padding byte-sex sex-width base case)
150   (with-output-to-string (output)
151     (loop
152       :with byte-type = (array-element-type byte-vector)
153       :for byte :across byte-vector
154       :do (encode-byte byte padding byte-sex sex-width base case output))))
155
156
157 (assert (string= (encode #(#xba #xbe #xfa #xce) 2 :little-endian 1 16 :downcase)
158           "abebafec"))
159 (assert (string= (encode #(#xbabeface #xb19b00b5 #xdeadface) 12 :little-endian 2 16 :downcase)
160                  "cefabeba0000b5009bb10000cefaadde0000"))
161
162
163 (defun validate-integer (object)
164   (check-type object integer)
165   object)
166
167 (defun parse-element-type (element-type)
168   (when (atom element-type)
169     (error "Expected an element-type specifying the byte size, not ~S." element-type))
170   (case (first element-type)
171     ((unsigned-byte)
172      (values (validate-integer (second element-type))
173              nil))
174     ((signed-byte
175       (values (validate-integer (second element-type))
176               t)))
177     ((integer)
178      (let ((lower (validate-integer (second element-type)))
179            (upper (validate-integer (third  element-type))))
180        (assert (<= lower upper) () "Invalid integer type ~S" element-type)
181        (if (minusp lower)
182          (values (1+ (integer-length (if (minusp upper)
183                                        (1- (abs lower))
184                                        (max (1- (abs lower)) upper))))
185                  t)
186          (values (integer-length (max (abs lower) (abs upper)))
187                  nil))))
188     (otherwise
189      (error "Expected an UNSIGNED-BYTE, SIGNED-BYTE or INTEGER element-type specifying the byte size, not ~S." element-type))))
190
191
192 ;; (parse-element-type '(integer 0 15))
193 ;; (parse-element-type '(integer -1 9))
194
195
196
197 (defun bytes-to-hexadecimal-string (byte-vector &key (element-type nil) (padding nil) (byte-sex :big-endian) (case :downcase))
198   "
199
200 ELEMENT-TYPE: The element-type of the BYTE-VECTOR (if NIL, then
201               (ARRAY-ELEMENT-TYPE BYTE-VECTOR) is used.
202
203 PADDING:      When NIL, the number of hexadecimal digits per byte is
204               the minimum required (a vector of (unsigned-byte 3)
205               would use one hexadecimal digit per element).  Otherwise
206               it's at least PADDING.
207
208 BYTE-SEX:     When more than one octet are needed to store the bytes,
209               they're ordered according to the byte-sex:
210
211                  :big-endian    most significant octets first.
212                  :little-endian least significant octets first.
213
214               Notice that the quads in the octets are always stored first.
215
216 RETURN:       A string containing the hexadecimal digits representing the vector.
217
218 "
219   (multiple-value-bind (bits signed)
220       (parse-element-type (or element-type (array-element-type byte-vector)))
221     (when signed (error "Not implemented yet"))
222     (encode byte-vector (or padding (ceiling bits 4)) byte-sex 2. 16. case)))
223
224
225 #-(and)
226 (bytes-to-hexadecimal-string (coerce (loop for i from 0 to 255 collect i) 'vector)
227                              :element-type '(unsigned-byte 8)
228                              :padding 4
229                              :byte-sex :little-endian
230                              :case :upcase)
231
232
233
234
235
236
237
238 (defun bytes-from-hexadecimal-string (string &key (element-type nil) (padding nil) (byte-sex :big-endian) (case :downcase))
239   "
240
241 ELEMENT-TYPE: The element-type of the BYTE-VECTOR (if NIL, then
242               (unsigned-byte 8) is used).
243
244 PADDING:      When NIL, the number of hexadecimal digits per byte is
245               the minimum required (a vector of (unsigned-byte 3)
246               would use one hexadecimal digit per element).  Otherwise
247               it's at least PADDING.
248
249 BYTE-SEX:     When more than one octet are needed to store the bytes,
250               they're ordered according to the byte-sex:
251
252                  :big-endian    most significant octets first.
253                  :little-endian least significant octets first.
254
255               Notice that the quads in the octets are always stored first.
256
257 RETURN:       A string containing the hexadecimal digits representing the vector.
258
259 "
260   (multiple-value-bind (bits signed) (parse-element-type (or element-type '(unsigned-byte 8)))
261     (when signed (error "Not implemented yet"))
262     (decode string
263             (or element-type '(unsigned-byte 8))
264             (or padding (ceiling bits 4))
265             byte-sex 2. 16.)))
266
267
268 (assert (equalp
269          (bytes-from-hexadecimal-string "4d49542d4d414749432d434f4f4b49452d31")
270          #(77 73 84 45 77 65 71 73 67 45 67 79 79 75 73 69 45 49)))
271
272 ;;;; THE END ;;;;