-- TEST telnetd should use multitasking\r
+- move <resource-stream> from parser\r
- quit responder breaks with multithreading\r
- nicer way to combine two paths\r
-- icons for file responder\r
- -1.1 3 ^ shouldn't give a complex number\r
- don't show listener on certain commands\r
- inferior hangs\r
public static void copy(InputStream in, OutputStream out)
throws IOException
{
- byte[] buf = new byte[4096];
+ try
+ {
+ byte[] buf = new byte[4096];
- int count;
+ int count;
- for(;;)
- {
- count = in.read(buf,0,buf.length);
- if(count == -1 || count == 0)
- break;
+ for(;;)
+ {
+ count = in.read(buf,0,buf.length);
+ if(count == -1 || count == 0)
+ break;
- out.write(buf,0,count);
+ out.write(buf,0,count);
+ }
+ }
+ finally
+ {
+ in.close();
+ out.close();
}
-
- in.close();
- out.close();
} //}}}
//{{{ readLine() method
int caret = textArea.getCaretPosition()
- textArea.getLineStartOffset(
textArea.getCaretLine());
+ if(caret == line.length())
+ caret--;
+
String noWordSep = textArea.getBuffer().getStringProperty(
"noWordSep");
int wordStart = TextUtilities.findWordStart(line,caret,
USE: inspect-responder
USE: quit-responder
USE: file-responder
+USE: resource-responder
USE: wiki-responder
-: no-such-responder ( -- )
- "404 No such responder" httpd-error ;
+#! Remove all existing responders, and create a blank
+#! responder table.
+global [ <namespace> "httpd-responders" set ] bind
-: default-responders ( -- )
- #! Remove all existing responders, and create a blank
- #! responder table.
- <namespace> [
- <responder> [
- "404" "responder" set
- [ drop no-such-responder ] "get" set
- ] extend "404" set
+<responder> [
+ "404" "responder" set
+ [ drop no-such-responder ] "get" set
+] extend add-responder
- <responder> [
- "test" "responder" set
- [ test-responder ] "get" set
- ] extend "test" set
+<responder> [
+ "test" "responder" set
+ [ test-responder ] "get" set
+] extend add-responder
- <responder> [
- "inspect" "responder" set
- [ inspect-responder ] "get" set
- "global" "default-argument" set
- ] extend "inspect" set
+<responder> [
+ "inspect" "responder" set
+ [ inspect-responder ] "get" set
+ "global" "default-argument" set
+] extend add-responder
- <responder> [
- "quit" "responder" set
- [ quit-responder ] "get" set
- ] extend "quit" set
+<responder> [
+ "quit" "responder" set
+ [ quit-responder ] "get" set
+] extend add-responder
- <responder> [
- "file" "responder" set
- [ file-responder ] "get" set
- [ file-responder ] "post" set
- [ file-responder ] "head" set
- ] extend "file" set
+<responder> [
+ "file" "responder" set
+ [ file-responder ] "get" set
+ [ file-responder ] "post" set
+ [ file-responder ] "head" set
+] extend add-responder
+
+<responder> [
+ "resource" "responder" set
+ [ resource-responder ] "get" set
+] extend add-responder
! <responder> [
! "wiki" "responder" set
! [ wiki-post-responder ] "post" set
! <namespace> "wiki" set
! "WikiHome" "default-argument" set
-! ] extend "wiki" set
- ] extend "httpd-responders" set ;
+! ] extend add-responder
: serving-path ( filename -- filename )
f>"" "doc-root" get swap cat2 ;
-: copy-and-close ( from -- )
- [ dupd "stdio" get fcopy ] [ >r fclose r> rethrow ] catch ;
-
: file-response ( mime-type length -- )
[,
unparse "Content-Length" swons ,
"Content-Type" swons ,
- ,] "200 OK" response ;
+ ,] "200 OK" response terpri ;
: serve-static ( filename mime-type -- )
over file-length file-response "method" get "head" = [
drop
] [
- <filebr> "stdio" get copy-and-close
+ <filebr> "stdio" get fcopy
] ifte ;
: serve-file ( filename -- )
serve-static
] ifte ;
-: directory-no/ ( -- )
- <% "request" get % CHAR: / %
- "raw-query" get [ CHAR: ? % % ] when*
- %> redirect ;
-
: list-directory ( directory -- )
serving-html
"method" get "head" = [
: serve-object ( filename -- )
dup directory? [ serve-directory ] [ serve-file ] ifte ;
-: file-responder ( filename method -- )
+: file-responder ( filename -- )
"doc-root" get [
serving-path dup exists? [
serve-object
] [
- 2drop "404 not found" httpd-error
+ drop "404 not found" httpd-error
] ifte
] [
- 2drop "404 doc-root not set" httpd-error
+ drop "404 doc-root not set" httpd-error
] ifte ;
--- /dev/null
+! cont-html v0.6
+!
+! Copyright (C) 2004 Chris Double.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: html
+USE: strings
+USE: lists
+USE: format
+USE: stack
+USE: combinators
+USE: stdio
+USE: namespaces
+USE: words
+USE: logic
+
+! These words are used to provide a means of writing
+! formatted HTML to standard output with a familiar 'html' look
+! and feel in the code.
+!
+! HTML tags can be used in a number of different ways. The highest
+! level involves a similar syntax to HTML:
+!
+! <p> "someoutput" write </p>
+!
+! <p> will outupt the opening tag and </p> will output the closing
+! tag with no attributes.
+!
+! <p class= "red" p> "someoutput" write </p>
+!
+! This time the opening tag does not have the '>'. It pushes
+! a namespace on the stack to hold the attributes and values.
+! Any attribute words used will store the attribute and values
+! in that namespace. After the attribute word should come the
+! value of that attribute. The next attribute word or
+! finishing word (which is the html word followed by '>')
+! will actually set the attribute to that value in the namespace.
+! The finishing word will print out the operning tag including
+! attributes.
+! Any writes after this will appear after the opening tag.
+!
+! Values for attributes can be used directly without any stack
+! operations:
+!
+! (url -- )
+! <a href= a> "Click me" write </a>
+!
+! (url -- )
+! <a href= "http://" swap cat2 a> "click" write </a>
+!
+! (url -- )
+! <a href= <% "http://" % % %> a> "click" write </a>
+!
+! Tags that have no 'closing' equivalent have a trailing tag/> form:
+!
+! <input type= "text" name= "name" size= "20" input/>
+
+: attrs>string ( alist -- string )
+ #! Convert the attrs alist to a string
+ #! suitable for embedding in an html tag.
+ nreverse <% [ dup car % "='" % cdr % "'" % ] each %> ;
+
+: write-attributes ( n: namespace -- )
+ #! With the attribute namespace on the stack, get the attributes
+ #! and write them to standard output. If no attributes exist, write
+ #! nothing.
+ "attrs" get [ " " write attrs>string write ] when* ;
+
+: store-prev-attribute ( n: tag value -- )
+ #! Assumes an attribute namespace is on the stack.
+ #! Gets the previous attribute that was used (if any)
+ #! and sets it's value to the current value on the stack.
+ #! If there is no previous attribute, no value is expected
+ #! on the stack.
+ "current-attribute" get [ swons "attrs" cons@ ] when* ;
+
+! HTML tag words
+!
+! Each closable HTML tag has four words defined. The example below is for
+! <p>:
+!
+! : <p> ( -- )
+! #! Writes the opening tag to standard output.
+! "<p>" write ;
+
+! : <p ( -- n: <namespace> )
+! #! Used for setting inline attributes. Prints out
+! #! an unclosed opening tag.
+! "<p" write <namespace> >n ;
+!
+! : p> ( n: <namespace> -- )
+! #! Used to close off inline attribute version of word.
+! #! Prints out attributes and closes opening tag.
+! store-prev-attribute write-attributes n> drop ">" write ;
+!
+! : </p> ( -- )
+! #! Write out the closing tag.
+! "</foo>" write ;
+!
+! Each open only HTML tag has only three words:
+!
+! : <input/> ( -- )
+! #! Used for printing the tag with no attributes.
+! "<input>" write ;
+!
+! : <input ( -- n: <namespace> )
+! #! Used for setting inline attributes.
+! "<input" write <namespace> >n ;
+!
+! : input/> ( n: <namespace> -- )
+! #! Used to close off inline attribute version of word
+! #! and print the tag/
+! store-prev-attribute write-attributes n> drop ">" write ;
+!
+! Each attribute word has the form xxxx= where 'xxxx' is the attribute
+! name. The example below is for href:
+!
+! : href= ( n: <namespace> optional-value -- )
+! store-prev-attribute "href" "current-attribute" set ;
+
+: create-word ( vocab name def -- )
+ #! Define 'word creating' word to allow
+ #! dynamically creating words.
+ >r swap create r> define-compound ;
+
+: def-for-html-word-<foo> ( name -- name quot )
+ #! Return the name and code for the <foo> patterned
+ #! word.
+ "<" swap ">" cat3 dup [ write ] cons ;
+
+: def-for-html-word-<foo ( name -- name quot )
+ #! Return the name and code for the <foo patterned
+ #! word.
+ "<" swap cat2 dup [ write <namespace> >n ] cons ;
+
+: def-for-html-word-foo> ( name -- name quot )
+ #! Return the name and code for the foo> patterned
+ #! word.
+ ">" cat2 [
+ store-prev-attribute write-attributes n> drop ">" write
+ ] ;
+
+: def-for-html-word-</foo> ( name -- name quot )
+ #! Return the name and code for the </foo> patterned
+ #! word.
+ <% "</" % % ">" % %> dup [ write ] cons ;
+
+: def-for-html-word-<foo/> ( name -- name quot )
+ #! Return the name and code for the <foo/> patterned
+ #! word.
+ <% "<" % dup % "/>" % %> swap
+ <% "<" % % ">" % %>
+ [ write ] cons ;
+
+: def-for-html-word-foo/> ( name -- name quot )
+ #! Return the name and code for the foo/> patterned
+ #! word.
+ "/>" cat2 [
+ store-prev-attribute write-attributes n> drop ">" write
+ ] ;
+
+: define-closed-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that closable HTML tag.
+ "html" swap
+ 2dup def-for-html-word-<foo> create-word
+ 2dup def-for-html-word-<foo create-word
+ 2dup def-for-html-word-foo> create-word
+ def-for-html-word-</foo> create-word ;
+
+: define-open-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that open HTML tag.
+ "html" swap
+ 2dup def-for-html-word-<foo/> create-word
+ 2dup def-for-html-word-<foo create-word
+ def-for-html-word-foo/> create-word ;
+
+: define-attribute-word ( name -- )
+ "html" swap dup "=" cat2 swap
+ [ store-prev-attribute ] cons reverse
+ [ "current-attribute" set ] append create-word ;
+
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
+
+! Define some attributes
+[
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "src"
+] [ define-attribute-word ] each
#! Convert <, >, &, ' and " to HTML entities.
[ dup html-entities assoc dup rot ? ] str-map ;
-: opening-tag ( tag attrs -- )
- "<" % swap % [ " " % % ] when* ">" % ;
-
-: closing-tag ( tag -- )
- "</" % % ">" % ;
-
-: html-tag ( str tag attrs -- str )
- #! Wrap a string in an HTML tag.
- <% dupd opening-tag swap % closing-tag %> ;
-
: >hex-color ( triplet -- hex )
[ >hex 2 digits ] map "#" swons cat ;
: font-css% ( font -- )
"font-family: " % % "; " % ;
-: css-style% ( style -- )
- [
+: css-style ( style -- )
+ <% [
[ "fg" fg-css% ]
[ "bold" bold-css% ]
[ "italics" italics-css% ]
[ "underline" underline-css% ]
[ "size" size-css% ]
[ "font" font-css% ]
- ] assoc-apply ;
+ ] assoc-apply %> ;
-: span-tag ( string style -- string )
- "span" swap <% "style=\"" % css-style% "\"" % %> html-tag ;
-
-: link-tag ( string link -- string )
- url-encode "a" swap <% "href=" % unparse % %> html-tag ;
+: span-tag ( style quot -- )
+ over css-style dup "" = [
+ drop call
+ ] [
+ <span style= span> call </span>
+ ] ifte ;
: resolve-file-link ( path -- link )
#! The file responder needs relative links not absolute
] when* "/" ?str-tail drop ;
: file-link-href ( path -- href )
- <% "/file/" % resolve-file-link % %> ;
+ <% "/file/" % resolve-file-link url-encode % %> ;
-: object-link-href ( path -- href )
- <% "/inspect/" % % %> ;
+: file-link-tag ( style quot -- )
+ over "file-link" swap assoc [
+ <a href= file-link-href a> call </a>
+ ] [
+ call
+ ] ifte* ;
-: html-attr-string ( string style -- string )
- [ span-tag ] keep
- [
- [ "file-link" file-link-href link-tag ]
- [ "object-link" object-link-href link-tag ]
- ] assoc-apply ;
+: object-link-href ( path -- href )
+ "/inspect/" swap cat2 ;
+
+: object-link-tag ( style quot -- )
+ over "object-link" swap assoc [
+ <a href= object-link-href url-encode a> call </a>
+ ] [
+ call
+ ] ifte* ;
+
+: icon-tag ( string style quot -- )
+ over "icon" swap assoc dup [
+ <img src= "/resource/" swap cat2 img/>
+ #! Ignore the quotation, since no further style
+ #! can be applied
+ 3drop
+ ] [
+ drop call
+ ] ifte ;
: html-write-attr ( string style -- )
- swap chars>entities swap html-attr-string write ;
+ [
+ [
+ [
+ [ drop chars>entities write ] span-tag
+ ] file-link-tag
+ ] object-link-tag
+ ] icon-tag ;
: <html-stream> ( stream -- stream )
#! Wraps the given stream in an HTML stream. An HTML stream
] extend ;
: with-html-stream ( quot -- )
- [
- "stdio" get <html-stream> "stdio" set call
- ] with-scope ;
-
-: html-head ( title -- )
- "<html><head><title>" write
- dup write
- "</title></head><body><h1>" write write "</h1>" write ;
-
-: html-tail ( -- ) "</body></html>" print ;
+ [ "stdio" get <html-stream> "stdio" set call ] with-scope ;
: html-document ( title quot -- )
- swap chars>entities html-head call html-tail ;
-
-: preformatted-html ( quot -- )
- "<pre>" print call "</pre>" print ;
+ swap chars>entities dup
+ <html>
+ <head>
+ <title> write </title>
+ </head>
+ <body>
+ <h1> write </h1>
+ call
+ </body>
+ </html> ;
: simple-html-document ( title quot -- )
- swap [
- [ with-html-stream ] preformatted-html
- ] html-document ;
+ swap [ <pre> with-html-stream </pre> ] html-document ;
"Location" swons unit
"301 Moved Permanently" response terpri ;
+: directory-no/ ( -- )
+ <% "request" get % CHAR: / %
+ "raw-query" get [ CHAR: ? % % ] when*
+ %> redirect ;
+
: header-line ( alist line -- alist )
": " split1 dup [ transp acons ] [ 2drop ] ifte ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: resource-responder
+USE: combinators
+USE: files
+USE: httpd
+USE: httpd-responder
+USE: kernel
+USE: lists
+USE: logic
+USE: namespaces
+USE: parser
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+
+: resource-response ( mime-type -- )
+ "Content-Type" swons unit "200 OK" response terpri ;
+
+: serve-resource ( filename mime-type -- )
+ dup mime-type resource-response "method" get "head" = [
+ drop
+ ] [
+ <resource-stream> "stdio" get fcopy
+ ] ifte ;
+
+: resource-responder ( filename -- )
+ java? "resource-path" get or [
+ serve-resource
+ ] [
+ drop "404 resource-path not set" httpd-error
+ ] ifte ;
! Just a responder name by itself
drop "/" swap "/" cat3 redirect drop
] ifte ;
+
+: no-such-responder ( -- )
+ "404 No such responder" httpd-error ;
+
+: add-responder ( responder -- )
+ #! Add a responder object to the list.
+ "responder" over get* "httpd-responders" get set* ;
"wiki" get [ get ] bind ;
: write-wiki-page ( text -- )
- [ chars>entities wiki-word-links write ] preformatted-html ;
+ [ chars>entities wiki-word-links write ] call ;
: wiki-nodes ( -- alist )
"wiki" get [ vars-values ] bind ;
!!! HTTPD.
"/library/httpd/url-encoding.factor" run-resource ! url-encoding
+"/library/httpd/html-tags.factor" run-resource ! html
"/library/httpd/html.factor" run-resource ! html
"/library/httpd/http-common.factor" run-resource ! httpd
"/library/httpd/responder.factor" run-resource ! httpd-responder
"/library/httpd/inspect-responder.factor" run-resource ! inspect-responder
"/library/httpd/file-responder.factor" run-resource ! file-responder
"/library/httpd/quit-responder.factor" run-resource ! quit-responder
+"/library/httpd/resource-responder.factor" run-resource ! resource-responder
"/library/httpd/test-responder.factor" run-resource ! test-responder
"/library/httpd/wiki-responder.factor" run-resource ! wiki-responder
"/library/httpd/default-responders.factor" run-resource ! default-responders
init-stdio
init-environment
init-search-path
- init-scratchpad
- init-styles
- init-vocab-styles
"args" get parse-command-line
run-user-init
"/library/platform/native/cross-compiler.factor"
"/library/httpd/url-encoding.factor"
+ "/library/httpd/html-tags.factor"
"/library/httpd/html.factor"
"/library/httpd/http-common.factor"
"/library/httpd/responder.factor"
"/library/httpd/inspect-responder.factor"
"/library/httpd/test-responder.factor"
"/library/httpd/quit-responder.factor"
+ "/library/httpd/resource-responder.factor"
"/library/httpd/default-responders.factor"
"/library/jedit/jedit-no-local.factor"
] each
IN: init
-DEFER: finish-cold-boot
DEFER: warm-boot
-finish-cold-boot
: set-boot ( quot -- ) 8 setenv ;
[ warm-boot ] set-boot
"interactive" get [ init-interpreter ] when
0 exit* ;
-
-: finish-cold-boot ( -- )
- #! After the stage2 bootstrap is done, this word
- #! completes initialization.
- init-scratchpad
- init-styles
- init-vocab-styles
- default-responders ;
#! An initially-generated image has this as the boot
#! quotation.
boot
- "/library/platform/native/boot-stage2.factor" run-resource
- "finish-cold-boot" [ "init" ] search execute ;
+ "/library/platform/native/boot-stage2.factor" run-resource ;
dup wait-to-accept accept-fd ;
: blocking-copy ( in out -- )
- [ add-copy-io-task (yield) ] callcc0 ;
+ [ add-copy-io-task (yield) ] callcc0 2drop ;
: init-stdio ( -- )
stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
+: (fcopy) ( from to -- )
+ #! Copy the contents of the fd-stream 'from' to the
+ #! fd-stream 'to'. Use fcopy; this word does not close
+ #! streams.
+ "out" swap get* >r "in" swap get* r> blocking-copy ;
+
: fcopy ( from to -- )
#! Copy the contents of the fd-stream 'from' to the
#! fd-stream 'to'.
- "out" swap get* >r "in" swap get* r> blocking-copy ;
+ [ 2dup (fcopy) ] [ -rot fclose fclose rethrow ] catch ;
#! In a URL, can this character be used without
#! URL-encoding?
[
- [ letter? ] [ drop t ]
- [ LETTER? ] [ drop t ]
- [ digit? ] [ drop t ]
- [ "/_?" str-contains? ] [ drop t ]
- [ ] [ drop f ]
+ [ letter? ] [ drop t ]
+ [ LETTER? ] [ drop t ]
+ [ digit? ] [ drop t ]
+ [ "/_?." str-contains? ] [ drop t ]
+ [ ] [ drop f ]
] cond ;
! XXX: use object path...
"styles" get [ set ] bind ;
-: init-styles ( -- )
- <namespace> "styles" set
+<namespace> "styles" set
- [
- [ "font" | "Monospaced" ]
- ] "default" set-style
+[
+ [ "font" | "Monospaced" ]
+] "default" set-style
- [
- [ "bold" | t ]
- ] default-style append "prompt" set-style
-
- [
- [ "ansi-fg" | "0" ]
- [ "ansi-bg" | "2" ]
- [ "fg" | [ 255 0 0 ] ]
- ] default-style append "comments" set-style ;
+[
+ [ "bold" | t ]
+] default-style append "prompt" set-style
+
+[
+ [ "ansi-fg" | "0" ]
+ [ "ansi-bg" | "2" ]
+ [ "fg" | [ 255 0 0 ] ]
+] default-style append "comments" set-style
USE: streams
USE: strings
USE: test
+USE: stack
[
"<html>&'sgml'"
] [ "<html>&'sgml'" chars>entities ] unit-test
-[ "<span style=\"color: #ff00ff; font-family: Monospaced; \">car</span>" ]
-[
- "car"
- [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ]
- span-tag
-] unit-test
-
[ "/file/foo/bar" ]
[
[
"/home/slava/doc/foo/bar" file-link-href
] with-scope
] unit-test
+
+[ "<img src='/resource/library/icons/File.png'>" ]
+[
+ [
+ ""
+ [ [ "icon" | "library/icons/File.png" ] ]
+ [ drop ] icon-tag
+ ] with-string
+] unit-test
+
+[ "" ]
+[
+ [
+ [ ] [ drop ] span-tag
+ ] with-string
+] unit-test
+
+[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
+[
+ [
+ [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ]
+ [ drop "car" write ]
+ span-tag
+ ] with-string
+] unit-test
+
+[ "hello world" ]
+[
+ [ "hello world" [ ] html-write-attr ] with-string
+] unit-test
+
+[ "<span style='color: #ff00ff; font-family: Monospaced; '>car</span>" ]
+[
+ [
+ "car"
+ [ [ "fg" 255 0 255 ] [ "font" | "Monospaced" ] ]
+ html-write-attr
+ ] with-string
+] unit-test
+
+[
+ "<html><head><title>Foo</title></head><body><h1>Foo</h1></body></html>"
+] [
+ [
+ "Foo" [ ] html-document
+ ] with-string
+] unit-test
+
+[
+ "<html><head><title>Foo</title></head><body><h1>Foo</h1><pre>Hi</pre></body></html>"
+] [
+ [
+ "Foo" [ "Hi" write ] simple-html-document
+ ] with-string
+] unit-test
[ 5430 ]
[ f "Content-Length: 5430" header-line content-length ] unit-test
-[ "hello world" ] [ "hello+world" url-decode ] unit-test
-[ "hello world" ] [ "hello%20world" url-decode ] unit-test
-[ " ! " ] [ "%20%21%20" url-decode ] unit-test
-[ "hello world" ] [ "hello world%" url-decode ] unit-test
-[ "hello world" ] [ "hello world%x" url-decode ] unit-test
-[ "hello%20world" ] [ "hello world" url-encode ] unit-test
-[ "%20%21%20" ] [ " ! " url-encode ] unit-test
-
[ ] [ "404 not found" ] [ httpd-error ] test-word
[ "arg" ] [
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
[ "" ] [ "%XX%XX%X" url-decode ] unit-test
+
+[ "hello world" ] [ "hello+world" url-decode ] unit-test
+[ "hello world" ] [ "hello%20world" url-decode ] unit-test
+[ " ! " ] [ "%20%21%20" url-decode ] unit-test
+[ "hello world" ] [ "hello world%" url-decode ] unit-test
+[ "hello world" ] [ "hello world%x" url-decode ] unit-test
+[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "%20%21%20" ] [ " ! " url-encode ] unit-test
"words"
"scratchpad"
] "use" set ;
-
-: init-scratchpad ( -- )
- #! The contents of the scratchpad vocabulary is not saved
- #! between runs.
- <namespace> "scratchpad" "vocabularies" get set* ;
drop default-style
] ifte ;
-: init-vocab-styles ( -- )
- "styles" get [ <namespace> "vocabularies" set ] bind
+"styles" get [ <namespace> "vocabularies" set ] bind
- [
- [ "ansi-fg" | "1" ]
- [ "fg" | [ 204 0 0 ] ]
- ] "arithmetic" set-vocab-style
- [
- [ "ansi-fg" | "3" ]
- [ "fg" | [ 255 132 0 ] ]
- ] "combinators" set-vocab-style
- [
- [ "ansi-fg" | "5" ]
- [ "fg" | [ 102 0 204 ] ]
- ] "continuations" set-vocab-style
- [
- [ "ansi-fg" | "1" ]
- [ "fg" | [ 255 0 0 ] ]
- ] "errors" set-vocab-style
- [
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 153 102 255 ] ]
- ] "hashtables" set-vocab-style
- [
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 0 102 153 ] ]
- ] "lists" set-vocab-style
- [
- [ "ansi-fg" | "6" ]
- [ "fg" | [ 0 153 102 ] ]
- ] "logic" set-vocab-style
- [
- [ "ansi-fg" | "1" ]
- [ "fg" | [ 204 0 0 ] ]
- ] "math" set-vocab-style
- [
- [ "ansi-fg" | "6" ]
- [ "fg" | [ 0 153 255 ] ]
- ] "namespaces" set-vocab-style
- [
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 102 204 255 ] ]
- ] "parser" set-vocab-style
- [
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 102 204 255 ] ]
- ] "prettyprint" set-vocab-style
- [
- [ "ansi-fg" | "2" ]
- [ "fg" | [ 0 0 0 ] ]
- ] "stack" set-vocab-style
- [
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 204 0 204 ] ]
- ] "stdio" set-vocab-style
- [
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 102 0 204 ] ]
- ] "streams" set-vocab-style
- [
- [ "ansi-fg" | "6" ]
- [ "fg" | [ 255 0 204 ] ]
- ] "strings" set-vocab-style
- [
- [ "ansi-fg" | "4" ]
- [ "fg" | [ 102 204 255 ] ]
- ] "unparser" set-vocab-style
- [
- [ "ansi-fg" | "3" ]
- [ "fg" | [ 2 185 2 ] ]
- ] "vectors" set-vocab-style ;
+[
+ [ "ansi-fg" | "1" ]
+ [ "fg" | [ 204 0 0 ] ]
+] "arithmetic" set-vocab-style
+[
+ [ "ansi-fg" | "3" ]
+ [ "fg" | [ 255 132 0 ] ]
+] "combinators" set-vocab-style
+[
+ [ "ansi-fg" | "5" ]
+ [ "fg" | [ 102 0 204 ] ]
+] "continuations" set-vocab-style
+[
+ [ "ansi-fg" | "1" ]
+ [ "fg" | [ 255 0 0 ] ]
+] "errors" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 153 102 255 ] ]
+] "hashtables" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 0 102 153 ] ]
+] "lists" set-vocab-style
+[
+ [ "ansi-fg" | "6" ]
+ [ "fg" | [ 0 153 102 ] ]
+] "logic" set-vocab-style
+[
+ [ "ansi-fg" | "1" ]
+ [ "fg" | [ 204 0 0 ] ]
+] "math" set-vocab-style
+[
+ [ "ansi-fg" | "6" ]
+ [ "fg" | [ 0 153 255 ] ]
+] "namespaces" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 102 204 255 ] ]
+] "parser" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 102 204 255 ] ]
+] "prettyprint" set-vocab-style
+[
+ [ "ansi-fg" | "2" ]
+ [ "fg" | [ 0 0 0 ] ]
+] "stack" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 204 0 204 ] ]
+] "stdio" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 102 0 204 ] ]
+] "streams" set-vocab-style
+[
+ [ "ansi-fg" | "6" ]
+ [ "fg" | [ 255 0 204 ] ]
+] "strings" set-vocab-style
+[
+ [ "ansi-fg" | "4" ]
+ [ "fg" | [ 102 204 255 ] ]
+] "unparser" set-vocab-style
+[
+ [ "ansi-fg" | "3" ]
+ [ "fg" | [ 2 185 2 ] ]
+] "vectors" set-vocab-style
projects / factor.git / commitdiff