source: project/release/4/php-s11n/trunk/php-s11n.scm @ 15288

Last change on this file since 15288 was 15288, checked in by felix winkelmann, 10 years ago

ported to chicken 4 (thanks to Christian Kellermann)

File size: 7.8 KB
Line 
1;;;; Serialization/unserialization of PHP data types.
2;;
3;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
4;;
5;; Permission is hereby granted, free of charge, to any person obtaining a copy
6;; of this software and associated documentation files (the "Software"), to
7;; deal in the Software without restriction, including without limitation the
8;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
9;; sell copies of the Software, and to permit persons to whom the Software is
10;; furnished to do so, subject to the following conditions:
11;;
12;; The above copyright notice and this permission notice shall be included in
13;; all copies or substantial portions of the Software.
14;;
15;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
21;; IN THE SOFTWARE.
22
23(module php-s11n
24  ( php-serialize
25    php-unserialize
26    php-s11n-writer
27    php-s11n-reader
28    php-s11n-array-reader
29    php-s11n-object-reader
30    php-s11n-write
31    php-s11n-read
32    php-s11n-read-null
33    php-s11n-read-boolean
34    php-s11n-read-integer
35    php-s11n-read-float
36    php-s11n-read-string
37    php-s11n-read-array
38    php-s11n-read-array/alist
39    php-s11n-read-array/hash-table
40    php-s11n-read-object)
41
42(import chicken scheme)
43(use data-structures extras ports srfi-1 srfi-69 regex)
44
45;;;; Exported parameters
46
47(define php-s11n-writer        (make-parameter #f))
48(define php-s11n-reader        (make-parameter #f))
49(define php-s11n-array-reader  (make-parameter #f))
50(define php-s11n-object-reader (make-parameter #f))
51
52;;;; Internal parameters
53
54(define php-s11n-read-table    (make-parameter '()))
55
56;;;; Exported procedures
57
58;;; Serialization and unserialization
59
60;; See http://php.net/manual/en/function.serialize.php
61(define (php-serialize value)
62  (with-output-to-string (lambda () (php-s11n-write value))))
63
64;; See http://php.net/manual/en/function.unserialize.php
65(define (php-unserialize string)
66  (call-with-input-string string php-s11n-read))
67
68;;; Output
69
70(define (php-s11n-write value #!optional (port (current-output-port)))
71  (cond ((void? value) ; => NULL
72         (fprintf port "N;"))
73        ((boolean? value) ; => boolean
74         (fprintf port "b:~A;" (if value 1 0)))
75        ((integer? value) ; => integer
76         (fprintf port "i:~A;" value))
77        ((and (number? value) (inexact? value)) ; => float
78         (fprintf port "d:~A;" value))
79        ((char? value) ; => string
80         (php-s11n-write (string value) port))
81        ((symbol? value) ; => string
82         (php-s11n-write (symbol->string value) port))
83        ((string? value) ; => string
84         (fprintf port "s:~A:~S;" (string-length value) value))
85        ((vector? value) ; => array
86         (fprintf port "a:~A:{" (vector-length value))
87         (let loop ((i 0))
88           (when (< i (vector-length value))
89             (fprintf port "i:~A;" i)
90             (php-s11n-write (vector-ref value i) port)
91             (loop (+ i 1))))
92         (fprintf port "}"))
93        ((alist? value) ; => associative array
94         (fprintf port "a:~A:{" (length value))
95         (for-each (lambda (e)
96                     (php-s11n-write (->array-key (car e)) port)
97                     (php-s11n-write (cdr e) port))
98                   value)
99         (fprintf port "}"))
100        ((hash-table? value) ; => associative array
101         (php-s11n-write (hash-table->alist value) port))
102        ((procedure? (php-s11n-writer))
103         ((php-s11n-writer) value port))
104        (else (error 'php-s11n-write "unable to serialize value" value))))
105
106;;; Input
107
108(define (php-s11n-read #!optional (port (current-input-port)))
109  (let ((char (peek-char port)))
110    (cond ((eof-object? char) (error 'php-s11n-read "unexpected end of input" port))
111          ((assq char (php-s11n-read-table)) => (lambda (e) ((cdr e) port)))
112          ((procedure? (php-s11n-reader)) ((php-s11n-reader) port))
113          (else (error 'php-s11n-read "unable to unserialize value of type" char)))))
114
115(define (php-s11n-read-null port)
116  (expect-string port "N;")
117  (void))
118
119(define (php-s11n-read-boolean port)
120  (string=? "1" (expect port "b:" #/[01]{1}/ ";")))
121
122(define (php-s11n-read-integer port)
123  (string->number (expect port "i:" #/[+\-\de]+/i ";")))
124
125(define (php-s11n-read-float port)
126  (string->number (expect port "d:" #/[+\-\d\.enan]+/i ";")))
127
128(define (php-s11n-read-string port)
129  (let ((length (string->number (expect port "s:" #/\d+/ ":"))))
130    (expect-char port #\")
131    (let ((value (read-string length port)))
132      (expect-char port #\")
133      (expect-char port #\;)
134      value)))
135
136(define (php-s11n-read-array port)
137  (let ((array (php-s11n-read-array/alist port)))
138    (cond ((vector-like-array? array)
139           (list->vector (map cdr array)))
140          (else array))))
141
142(define (php-s11n-read-array/alist port)
143  (let ((length (string->number (expect port "a:" #/\d+/ ":"))))
144    (expect-char port #\{)
145    (let loop ((i 0) (values '()))
146      (if (= i length)
147          (begin (expect-char port #\})
148                 (reverse values))
149          (loop (+ i 1)
150                (cons (cons (php-s11n-read port)
151                            (php-s11n-read port))
152                      values))))))
153
154(define (php-s11n-read-array/hash-table port)
155  (alist->hash-table (php-s11n-read-array/alist port)))
156
157(define (php-s11n-read-object port)
158  (error 'php-s11n-read "object unserialization not supported"))
159
160;;;; Initialization
161
162(begin
163  (php-s11n-array-reader php-s11n-read-array)
164  (php-s11n-object-reader php-s11n-read-object)
165  (php-s11n-read-table
166    `((#\N . ,php-s11n-read-null)
167      (#\b . ,php-s11n-read-boolean)
168      (#\i . ,php-s11n-read-integer)
169      (#\d . ,php-s11n-read-float)
170      (#\s . ,php-s11n-read-string)
171      (#\a . ,(lambda (port) ((php-s11n-array-reader) port)))
172      (#\O . ,(lambda (port) ((php-s11n-object-reader) port))))))
173
174;;;; Internal procedures
175
176;;; Lexer implementation
177
178(define (expect-char port char)
179  (if (eq? (peek-char port) char)
180      (read-char port)
181      (error 'php-s11n-read (sprintf "expected character: ~S but got: ~S"
182                            char (peek-char port)))))
183
184(define (expect-string port string)
185  (for-each (lambda (char)
186              (expect-char port char))
187            (string->list string))
188  string)
189
190(define (expect-regex port regex)
191  (let loop ((buffer '()))
192    (let ((char (peek-char port)))
193      (if (not (string-match regex (string char)))
194          (list->string (reverse buffer))
195          (loop (cons (read-char port) buffer))))))
196
197(define (expect port prelude regex terminator)
198  (expect-string port prelude)
199  (let ((value (expect-regex port regex)))
200    (expect-string port terminator)
201    value))
202
203;;; General helpers
204
205(define (void? x) (eq? x (void)))
206
207(define (alist? x)
208  (and (proper-list? x)
209       (every pair? x)))
210
211(define (integer-like-string? x)
212  (and (string? x)
213       (string-match #/^[1-9][0-9]*$/ x)))
214
215(define (vector-like-array? x)
216  (let ((keys (map car x)))
217    (and (every integer? keys)
218         (equal? (iota (length x)) keys))))
219
220;; See http://www.php.net/manual/en/language.types.array.php
221(define (->array-key value)
222  (cond ((void? value) "")
223        ((integer? value) value)
224        ((integer-like-string? value) (string->number value))
225        ((string? value) value)
226        ((flonum? value) (inexact->exact (floor value)))
227        ((boolean? value) (if value 1 0))
228        ((keyword? value) (->array-key (keyword->string value)))
229        ((symbol? value) (->array-key (symbol->string value)))
230        (else (->array-key (->string value))))) )
Note: See TracBrowser for help on using the repository browser.