;;;; Serialization/unserialization of PHP data types.
;;
;; Copyright (c) 2006-2007 Arto Bendiken <http://bendiken.net/>
;;
;; Permission is hereby granted, free of charge, to any person obtaining a copy
;; of this software and associated documentation files (the "Software"), to
;; deal in the Software without restriction, including without limitation the
;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;; IN THE SOFTWARE.

(module php-s11n
  ( php-serialize
    php-unserialize
    php-s11n-writer
    php-s11n-reader
    php-s11n-array-reader
    php-s11n-object-reader
    php-s11n-write
    php-s11n-read
    php-s11n-read-null
    php-s11n-read-boolean
    php-s11n-read-integer
    php-s11n-read-float
    php-s11n-read-string
    php-s11n-read-array
    php-s11n-read-array/alist
    php-s11n-read-array/hash-table
    php-s11n-read-object)

(import chicken scheme)
(use data-structures extras ports srfi-1 srfi-69 regex)

;;;; Exported parameters

(define php-s11n-writer        (make-parameter #f))
(define php-s11n-reader        (make-parameter #f))
(define php-s11n-array-reader  (make-parameter #f))
(define php-s11n-object-reader (make-parameter #f))

;;;; Internal parameters

(define php-s11n-read-table    (make-parameter '()))

;;;; Exported procedures

;;; Serialization and unserialization

;; See http://php.net/manual/en/function.serialize.php
(define (php-serialize value)
  (with-output-to-string (lambda () (php-s11n-write value))))

;; See http://php.net/manual/en/function.unserialize.php
(define (php-unserialize string)
  (call-with-input-string string php-s11n-read))

;;; Output

(define (php-s11n-write value #!optional (port (current-output-port)))
  (cond ((void? value) ; => NULL
         (fprintf port "N;"))
        ((boolean? value) ; => boolean
         (fprintf port "b:~A;" (if value 1 0)))
        ((integer? value) ; => integer
         (fprintf port "i:~A;" value))
        ((and (number? value) (inexact? value)) ; => float
         (fprintf port "d:~A;" value))
        ((char? value) ; => string
         (php-s11n-write (string value) port))
        ((symbol? value) ; => string
         (php-s11n-write (symbol->string value) port))
        ((string? value) ; => string
         (fprintf port "s:~A:~S;" (string-length value) value))
        ((vector? value) ; => array
         (fprintf port "a:~A:{" (vector-length value))
         (let loop ((i 0))
           (when (< i (vector-length value))
             (fprintf port "i:~A;" i)
             (php-s11n-write (vector-ref value i) port)
             (loop (+ i 1))))
         (fprintf port "}"))
        ((alist? value) ; => associative array
         (fprintf port "a:~A:{" (length value))
         (for-each (lambda (e)
                     (php-s11n-write (->array-key (car e)) port)
                     (php-s11n-write (cdr e) port))
                   value)
         (fprintf port "}"))
        ((hash-table? value) ; => associative array
         (php-s11n-write (hash-table->alist value) port))
        ((procedure? (php-s11n-writer))
         ((php-s11n-writer) value port))
        (else (error 'php-s11n-write "unable to serialize value" value))))

;;; Input

(define (php-s11n-read #!optional (port (current-input-port)))
  (let ((char (peek-char port)))
    (cond ((eof-object? char) (error 'php-s11n-read "unexpected end of input" port))
          ((assq char (php-s11n-read-table)) => (lambda (e) ((cdr e) port)))
          ((procedure? (php-s11n-reader)) ((php-s11n-reader) port))
          (else (error 'php-s11n-read "unable to unserialize value of type" char)))))

(define (php-s11n-read-null port)
  (expect-string port "N;")
  (void))

(define (php-s11n-read-boolean port)
  (string=? "1" (expect port "b:" #/[01]{1}/ ";")))

(define (php-s11n-read-integer port)
  (string->number (expect port "i:" #/[+\-\de]+/i ";")))

(define (php-s11n-read-float port)
  (string->number (expect port "d:" #/[+\-\d\.enan]+/i ";")))

(define (php-s11n-read-string port)
  (let ((length (string->number (expect port "s:" #/\d+/ ":"))))
    (expect-char port #\")
    (let ((value (read-string length port)))
      (expect-char port #\")
      (expect-char port #\;)
      value)))

(define (php-s11n-read-array port)
  (let ((array (php-s11n-read-array/alist port)))
    (cond ((vector-like-array? array)
           (list->vector (map cdr array)))
          (else array))))

(define (php-s11n-read-array/alist port)
  (let ((length (string->number (expect port "a:" #/\d+/ ":"))))
    (expect-char port #\{)
    (let loop ((i 0) (values '()))
      (if (= i length)
          (begin (expect-char port #\})
                 (reverse values))
          (loop (+ i 1)
                (cons (cons (php-s11n-read port)
                            (php-s11n-read port))
                      values))))))

(define (php-s11n-read-array/hash-table port)
  (alist->hash-table (php-s11n-read-array/alist port)))

(define (php-s11n-read-object port)
  (error 'php-s11n-read "object unserialization not supported"))

;;;; Initialization

(begin
  (php-s11n-array-reader php-s11n-read-array)
  (php-s11n-object-reader php-s11n-read-object)
  (php-s11n-read-table
    `((#\N . ,php-s11n-read-null)
      (#\b . ,php-s11n-read-boolean)
      (#\i . ,php-s11n-read-integer)
      (#\d . ,php-s11n-read-float)
      (#\s . ,php-s11n-read-string)
      (#\a . ,(lambda (port) ((php-s11n-array-reader) port)))
      (#\O . ,(lambda (port) ((php-s11n-object-reader) port))))))

;;;; Internal procedures

;;; Lexer implementation

(define (expect-char port char)
  (if (eq? (peek-char port) char)
      (read-char port)
      (error 'php-s11n-read (sprintf "expected character: ~S but got: ~S"
                            char (peek-char port)))))

(define (expect-string port string)
  (for-each (lambda (char)
              (expect-char port char))
            (string->list string))
  string)

(define (expect-regex port regex)
  (let loop ((buffer '()))
    (let ((char (peek-char port)))
      (if (not (string-match regex (string char)))
          (list->string (reverse buffer))
          (loop (cons (read-char port) buffer))))))

(define (expect port prelude regex terminator)
  (expect-string port prelude)
  (let ((value (expect-regex port regex)))
    (expect-string port terminator)
    value))

;;; General helpers

(define (void? x) (eq? x (void)))

(define (alist? x)
  (and (proper-list? x)
       (every pair? x)))

(define (integer-like-string? x)
  (and (string? x)
       (string-match #/^[1-9][0-9]*$/ x)))

(define (vector-like-array? x)
  (let ((keys (map car x)))
    (and (every integer? keys)
         (equal? (iota (length x)) keys))))

;; See http://www.php.net/manual/en/language.types.array.php
(define (->array-key value)
  (cond ((void? value) "")
        ((integer? value) value)
        ((integer-like-string? value) (string->number value))
        ((string? value) value)
        ((flonum? value) (inexact->exact (floor value)))
        ((boolean? value) (if value 1 0))
        ((keyword? value) (->array-key (keyword->string value)))
        ((symbol? value) (->array-key (symbol->string value)))
        (else (->array-key (->string value))))) )