source: project/release/3/php-s11n/trunk/php-s11n.scm @ 9970

Last change on this file since 9970 was 9970, checked in by Kon Lovett, 12 years ago

Rel 1.0.1 w/ Explict use of SRFI 69.

File size: 7.9 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(require-extension srfi-1 srfi-69 regex)
24
25#+chicken
26(eval-when (compile)
27  (declare
28    (export php-serialize
29            php-unserialize
30            php-s11n-writer
31            php-s11n-reader
32            php-s11n-array-reader
33            php-s11n-object-reader
34            php-s11n-write
35            php-s11n-read
36            php-s11n-read-null
37            php-s11n-read-boolean
38            php-s11n-read-integer
39            php-s11n-read-float
40            php-s11n-read-string
41            php-s11n-read-array
42            php-s11n-read-array/alist
43            php-s11n-read-array/hash-table
44            php-s11n-read-object)))
45
46;;;; Exported parameters
47
48(define php-s11n-writer        (make-parameter #f))
49(define php-s11n-reader        (make-parameter #f))
50(define php-s11n-array-reader  (make-parameter #f))
51(define php-s11n-object-reader (make-parameter #f))
52
53;;;; Internal parameters
54
55(define php-s11n-read-table    (make-parameter '()))
56
57;;;; Exported procedures
58
59;;; Serialization and unserialization
60
61;; See http://php.net/manual/en/function.serialize.php
62(define (php-serialize value)
63  (with-output-to-string (lambda () (php-s11n-write value))))
64
65;; See http://php.net/manual/en/function.unserialize.php
66(define (php-unserialize string)
67  (call-with-input-string string php-s11n-read))
68
69;;; Output
70
71(define (php-s11n-write value #!optional (port (current-output-port)))
72  (cond ((void? value) ; => NULL
73         (fprintf port "N;"))
74        ((boolean? value) ; => boolean
75         (fprintf port "b:~A;" (if value 1 0)))
76        ((integer? value) ; => integer
77         (fprintf port "i:~A;" value))
78        ((and (number? value) (inexact? value)) ; => float
79         (fprintf port "d:~A;" value))
80        ((char? value) ; => string
81         (php-s11n-write (string value) port))
82        ((symbol? value) ; => string
83         (php-s11n-write (symbol->string value) port))
84        ((string? value) ; => string
85         (fprintf port "s:~A:~S;" (string-length value) value))
86        ((vector? value) ; => array
87         (fprintf port "a:~A:{" (vector-length value))
88         (let loop ((i 0))
89           (when (< i (vector-length value))
90             (fprintf port "i:~A;" i)
91             (php-s11n-write (vector-ref value i) port)
92             (loop (+ i 1))))
93         (fprintf port "}"))
94        ((alist? value) ; => associative array
95         (fprintf port "a:~A:{" (length value))
96         (for-each (lambda (e)
97                     (php-s11n-write (->array-key (car e)) port)
98                     (php-s11n-write (cdr e) port))
99                   value)
100         (fprintf port "}"))
101        ((hash-table? value) ; => associative array
102         (php-s11n-write (hash-table->alist value) port))
103        ((procedure? (php-s11n-writer))
104         ((php-s11n-writer) value port))
105        (else (error 'php-s11n-write "unable to serialize value" value))))
106
107;;; Input
108
109(define (php-s11n-read #!optional (port (current-input-port)))
110  (let ((char (peek-char port)))
111    (cond ((eof-object? char) (error 'php-s11n-read "unexpected end of input" port))
112          ((assq char (php-s11n-read-table)) => (lambda (e) ((cdr e) port)))
113          ((procedure? (php-s11n-reader)) ((php-s11n-reader) port))
114          (else (error 'php-s11n-read "unable to unserialize value of type" char)))))
115
116(define (php-s11n-read-null port)
117  (expect-string port "N;")
118  (void))
119
120(define (php-s11n-read-boolean port)
121  (string=? "1" (expect port "b:" #/[01]{1}/ ";")))
122
123(define (php-s11n-read-integer port)
124  (string->number (expect port "i:" #/[+\-\de]+/i ";")))
125
126(define (php-s11n-read-float port)
127  (string->number (expect port "d:" #/[+\-\d\.enan]+/i ";")))
128
129(define (php-s11n-read-string port)
130  (let ((length (string->number (expect port "s:" #/\d+/ ":"))))
131    (expect-char port #\")
132    (let ((value (read-string length port)))
133      (expect-char port #\")
134      (expect-char port #\;)
135      value)))
136
137(define (php-s11n-read-array port)
138  (let ((array (php-s11n-read-array/alist port)))
139    (cond ((vector-like-array? array)
140           (list->vector (map cdr array)))
141          (else array))))
142
143(define (php-s11n-read-array/alist port)
144  (let ((length (string->number (expect port "a:" #/\d+/ ":"))))
145    (expect-char port #\{)
146    (let loop ((i 0) (values '()))
147      (if (= i length)
148          (begin (expect-char port #\})
149                 (reverse values))
150          (loop (+ i 1)
151                (cons (cons (php-s11n-read port)
152                            (php-s11n-read port))
153                      values))))))
154
155(define (php-s11n-read-array/hash-table port)
156  (alist->hash-table (php-s11n-read-array/alist port)))
157
158(define (php-s11n-read-object port)
159  (error 'php-s11n-read "object unserialization not supported"))
160
161;;;; Initialization
162
163(begin
164  (php-s11n-array-reader php-s11n-read-array)
165  (php-s11n-object-reader php-s11n-read-object)
166  (php-s11n-read-table
167    `((#\N . ,php-s11n-read-null)
168      (#\b . ,php-s11n-read-boolean)
169      (#\i . ,php-s11n-read-integer)
170      (#\d . ,php-s11n-read-float)
171      (#\s . ,php-s11n-read-string)
172      (#\a . ,(lambda (port) ((php-s11n-array-reader) port)))
173      (#\O . ,(lambda (port) ((php-s11n-object-reader) port))))))
174
175;;;; Internal procedures
176
177;;; Lexer implementation
178
179(define (expect-char port char)
180  (if (eq? (peek-char port) char)
181      (read-char port)
182      (error 'php-s11n-read (sprintf "expected character: ~S but got: ~S"
183                            char (peek-char port)))))
184
185(define (expect-string port string)
186  (for-each (lambda (char)
187              (expect-char port char))
188            (string->list string))
189  string)
190
191(define (expect-regex port regex)
192  (let loop ((buffer '()))
193    (let ((char (peek-char port)))
194      (if (not (string-match regex (string char)))
195          (list->string (reverse buffer))
196          (loop (cons (read-char port) buffer))))))
197
198(define (expect port prelude regex terminator)
199  (expect-string port prelude)
200  (let ((value (expect-regex port regex)))
201    (expect-string port terminator)
202    value))
203
204;;; General helpers
205
206(define (void? x) (eq? x (void)))
207
208(define (alist? x)
209  (and (proper-list? x)
210       (every pair? x)))
211
212(define (integer-like-string? x)
213  (and (string? x)
214       (string-match #/^[1-9][0-9]*$/ x)))
215
216(define (vector-like-array? x)
217  (let ((keys (map car x)))
218    (and (every integer? keys)
219         (equal? (iota (length x)) keys))))
220
221;; See http://www.php.net/manual/en/language.types.array.php
222(define (->array-key value)
223  (cond ((void? value) "")
224        ((integer? value) value)
225        ((integer-like-string? value) (string->number value))
226        ((string? value) value)
227        ((flonum? value) (inexact->exact (floor value)))
228        ((boolean? value) (if value 1 0))
229        ((keyword? value) (->array-key (keyword->string value)))
230        ((symbol? value) (->array-key (symbol->string value)))
231        (else (->array-key (->string value)))))
Note: See TracBrowser for help on using the repository browser.