From 65e88f70b99f9973153f59154bac1861305b065c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 15:45:27 -0500
Subject: [PATCH 1/8] Make counter runnable to demonstrate web app deployment
---
extra/webapps/counter/counter.factor | 19 +++++++++++++++++++
1 file changed, 19 insertions(+)
diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor
index f3efb3868f..a0ee3a1b29 100644
--- a/extra/webapps/counter/counter.factor
+++ b/extra/webapps/counter/counter.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: math kernel accessors http.server http.server.dispatchers
furnace furnace.actions furnace.sessions furnace.redirection
html.components html.forms html.templates.chloe
@@ -28,3 +30,20 @@ M: counter-app init-session* drop 0 count sset ;
[ 1- ] <counter-action> "dec" add-responder
<display-action> "" add-responder
<sessions> ;
+
+! Deployment example
+USING: db.sqlite db.tuples db furnace.db namespaces ;
+
+: counter-db ( -- params db ) "counter.db" sqlite-db ;
+
+: init-counter-db ( -- )
+ counter-db [ session ensure-table ] with-db ;
+
+: run-counter ( -- )
+ init-counter-db
+ <counter-app>
+ counter-db <db-persistence>
+ main-responder set-global
+ 8080 httpd ;
+
+MAIN: run-counter
From 90e440bf60ccfdc5164a4a81971166b28249b600 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 15:45:45 -0500
Subject: [PATCH 2/8] Fix html.elements load problem
---
basis/html/elements/elements.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor
index ab9d987b67..ad75b58df3 100644
--- a/basis/html/elements/elements.factor
+++ b/basis/html/elements/elements.factor
@@ -48,8 +48,6 @@ IN: html.elements
!
! <input "text" =type "name" =name "20" =size input/>
-: elements-vocab ( -- vocab-name ) "html.elements" ;
-
SYMBOL: html
: write-html ( str -- )
@@ -60,6 +58,8 @@ SYMBOL: html
<<
+: elements-vocab ( -- vocab-name ) "html.elements" ;
+
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
From 5647d08f5905b8b35d539ffbef7ffed64e044c6b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 15:46:02 -0500
Subject: [PATCH 3/8] Fix some farkup bugs
---
basis/farkup/farkup-docs.factor | 6 +-
basis/farkup/farkup-tests.factor | 4 ++
basis/farkup/farkup.factor | 103 ++++++++++++++++---------------
3 files changed, 61 insertions(+), 52 deletions(-)
diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor
index f2d53d2362..6e7a5ddcb0 100644
--- a/basis/farkup/farkup-docs.factor
+++ b/basis/farkup/farkup-docs.factor
@@ -9,7 +9,7 @@ HELP: write-farkup
{ $values { "string" string } }
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
-HELP: farkup ( string -- farkup )
+HELP: parse-farkup ( string -- farkup )
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
@@ -18,7 +18,7 @@ HELP: (write-farkup)
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
-"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsection heading1 }
{ $subsection heading2 }
{ $subsection heading3 }
@@ -44,7 +44,7 @@ $nl
{ $subsection convert-farkup }
{ $subsection write-farkup }
"The syntax tree of a piece of Farkup can also be inspected and modified:"
-{ $subsection farkup }
+{ $subsection parse-farkup }
{ $subsection (write-farkup) }
{ $subsection "farkup-ast" } ;
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index e25fa34960..cc032913b7 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -118,3 +118,7 @@ link-no-follow? off
] unit-test
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
+
+[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+
+[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 4d6ac127ad..cc56f48949 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -1,29 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators html.elements io io.streams.string
-kernel math memoize namespaces peg peg.ebnf prettyprint
-sequences sequences.deep strings xml.entities vectors splitting
-xmode.code2html ;
+USING: accessors arrays combinators html.elements io
+io.streams.string kernel math memoize namespaces peg peg.ebnf
+prettyprint sequences sequences.deep strings xml.entities
+vectors splitting xmode.code2html urls ;
IN: farkup
SYMBOL: relative-link-prefix
SYMBOL: disable-images?
SYMBOL: link-no-follow?
-TUPLE: heading1 obj ;
-TUPLE: heading2 obj ;
-TUPLE: heading3 obj ;
-TUPLE: heading4 obj ;
-TUPLE: strong obj ;
-TUPLE: emphasis obj ;
-TUPLE: superscript obj ;
-TUPLE: subscript obj ;
-TUPLE: inline-code obj ;
-TUPLE: paragraph obj ;
-TUPLE: list-item obj ;
-TUPLE: list obj ;
-TUPLE: table obj ;
-TUPLE: table-row obj ;
+TUPLE: heading1 child ;
+TUPLE: heading2 child ;
+TUPLE: heading3 child ;
+TUPLE: heading4 child ;
+TUPLE: strong child ;
+TUPLE: emphasis child ;
+TUPLE: superscript child ;
+TUPLE: subscript child ;
+TUPLE: inline-code child ;
+TUPLE: paragraph child ;
+TUPLE: list-item child ;
+TUPLE: list child ;
+TUPLE: table child ;
+TUPLE: table-row child ;
TUPLE: link href text ;
TUPLE: image href text ;
TUPLE: code mode string ;
@@ -34,7 +34,7 @@ TUPLE: code mode string ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" last-split1 swap or ] unless ;
-EBNF: farkup
+EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
@@ -65,7 +65,7 @@ subscript = "~" (!("~" | nl).)+ "~"
inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
-escaped-char = "\" . => [[ second ]]
+escaped-char = "\" . => [[ second 1string ]]
link-content = (!("|"|"]").)+
@@ -89,20 +89,26 @@ inline-tag = strong | emphasis | superscript | subscript | inline-code
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
-table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|'
+cell = (!(inline-delimiter | '|' | nl).)+
+ => [[ >string ]]
+
+table-column = (list | cell | inline-tag | inline-delimiter ) '|'
=> [[ first ]]
table-row = "|" (table-column)+
=> [[ second table-row boa ]]
table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
=> [[ table boa ]]
-paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+
+text = (!(nl | code | heading | inline-delimiter | table ).)+
+ => [[ >string ]]
+
+paragraph-item = (table | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item?
| paragraph-item)
=> [[ paragraph boa ]]
-
-list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)*
+
+list-item = '-' (cell | inline-tag)*
=> [[ second list-item boa ]]
list = ((list-item nl)+ list-item? | list-item)
=> [[ list boa ]]
@@ -136,7 +142,7 @@ stand-alone
: write-link ( href text -- )
escape-link
- [ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
+ [ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
@@ -146,7 +152,7 @@ stand-alone
<strong> "Images are not allowed" write </strong>
] [
escape-link
- [ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
+ [ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
] if ;
: render-code ( string mode -- string' )
@@ -161,31 +167,30 @@ GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; inline
-M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ;
-M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ;
-M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ;
-M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ;
-M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ;
-M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ;
-M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ;
-M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ;
-M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ;
-M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ;
+M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
+M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
+M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
+M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
+M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
+M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
+M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
+M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
+M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
+M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
+M: list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
+M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
+M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
+M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
+M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
M: table-row (write-farkup) ( obj -- )
- obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ;
-M: fixnum (write-farkup) ( obj -- ) write1 ;
-M: string (write-farkup) ( obj -- ) write ;
-M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ;
-M: f (write-farkup) ( obj -- ) drop ;
+ child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
+M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
+M: string (write-farkup) escape-string write ;
+M: vector (write-farkup) [ (write-farkup) ] each ;
+M: f (write-farkup) drop ;
: write-farkup ( string -- )
- farkup (write-farkup) ;
+ parse-farkup (write-farkup) ;
: convert-farkup ( string -- string' )
- farkup [ (write-farkup) ] with-string-writer ;
+ parse-farkup [ (write-farkup) ] with-string-writer ;
From ad1c520d13ad01d40617b80783e7866e0ecf4acf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 15:46:12 -0500
Subject: [PATCH 4/8] Fix stack effects
---
basis/urls/urls.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index e16f62d1f1..4f2639975b 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -14,7 +14,7 @@ IN: urls
[ letter? ]
[ LETTER? ]
[ digit? ]
- [ "/_-." member? ]
+ [ "/_-.:" member? ]
} 1|| ; foldable
<PRIVATE
@@ -25,7 +25,7 @@ IN: urls
PRIVATE>
-: url-encode ( str -- str )
+: url-encode ( str -- encoded )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
@@ -58,7 +58,7 @@ PRIVATE>
PRIVATE>
-: url-decode ( str -- str )
+: url-decode ( str -- decoded )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
<PRIVATE
From a3dcbb43a979a9060a954d8dd6eaf6d39c51e4fe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 16:36:31 -0500
Subject: [PATCH 5/8] Fix validation-messages tag
---
basis/furnace/actions/actions.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor
index cce098f208..6e55ca44a0 100755
--- a/basis/furnace/actions/actions.factor
+++ b/basis/furnace/actions/actions.factor
@@ -14,7 +14,8 @@ html.elements
html.components
html.components
html.templates.chloe
-html.templates.chloe.syntax ;
+html.templates.chloe.syntax
+html.templates.chloe.compiler ;
IN: furnace.actions
SYMBOL: params
@@ -29,7 +30,8 @@ SYMBOL: rest
</ul>
] unless-empty ;
-CHLOE: validation-messages drop render-validation-messages ;
+CHLOE: validation-messages
+ drop [ render-validation-messages ] [code] ;
TUPLE: action rest authorize init display validate submit ;
From 0f284816c1fd90cbd7d09bbeb8b090022bdf7771 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 16:37:27 -0500
Subject: [PATCH 6/8] Fix docs
---
core/sequences/sequences-docs.factor | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 789837ea47..b8be31c55c 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -1356,16 +1356,18 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
{ $subsection slice }
{ $subsection slice? }
-"Creating slices:"
+"Extracting a slice:"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
-{ $subsection but-last-slice }
-{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
+"Removing the first or last element:"
+{ $subsection rest-slice }
+{ $subsection but-last-slice }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
+{ $subsection unclip-last-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
From 7b8be1222f87475b8aae1dd648aa369542d6fe70 Mon Sep 17 00:00:00 2001
From: "U-WSCHLIEP-PC\\wschliep" <wschliep@wschliep-pc.(none)>
Date: Fri, 19 Sep 2008 18:32:49 -0400
Subject: [PATCH 7/8] irc.client: Got rid of the annoying 100% CPU
---
extra/irc/client/client.factor | 13 ++++++-------
1 file changed, 6 insertions(+), 7 deletions(-)
mode change 100644 => 100755 extra/irc/client/client.factor
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
old mode 100644
new mode 100755
index 2474fd643a..76382edf1b
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -91,8 +91,6 @@ SYMBOL: current-irc-client
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: listener> ( name -- listener/f ) irc> listeners>> at ;
-: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
- [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
GENERIC: to-listener ( message obj -- )
@@ -294,14 +292,14 @@ DEFER: (connect-irc)
[ (reader-loop) ] [ handle-disconnect ] recover t ;
: writer-loop ( -- ? )
- irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
+ irc> out-messages>> mailbox-get handle-outgoing-irc t ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- ? )
- irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
+ irc> in-messages>> mailbox-get handle-incoming-irc t ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
@@ -314,9 +312,10 @@ DEFER: (connect-irc)
: listener-loop ( name -- ? )
dup listener> [
- out-messages>> [ maybe-annotate-with-name
- irc> out-messages>> mailbox-put ] with
- maybe-mailbox-get t
+ out-messages>> mailbox-get
+ maybe-annotate-with-name
+ irc> out-messages>> mailbox-put
+ t
] [ drop f ] if* ;
: spawn-irc-loop ( quot: ( -- ? ) name -- )
From 19b2f6a6f31c70c77a51959d008f2d536267c4f3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 19 Sep 2008 17:48:32 -0500
Subject: [PATCH 8/8] Fix farkup tests
---
basis/farkup/farkup-tests.factor | 6 ++----
1 file changed, 2 insertions(+), 4 deletions(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index cc032913b7..571d333359 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -11,13 +11,11 @@ link-no-follow? off
[ "Baz" ] [ "Baz" simple-link-title ] unit-test
[ ] [
- "abcd-*strong*\nasdifj\nweouh23ouh23"
- "paragraph" \ farkup rule parse drop
+ "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop
] unit-test
[ ] [
- "abcd-*strong*\nasdifj\nweouh23ouh23\n"
- "paragraph" \ farkup rule parse drop
+ "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop
] unit-test
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test