Changeset 2752 in project

Timestamp:

12/21/06 17:33:06 (12 years ago)

Author:

felix

Message:

hart and xml-rpc fixes

Files:

• doc-indices/chicken-setup.index (added)
• doc-indices/grovel (modified) (1 diff)
• hart/hart.scm (modified) (1 diff)
• hart/hart.setup (modified) (1 diff)
• wiki/Unit extras (modified) (2 diffs)
• wiki/faq (modified) (1 diff)
• wiki/fps (modified) (1 diff)
• wiki/syntactic-closures (modified) (1 diff)
• xml-rpc/hello-client.scm (modified) (1 diff)
• xml-rpc/hello.scm (modified) (1 diff)
• xml-rpc/xml-rpc-client.scm (modified) (1 diff)
• xml-rpc/xml-rpc-server-support.scm (modified) (5 diffs)
• xml-rpc/xml-rpc.html (modified) (1 diff)
• xml-rpc/xml-rpc.setup (modified) (1 diff)

doc-indices/grovel

@@ -4 +4 @@
 |#
 
-
 (use utils regex-case posix)
-
 
 (set-sharp-read-syntax! 

hart/hart.scm

@@ -1 @@
-(use srfi-1 hart-support)
-
-
 ;;;Hart macros.
 

hart/hart.setup

@@ -4 +4 @@
  'hart
  '("hart.scm" "hart-support.so")
- '((syntax) (require-at-runtime hart)))
+ '((syntax) (require-at-runtime hart-support)))
 

wiki/Unit extras

@@ -813 +813 @@
 
 
+==== any?
+
+ [procedure] (any? X)
+
+Ignores it's argument and always returns {{#t}}. This is actually useful sometimes.
+
 
 === Binary searching
@@ -826 +832 @@
 searched value is equal to the current item, negative if the searched
 value is ''less'' than the current item, and positive otherwise.
+Returns the index of the found value or {{#f}} otherwise.
 
 Previous: [[Unit eval]]

wiki/faq

@@ -458 +458 @@
 {{make-record-instance}}
 {{locative-ref}} {{locative-set!}} {{locative?}} {{locative->object}} {{identity}}
-{{cpu-time}} {{error}} {{call/cc}}
+{{cpu-time}} {{error}} {{call/cc}} {{any?}}
 
 == Garbage collection

wiki/fps

@@ -63 +63 @@
  (import fps)
 
+The same can be achieved with the {{modules}} egg (note that importing {{fps}} at top-level
+still clobbers some library functions).
+
 
 === Requirements

wiki/syntactic-closures

@@ -2 +2 @@
 
 == syntactic-closures
+
+An implementation of {{syntax-rules}} and a hygienic low-level
+macro system.
 
 === Usage

xml-rpc/hello-client.scm

@@ -4 +4 @@
 (define hello (srv "hello"))
 
-(print "-> " (hello (:optional (command-line-arguments) "you")))
+(for-each
+ (lambda (arg)
+   (print "-> " (hello arg)) )
+ (let ((args (command-line-arguments)))
+   (if (null? args)
+       '("you")
+       args) ) )
+

xml-rpc/hello.scm

@@ -4 +4 @@
   (sprintf "Hello, ~A!" var) )
 
-((http:make-server 4242))
+((http:make-server 4242) #t)

xml-rpc/xml-rpc-client.scm

@@ -15 +15 @@
 (define-constant fault-response-code 1)
 (define-constant invalid-response-format-code 2)
-(define-constant version "1.8")
+(define-constant version "1.13")
 
 (define xml-rpc:version 

xml-rpc/xml-rpc-server-support.scm

@@ -46 +46 @@
                       (with-input-from-string data (cut SSAX:XML->SXML (current-input-port) '())) 
                       data) ] )
-       (handle-exceptions ex
-           (write-fault-response ex)
+       (handle-exceptions ex (write-fault-response ex r)
          (match data
            [(or `(*TOP* (*PI* xml . ,_) (|methodCall| ,mname . ,params))
@@ -59 +58 @@
                        [`((params (param ,x) ...))
                         (receive results (call-proc m (map xml-rpc:unmarshall-value x))
-                          (write-result-response results) ) ]
+                          (write-result-response results r) ) ]
                        [() 
                         (receive results (call-proc m '())
-                          (write-result-response results) ) ]
+                          (write-result-response results r) ) ]
                        [r (xml-rpc:error invalid-parameter-format-code "invalid parameter format" r)] )
-                     (write-undefined-method-response name) ) ) ]
+                     (write-undefined-method-response name r) ) ) ]
               [r (xml-rpc:error invalid-rpc-format-code "invalid rpc format" r)] ) ]
            [r (xml-rpc:error invalid-rpc-format-code "invalid rpc format" r)] ) ) ) ) ) )
@@ -84 +83 @@
 (define exn-message (condition-property-accessor 'exn 'message))
 
-(define (write-response s)
-  (http:write-response-header)
+(define (write-response s req)
+  (http:write-response-header 
+   200 "OK" '() (current-output-port) 
+   (http:request-protocol req) )
   (printf "Content-type: text/xml\r\nContent-length: ~A\r\n\r\n~A"
           (string-length s)
           s) )
 
-(define (write-fault-response ex)
+(define (write-fault-response ex req)
   (let ([o (open-output-string)])
     (fprintf o #<<EOF
@@ -113 +114 @@
           (exn-message ex)
           (->string ex) ) )
-    (write-response (get-output-string o)) ) )
+    (write-response (get-output-string o) req) ) )
 
-(define (write-undefined-method-response name)
+(define (write-undefined-method-response name req)
   (write-fault-response
-   (make-property-condition 'exn 'message (sprintf "undefined method ~S" name)) ) )
+   (make-property-condition 'exn 'message (sprintf "undefined method ~S" name))
+   req) )
 
-(define (write-result-response results)
+(define (write-result-response results req)
   (let ([o (open-output-string)])
     (display "<?xml version=\"1.0\"?><methodResponse>" o)
@@ -129 +131 @@
       (display "</params>" o) )
     (display "</methodResponse>\n" o) 
-    (write-response (get-output-string o) ) ) )
+    (write-response (get-output-string o) req) ) )
 
 (define (xml-rpc:method-documentation name . url)

xml-rpc/xml-rpc.html

@@ -16 +16 @@
 <h3>Version:</h3>
 <ul>
+<li>1.13
+Server replies with proper protocol [guess who reported it?]
 <li>1.12
 Fixed another bug, again reported by Daishi

xml-rpc/xml-rpc.setup

@@ -14 +14 @@
  '("xml-rpc-server.scm" "xml-rpc-server-support.so" "xml-rpc-utils.so") 
  '((syntax) 
-   (documentation "xml-rpx.html") (version 1.12)
+   (documentation "xml-rpx.html") (version 1.13)
    (require-at-runtime xml-rpc-server-support)) )