Merge branch 'master' into new_ui

basis/help/handbook/handbook.factor

@@ -181,7 +181,6 @@ ARTICLE: "io" "Input and output"
 { $subsection "io.streams.plain" }
 { $subsection "io.streams.string" }
 { $subsection "io.streams.byte-array" }
-{ $subsection "io.streams.limited" }
 { $heading "Utilities" }
 { $subsection "stream-binary" }
 { $subsection "io.styles" }

basis/http/http.factor

@@ -213,12 +213,14 @@ body ;
     raw-response new
         "1.1" >>version ;
 
-TUPLE: post-data raw content content-type ;
+TUPLE: post-data raw content content-type form-variables uploaded-files ;
 
-: <post-data> ( raw content-type -- post-data )
+: <post-data> ( form-variables uploaded-files raw content-type -- post-data )
     post-data new
         swap >>content-type
-        swap >>raw ;
+        swap >>raw
+        swap >>uploaded-files
+        swap >>form-variables ;
 
 : parse-content-type-attributes ( string -- attributes )
     " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;

basis/http/server/server.factor

@@ -15,6 +15,8 @@ io.streams.limited
 io.servers.connection
 io.timeouts
 fry logging logging.insomniac calendar urls urls.encoding
+mime.multipart
+unicode.categories
 http
 http.parsers
 http.server.responses
@@ -36,17 +38,35 @@ IN: http.server
 : read-request-header ( request -- request )
     read-header >>header ;
 
-: parse-post-data ( post-data -- post-data )
-    [ ] [ raw>> ] [ content-type>> ] tri
-    "application/x-www-form-urlencoded" = [ query>assoc ] when
-    >>content ;
+ERROR: no-boundary ;
+
+: parse-multipart-form-data ( string -- separator )
+    ";" split1 nip
+    "=" split1 nip [ no-boundary ] unless* ;
+
+: read-multipart-data ( request -- form-variables uploaded-files )
+    [ "content-type" header ]
+    [ "content-length" header string>number ] bi
+    unlimit-input
+    stream-eofs limit-input
+    binary decode-input
+    parse-multipart-form-data parse-multipart ;
+
+: read-content ( request -- bytes )
+    "content-length" header string>number read ;
+
+: parse-content ( request content-type -- form-variables uploaded-files raw )
+    {
+        { "multipart/form-data" [ read-multipart-data f ] }
+        { "application/x-www-form-urlencoded" [ read-content [ f f ] dip ] }
+        [ drop read-content [ f f ] dip ]
+    } case ;
 
 : read-post-data ( request -- request )
     dup method>> "POST" = [
-        [ ]
-        [ "content-length" header string>number read ]
-        [ "content-type" header ] tri
-        <post-data> parse-post-data >>post-data
+        dup dup "content-type" header
+        [ ";" split1 drop parse-content ] keep
+        <post-data> >>post-data
     ] when ;
 
 : extract-host ( request -- request )
@@ -80,7 +100,7 @@ GENERIC: write-full-response ( request response -- )
     [ content-type>> "application/octet-stream" or ]
     [ content-charset>> encoding>name ]
     bi
-    [ "; charset=" swap 3append ] when* ;
+    [ "; charset=" glue ] when* ;
 
 : ensure-domain ( cookie -- cookie )
     [
@@ -236,7 +256,7 @@ TUPLE: http-server < threaded-server ;
 M: http-server handle-client*
     drop
     [
-        64 1024 * limit-input
+        64 1024 * stream-throws limit-input
         ?refresh-all
         [ read-request ] ?benchmark
         [ do-request ] ?benchmark

basis/io/streams/limited/limited-docs.factor

@@ -5,16 +5,23 @@ IN: io.streams.limited
 
 HELP: <limited-stream>
 { $values
-     { "stream" "an input stream" } { "limit" integer }
+     { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
      { "stream'" "an input stream" }
 }
-{ $description "Constructs a new " { $link limited-stream } " from an existing stream. Upon exhaustion, the stream will throw an error by default." }
+{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
+
+HELP: limit
+{ $values
+     { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
+     { "stream'" "a stream" }
+}
+{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
 { $examples "Throwing an exception:"
     { $example
         "USING: continuations io io.streams.limited io.streams.string"
         "kernel prettyprint ;"
         "["
-        "    \"123456\" <string-reader> 3 <limited-stream>"
+        "    \"123456\" <string-reader> 3 stream-throws limit"
         "    100 swap stream-read ."
         "] [ ] recover ."
         "T{ limit-exceeded }"
@@ -23,32 +30,34 @@ HELP: <limited-stream>
     { $example
         "USING: accessors continuations io io.streams.limited"
         "io.streams.string kernel prettyprint ;"
-        "\"123456\" <string-reader> 3 <limited-stream>"
-        "stream-eofs >>mode"
+        "\"123456\" <string-reader> 3 stream-eofs limit"
         "100 swap stream-read ."
         "\"123\""
     }
 } ;
 
-HELP: limit
+HELP: unlimit
 { $values
-     { "stream" "a stream" } { "limit" integer }
+     { "stream" "an input stream" }
      { "stream'" "a stream" }
 }
-{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." } ;
+{ $description "Returns the underlying stream of a limited stream." } ;
 
 HELP: limited-stream
 { $values
     { "value" "a limited-stream class" }
 }
-{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion. The default behavior is to throw an exception." } ;
+{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
 
 HELP: limit-input
 { $values
-     { "limit" integer }
+     { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
 }
 { $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
 
+HELP: unlimit-input
+{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
+
 HELP: stream-eofs
 { $values
     { "value" "a " { $link limited-stream } " mode singleton" }
@@ -64,13 +73,15 @@ HELP: stream-throws
 { stream-eofs stream-throws } related-words
 
 ARTICLE: "io.streams.limited" "Limited input streams"
-"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. The default behavior is to throw an error." $nl
-"Wrap an existing stream in a limited stream:"
-{ $subsection <limited-stream> }
+"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end." $nl
 "Wrap a stream in a limited stream:"
 { $subsection limit }
 "Wrap the current " { $link input-stream } " in a limited stream:"
 { $subsection limit-input }
+"Unlimits a limited stream:"
+{ $subsection unlimit }
+"Unlimits the current " { $link input-stream } ":"
+{ $subsection limit-input }
 "Make a limited stream throw an exception on exhaustion:"
 { $subsection stream-throws }
 "Make a limited stream return " { $link f } " on exhaustion:"

basis/io/streams/limited/limited-tests.factor

@@ -8,7 +8,7 @@ IN: io.streams.limited.tests
     ascii encode binary <byte-reader> "data" set
 ] unit-test
 
-[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
 
 [ CHAR: h ] [ "limited" get stream-read1 ] unit-test
 
@@ -25,7 +25,7 @@ IN: io.streams.limited.tests
     ascii encode binary <byte-reader> "data" set
 ] unit-test
 
-[ ] [ "data" get 7 <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
 
 [ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
 
@@ -34,22 +34,28 @@ IN: io.streams.limited.tests
 [ "he" CHAR: l ] [
     B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
     ascii <byte-reader> [
-        5 limit-input
+        5 stream-throws limit-input
         "l" read-until
     ] with-input-stream
 ] unit-test
 
 [ CHAR: a ]
-[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
+[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
 
 [ "abc" ]
 [
-    "abc" <string-reader> 3 <limited-stream> stream-eofs >>mode
+    "abc" <string-reader> 3 stream-eofs <limited-stream>
     4 swap stream-read
 ] unit-test
 
 [ f ]
 [
-    "abc" <string-reader> 3 <limited-stream> stream-eofs >>mode
+    "abc" <string-reader> 3 stream-eofs <limited-stream>
     4 over stream-read drop 10 swap stream-read
 ] unit-test
+
+[ t ]
+[
+    "abc" <string-reader> 3 stream-eofs limit unlimit
+    "abc" <string-reader> =
+] unit-test

basis/io/streams/limited/limited.factor

@@ -9,20 +9,27 @@ TUPLE: limited-stream stream count limit mode ;
 
 SINGLETONS: stream-throws stream-eofs ;
 
-: <limited-stream> ( stream limit -- stream' )
+: <limited-stream> ( stream limit mode -- stream' )
     limited-stream new
+        swap >>mode
         swap >>limit
         swap >>stream
-        0 >>count
-        stream-throws >>mode ;
+        0 >>count ;
 
-GENERIC# limit 1 ( stream limit -- stream' )
+GENERIC# limit 2 ( stream limit mode -- stream' )
 
-M: decoder limit [ clone ] dip [ limit ] curry change-stream ;
+M: decoder limit ( stream limit mode -- stream' )
+    [ clone ] 2dip '[ _ _ limit ] change-stream ;
 
-M: object limit <limited-stream> ;
+M: object limit ( stream limit mode -- stream' )
+    <limited-stream> ;
 
-: limit-input ( limit -- ) input-stream [ swap limit ] change ;
+: unlimit ( stream -- stream' )
+    [ stream>> ] change-stream ;
+
+: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
+
+: unlimit-input ( -- ) input-stream [ unlimit ] change ;
 
 ERROR: limit-exceeded ;
 

basis/mime/multipart/multipart-tests.factor

@@ -20,10 +20,11 @@ IN: mime.multipart.tests
 
 [ t ] [
     mime-test-stream [ upload-separator parse-multipart ] with-input-stream
-    drop "\"up.txt\"" swap key?
+    nip "\"up.txt\"" swap key?
 ] unit-test
 
 [ t ] [
     mime-test-stream [ upload-separator parse-multipart ] with-input-stream
-    nip "\"text1\"" swap key?
+    drop "\"text1\"" swap key?
 ] unit-test
+

basis/mime/multipart/multipart.factor

@@ -33,8 +33,8 @@ ERROR: bad-header bytes ;
 : mime-write ( sequence -- )
     >byte-array write ;
 
-: parse-headers ( string -- sequence )
-    string-lines harvest [ parse-header-line ] map ;
+: parse-headers ( string -- hashtable )
+    string-lines harvest [ parse-header-line ] map >hashtable ;
 
 ERROR: end-of-stream multipart ;
 
@@ -73,11 +73,14 @@ ERROR: end-of-stream multipart ;
     "\r\n\r\n" dump-string dup "--\r" = [
         drop
     ] [
-        parse-headers >hashtable >>header
+        parse-headers >>header
     ] if ;
 
+: empty-name? ( string -- ? )
+    { "''" "\"\"" "" f } member? ;
+
 : save-uploaded-file ( multipart -- )
-    dup filename>> empty? [
+    dup filename>> empty-name? [
         drop
     ] [
         [ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
@@ -86,9 +89,13 @@ ERROR: end-of-stream multipart ;
     ] if ;
 
 : save-form-variable ( multipart -- )
-    [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
-    [ name>> ]
-    [ form-variables>> set-at ] tri ;
+    dup name>> empty-name? [
+        drop
+    ] [
+        [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
+        [ name>> ]
+        [ form-variables>> set-at ] tri
+    ] if ;
 
 : dump-mime-file ( multipart filename -- multipart )
     binary <file-writer> [
@@ -132,19 +139,22 @@ ERROR: no-content-disposition multipart ;
         [ no-content-disposition ]
     } case ;
 
-: read-assert= ( string -- )
-    [ length read ] keep assert= ;
+: assert-sequence= ( a b -- )
+    2dup sequence= [ 2drop ] [ assert ] if ;
+
+: read-assert-sequence= ( sequence -- )
+    [ length read ] keep assert-sequence= ;
 
 : parse-beginning ( multipart -- multipart )
-    "--" read-assert=
+    "--" read-assert-sequence=
     dup mime-separator>>
-    [ read-assert= ]
+    [ read-assert-sequence= ]
     [ separator-prefix prepend >>mime-separator ] bi ;
 
 : parse-multipart-loop ( multipart -- multipart )
     read-header
     dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
 
-: parse-multipart ( sep -- uploaded-files form-variables )
+: parse-multipart ( separator -- form-variables uploaded-files )
     <multipart> parse-beginning parse-multipart-loop
-    [ uploaded-files>> ] [ form-variables>> ] bi ;
+    [ form-variables>> ] [ uploaded-files>> ] bi ;

extra/webapps/imagebin/imagebin.factor

@@ -23,11 +23,12 @@ SYMBOL: my-post-data
     <page-action>
         { imagebin "upload-image" } >>template
         [
-            request get post-data>> my-post-data set-global
+            
+            ! request get post-data>> my-post-data set-global
             ! image new
             !    "file" value
                 ! insert-tuple
-            ! "uploaded-image" <redirect>
+            "uploaded-image" <redirect>
         ] >>submit ;
 
 : <imagebin> ( -- responder )

misc/fuel/README

@@ -75,6 +75,7 @@ beast.
     - C-cz : switch to listener
     - C-co : cycle between code, tests and docs factor files
     - C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer)
+    - C-cr : switch to listener and refresh all loaded vocabs
     - C-x4s : switch to other factor buffer in other window
     - C-x5s : switch to other factor buffer in other frame
 
@@ -86,7 +87,7 @@ beast.
     - C-cC-ew : edit word (M-x fuel-edit-word-at-point)
     - C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point)
 
-    - C-cr, C-cC-er : eval region
+    - C-cC-er : eval region
     - C-M-r, C-cC-ee : eval region, extending it to definition boundaries
     - C-M-x, C-cC-ex : eval definition around point
     - C-ck, C-cC-ek : run file
@@ -110,6 +111,7 @@ beast.
 
     - TAB : complete word at point
     - M-. : edit word at point in Emacs
+    - C-cr : refresh all loaded vocabs
     - C-ca : toggle autodoc mode
     - C-cp : find words containing given substring (M-x fuel-apropos)
     - C-cs : toggle stack mode

misc/fuel/fuel-debug.el

@@ -1,6 +1,6 @@
 ;;; fuel-debug.el -- debugging factor code
 
-;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
 ;; See http://factorcode.org/license.txt for BSD license.
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
@@ -287,7 +287,8 @@ the debugger."
   (goto-char (point-min))
   (if (re-search-forward "^USING: " nil t)
       (let ((begin (point))
-            (end (or (and (re-search-forward "\\_<;\\_>") (point)) (point))))
+            (end (or (and (re-search-forward ";\\( \\|$\\)") (point))
+                     (point))))
         (kill-region begin end))
     (re-search-forward "^IN: " nil t)
     (beginning-of-line)

misc/fuel/fuel-font-lock.el

@@ -75,7 +75,7 @@
 (defun fuel-font-lock--syntactic-face (state)
   (if (nth 3 state) 'factor-font-lock-string
     (let ((c (char-after (nth 8 state))))
-      (cond ((char-equal c ?\ )
+      (cond ((or (char-equal c ?\ ) (char-equal c ?\n))
              (save-excursion
                (goto-char (nth 8 state))
                (beginning-of-line)

misc/fuel/fuel-listener.el

@@ -107,15 +107,9 @@ buffer."
     (goto-char (point-max))
     (unless seen (error "No prompt found!"))))
 
-(defun fuel-listener-nuke ()
-  (interactive)
-  (goto-char (point-max))
-  (comint-kill-region comint-last-input-start (point))
-  (comint-redirect-cleanup)
-  (fuel-con--setup-connection fuel-listener--buffer))
 
 
-;;; Interface: starting fuel listener
+;;; Interface: starting and interacting with fuel listener:
 
 (defalias 'switch-to-factor 'run-factor)
 (defalias 'switch-to-fuel-listener 'run-factor)
@@ -129,6 +123,23 @@ buffer."
         (pop-to-buffer buf)
       (switch-to-buffer buf))))
 
+(defun fuel-listener-nuke ()
+  "Try this command if the listener becomes unresponsive."
+  (interactive)
+  (goto-char (point-max))
+  (comint-kill-region comint-last-input-start (point))
+  (comint-redirect-cleanup)
+  (fuel-con--setup-connection fuel-listener--buffer))
+
+(defun fuel-refresh-all ()
+  "Switch to the listener buffer and invokes Factor's refresh-all.
+With prefix, you're teletransported to the listener's buffer."
+  (interactive)
+  (let ((buf (process-buffer (fuel-listener--process))))
+    (pop-to-buffer buf)
+    (comint-send-string nil "\"Refreshing loaded vocabs...\" write nl flush")
+    (comint-send-string nil " refresh-all \"Done!\" write nl flush\n")))
+
 
 ;;; Completion support
 
@@ -172,6 +183,7 @@ buffer."
 (define-key fuel-listener-mode-map "\C-a" 'fuel-listener--bol)
 (define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode)
 (define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
+(define-key fuel-listener-mode-map "\C-cr" 'fuel-refresh-all)
 (define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode)
 (define-key fuel-listener-mode-map "\C-cp" 'fuel-apropos)
 (define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)

misc/fuel/fuel-mode.el

@@ -175,7 +175,7 @@ interacting with a factor listener is at your disposal.
 
 (fuel-mode--key-1 ?k 'fuel-run-file)
 (fuel-mode--key-1 ?l 'fuel-run-file)
-(fuel-mode--key-1 ?r 'fuel-eval-region)
+(fuel-mode--key-1 ?r 'fuel-refresh-all)
 (fuel-mode--key-1 ?z 'run-factor)
 (fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
 (define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)

misc/fuel/fuel-syntax.el

@@ -252,8 +252,9 @@
     ;; Multiline constructs
     ("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
     ("\\_<USING:\\( \\)" (1 "<b"))
-    ("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\)" (1 "<b"))
-    ("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\)\\([^<\n]\\|\\_>\\)" (2 "<b"))
+    ("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
+    ("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)"
+     (2 "<b"))
     ("\\(\n\\| \\);\\_>" (1 ">b"))
     ;; Let and lambda:
     ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))