steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-04-15 22:34:59 -05:00
parent defc1cfae9 783d0d613d
commit 6937e9b367
108 changed files with 1765 additions and 805 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
README.txt
View File

@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself.
* Contents
- Platform support
- Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image
@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself.
- Source organization
- Community
* Platform support
Factor supports the following platforms:
Linux/x86
Linux/AMD64
Linux/PowerPC
Linux/ARM
Mac OS X/x86
Mac OS X/PowerPC
FreeBSD/x86
FreeBSD/AMD64
OpenBSD/x86
OpenBSD/AMD64
Solaris/x86
Solaris/AMD64
MS Windows/x86 (XP and above)
MS Windows CE/ARM
Please donate time or hardware if you wish to see Factor running on
other platforms. In particular, we are interested in:
Windows/AMD64
Mac OS X/AMD64
Solaris/UltraSPARC
Linux/MIPS
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
3.3 or earlier. If you are using gcc 4.3, you might get an unusable
Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
command-line arguments for make.
Factor supports various platforms. For an up-to-date list, see
<http://factorcode.org/getfactor.fhtml>.
Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
targets and build options. Then run 'make' with the appropriate target
for your platform.
Factor requires gcc 3.4 or later.
On x86, Factor /will not/ build using gcc 3.3 or earlier.
If you are using gcc 4.3, you might get an unusable Factor binary unless
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
arguments for make.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
Compilation will yield an executable named 'factor' on Unix,
'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Libraries needed for compilation
For X11 support, you need recent development libraries for libc, Freetype,
X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
you can use the line
For X11 support, you need recent development libraries for libc,
Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
(like Ubuntu), you can use the line
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
to grab everything (if you're on a non-debian-derived distro please tell us
what the equivalent command is on there and it can be added :)
to grab everything (if you're on a non-debian-derived distro please tell
us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image
The boot images are no longer included with the Factor distribution
due to size concerns. Instead, download a boot image from:
http://factorcode.org/images/
Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
Once you download the right image, bootstrap the system with the
Boot images can be obtained from <http://factorcode.org/images/latest/>.
Once you download the right image, bootstrap Factor with the
following command line:
./factor -i=boot.<cpu>.image
Or this command for Mac OS X systems:
./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
@ -122,9 +91,8 @@ The latter keeps the terminal listener running.
* Running Factor on Mac OS X - Cocoa UI
On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
terminal listener. If you are using Mac OS X 10.3, you can only run the
X11 UI, as documented in the next section.
On Mac OS X, a Cocoa UI is available in addition to the terminal
listener.
The 'factor' executable runs the terminal listener:
@ -136,17 +104,16 @@ contains factor.image and the library sources.
* Running Factor on Mac OS X - X11 UI
The X11 UI is available on Mac OS X, however its use is not recommended
since it does not integrate with the host OS. However, if you are
running Mac OS X 10.3, it is your only choice.
The X11 UI is also available on Mac OS X, however its use is not
recommended since it does not integrate with the host OS.
When compiling Factor, pass the X11=1 parameter:
make macosx-ppc X11=1
make X11=1
Then bootstrap with the following switches:
./factor -i=boot.ppc.image -ui-backend=x11
./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI.
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
factor-nt.exe -i=boot.x86.32.image
factor.exe -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
To run the listener in the command prompt:
factor-nt.exe -run=listener
factor.exe -run=listener
* The Factor FAQ
The Factor FAQ lives online at http://factorcode.org/faq.fhtml
The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
* Command line usage
The Factor VM supports a number of command line switches. To read
command line usage documentation, either enter the following in the UI
listener:
Factor supports a number of command line switches. To read command line
usage documentation, enter the following in the UI listener:
"command-line" about
* Source organization
The following two directories are managed by the module system; consult
the documentation for details:
The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor
core/ - Factor core library and compiler
extra/ - more libraries
The following directories contain additional files:
misc/ - editor modes, icons, etc
vm/ - sources for the Factor runtime, written in C
fonts/ - TrueType fonts used by UI
misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help!
vm/ - sources for the Factor VM, written in C
* Community

6
core/alien/c-types/c-types.factor
View File

@ -18,12 +18,12 @@ boxer prep unboxer
getter setter
reg-class size align stack-align? ;
: construct-c-type ( class -- type )
: new-c-type ( class -- type )
new
int-regs >>reg-class ;
: <c-type> ( -- type )
\ c-type construct-c-type ;
\ c-type new-c-type ;
SYMBOL: c-types
@ -189,7 +189,7 @@ DEFER: >c-ushort-array
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type )
long-long-type construct-c-type ;
long-long-type new-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;

9
core/assocs/assocs-docs.factor
View File

@ -76,7 +76,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
{ $see-also key? } ;
{ $see-also key? assoc-contains? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
@ -97,6 +97,7 @@ $nl
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-subset }
{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Three additional combinators:"
{ $subsection cache }
@ -206,9 +207,13 @@ HELP: assoc-subset
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
HELP: assoc-contains?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }

18
core/bootstrap/primitives.factor
View File

@ -390,7 +390,7 @@ define-builtin
! Create special tombstone values
"tombstone" "hashtables.private" create
"tuple" "kernel" lookup
tuple
{ } define-tuple-class
"((empty))" "hashtables.private" create
@ -403,7 +403,7 @@ define-builtin
! Some tuple classes
"hashtable" "hashtables" create
"tuple" "kernel" lookup
tuple
{
{
{ "array-capacity" "sequences.private" }
@ -424,7 +424,7 @@ define-builtin
} define-tuple-class
"sbuf" "sbufs" create
"tuple" "kernel" lookup
tuple
{
{
{ "string" "strings" }
@ -440,7 +440,7 @@ define-builtin
} define-tuple-class
"vector" "vectors" create
"tuple" "kernel" lookup
tuple
{
{
{ "array" "arrays" }
@ -456,7 +456,7 @@ define-builtin
} define-tuple-class
"byte-vector" "byte-vectors" create
"tuple" "kernel" lookup
tuple
{
{
{ "byte-array" "byte-arrays" }
@ -472,7 +472,7 @@ define-builtin
} define-tuple-class
"bit-vector" "bit-vectors" create
"tuple" "kernel" lookup
tuple
{
{
{ "bit-array" "bit-arrays" }
@ -488,7 +488,7 @@ define-builtin
} define-tuple-class
"float-vector" "float-vectors" create
"tuple" "kernel" lookup
tuple
{
{
{ "float-array" "float-arrays" }
@ -504,7 +504,7 @@ define-builtin
} define-tuple-class
"curry" "kernel" create
"tuple" "kernel" lookup
tuple
{
{
{ "object" "kernel" }
@ -525,7 +525,7 @@ define-builtin
[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create
"tuple" "kernel" lookup
tuple
{
{
{ "object" "kernel" }

17
core/classes/tuple/tuple-docs.factor
View File

@ -32,23 +32,23 @@ $nl
""
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
": construct-vehicle ( class -- vehicle )"
": new-vehicle ( class -- vehicle )"
" new"
" V{ } clone >>occupants ;"
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
" car construct-vehicle"
" car new-vehicle"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
" aeroplane construct-vehicle"
" aeroplane new-vehicle"
" swap >>max-altitude"
" swap >>max-speed ;"
}
"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
ARTICLE: "tuple-constructors" "Tuple constructors"
"Tuples are created by calling one of two constructor primitives:"
@ -64,13 +64,16 @@ $nl
{ $code
"TUPLE: color red green blue alpha ;"
""
"! The following two are equivalent"
"C: <rgba> rgba"
": <rgba> color boa ; ! identical to above"
": <rgba> color boa ;"
""
"! We can define constructors which call other constructors"
": <rgb> f <rgba> ;"
""
": <color> new ;"
": <color> f f f f <rgba> ; ! identical to above"
"! The following two are equivalent"
": <color> color new ;"
": <color> f f f f <rgba> ;"
}
{ $subsection "parametrized-constructors" } ;

3
core/classes/tuple/tuple-tests.factor
View File

@ -538,3 +538,6 @@ TUPLE: another-forget-accessors-test ;
] with-string-writer empty?
] with-variable
] unit-test
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail

11
core/classes/tuple/tuple.factor
View File

@ -58,6 +58,8 @@ PRIVATE>
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
ERROR: bad-superclass class ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
@ -185,16 +187,23 @@ M: tuple-class update-class
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
: valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ;
: check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ;
PRIVATE>
GENERIC# define-tuple-class 2 ( class superclass slots -- )
M: word define-tuple-class
over check-superclass
define-new-tuple-class ;
M: tuple-class define-tuple-class
3dup tuple-class-unchanged?
[ 3dup redefine-tuple-class ] unless
[ over check-superclass 3dup redefine-tuple-class ] unless
3drop ;
: define-error-class ( class superclass slots -- )

5
core/debugger/debugger.factor
View File

@ -215,7 +215,10 @@ M: check-method summary
drop "Invalid parameters for create-method" ;
M: no-tuple-class summary
drop "Invalid class for define-constructor" ;
drop "BOA constructors can only be defined for tuple classes" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
M: no-cond summary
drop "Fall-through in cond" ;

2
core/dlists/dlists-tests.factor
View File

@ -1,5 +1,5 @@
USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint
sets sequences namespaces sorting debugger io prettyprint
math ;
IN: dlists.tests

6
core/generator/registers/registers.factor
View File

@ -237,7 +237,7 @@ M: phantom-stack clone
GENERIC: finalize-height ( stack -- )
: construct-phantom-stack ( class -- stack )
: new-phantom-stack ( class -- stack )
>r 0 V{ } clone r> boa ; inline
: (loc)
@ -257,7 +257,7 @@ GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> ( -- stack )
phantom-datastack construct-phantom-stack ;
phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
@ -267,7 +267,7 @@ M: phantom-datastack finalize-height
TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> ( -- stack )
phantom-retainstack construct-phantom-stack ;
phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;

9
core/parser/parser.factor
View File

@ -17,9 +17,14 @@ TUPLE: lexer text line line-text line-length column ;
0 >>column
drop ;
: new-lexer ( text class -- lexer )
new
0 >>line
swap >>text
dup next-line ; inline
: <lexer> ( text -- lexer )
0 { set-lexer-text set-lexer-line } lexer construct
dup next-line ;
lexer new-lexer ;
: location ( -- loc )
file get lexer get lexer-line 2dup and

4
core/prettyprint/prettyprint-docs.factor
View File

@ -60,8 +60,8 @@ $nl
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
{ $subsection construct-section }
{ $subsection construct-block }
{ $subsection new-section }
{ $subsection new-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"

2
core/prettyprint/sections/sections-docs.factor
View File

@ -78,7 +78,7 @@ HELP: section
{ { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
HELP: construct-section
HELP: new-section
{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;

18
core/prettyprint/sections/sections.factor
View File

@ -71,7 +71,7 @@ start end
start-group? end-group?
style overhang ;
: construct-section ( length class -- section )
: new-section ( length class -- section )
new
position get >>start
swap position [ + ] change
@ -127,7 +127,7 @@ M: object short-section? section-fits? ;
TUPLE: line-break < section type ;
: <line-break> ( type -- section )
0 \ line-break construct-section
0 \ line-break new-section
swap >>type ;
M: line-break short-section drop ;
@ -137,13 +137,13 @@ M: line-break long-section drop ;
! Block sections
TUPLE: block < section sections ;
: construct-block ( style class -- block )
0 swap construct-section
: new-block ( style class -- block )
0 swap new-section
V{ } clone >>sections
swap >>style ; inline
: <block> ( style -- block )
block construct-block ;
block new-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
@ -200,7 +200,7 @@ M: block short-section ( block -- )
TUPLE: text < section string ;
: <text> ( string style -- text )
over length 1+ \ text construct-section
over length 1+ \ text new-section
swap >>style
swap >>string ;
@ -216,7 +216,7 @@ M: text long-section short-section ;
TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
H{ } inset construct-block
H{ } inset new-block
2 >>overhang
swap >>narrow? ;
@ -237,7 +237,7 @@ M: inset newline-after? drop t ;
TUPLE: flow < block ;
: <flow> ( -- block )
H{ } flow construct-block ;
H{ } flow new-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
@ -253,7 +253,7 @@ M: flow short-section? ( section -- ? )
TUPLE: colon < block ;
: <colon> ( -- block )
H{ } colon construct-block ;
H{ } colon new-block ;
M: colon long-section short-section ;

7
core/sequences/sequences-docs.factor
View File

@ -528,12 +528,7 @@ HELP: contains?
HELP: all?
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." }
{ $notes
"The implementation makes use of a well-known logical identity:"
$nl
{ $snippet "P[x] for all x <==> not ((not P[x]) for some x)" }
} ;
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }

2
core/sets/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Doug Coleman

17
core/sets/sets-docs.factor
View File

@ -1,7 +1,9 @@
USING: kernel help.markup help.syntax sequences ;
IN: sets
ARTICLE: "sets" "Set theoretic operations"
ARTICLE: "sets" "Set-theoretic operations on sequences"
"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
$nl
"Remove duplicates:"
{ $subsection prune }
"Test for duplicates:"
@ -9,7 +11,8 @@ ARTICLE: "sets" "Set theoretic operations"
"Set operations on sequences:"
{ $subsection diff }
{ $subsection intersect }
{ $subsection union } ;
{ $subsection union }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
@ -22,14 +25,14 @@ HELP: prune
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: sequences prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
{ $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
{ $example
"USING: hashtables prettyprint ;"
"USING: sets prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
"f"
} ;
@ -38,21 +41,21 @@ HELP: diff
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
} { $examples
{ $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
} ;
HELP: intersect
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
{ $examples
{ $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
} ;
HELP: union
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
{ $examples
{ $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "{ 1 2 3 4 }" }
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
} ;
{ diff intersect union } related-words

1
core/sets/summary.txt Normal file
View File

@ -0,0 +1 @@
Set-theoretic operations on sequences

1
core/sets/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

2
core/strings/strings-tests.factor
View File

@ -96,7 +96,7 @@ unit-test
[ ] [
[
4 [
100 [ drop "obdurak" ] map
100 [ drop "obdurak" clone ] map
gc
dup [
1234 0 rot set-string-nth

9
core/threads/threads.factor
View File

@ -56,13 +56,16 @@ mailbox variables sleep-entry ;
PRIVATE>
: <thread> ( quot name -- thread )
\ thread new
: new-thread ( quot name class -- thread )
new
swap >>name
swap >>quot
\ thread counter >>id
<box> >>continuation
[ ] >>exit-handler ;
[ ] >>exit-handler ; inline
: <thread> ( quot name -- thread )
\ thread new-thread ;
: run-queue 42 getenv ;

1
extra/arrays/lib/summary.txt Normal file
View File

@ -0,0 +1 @@
Non-core array words

2
extra/builder/cleanup/cleanup.factor
View File

@ -8,6 +8,8 @@ IN: builder.cleanup
SYMBOL: builder-debug
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
: delete-child-factor ( -- )

18
extra/builder/common/common.factor
View File

@ -7,6 +7,10 @@ IN: builder.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builds-dir
: builds ( -- path )
@ -21,15 +25,6 @@ VAR: stamp
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
: create-build-dir ( -- )
datestamp >stamp
build-dir make-directory ;
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
{ "git" "clone" builds/factor } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
@ -57,8 +52,3 @@ SYMBOL: status
{ status-vm status-boot status-test status-build status-release status }
[ off ]
each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode

2
extra/builder/email/email.factor
View File

@ -8,6 +8,8 @@ IN: builder.email
SYMBOL: builder-from
SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;

4
extra/concurrency/combinators/combinators-tests.factor
View File

@ -1,6 +1,6 @@
IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences ;
concurrency.mailboxes threads sequences accessors ;
[ [ drop ] parallel-each ] must-infer
[ [ ] parallel-map ] must-infer
@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ;
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
[ delegate "Even" = ] must-fail-with
[ error>> "Even" = ] must-fail-with
[ V{ 0 3 6 9 } ]
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test

14
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -81,23 +81,19 @@ M: mailbox dispose
: wait-for-close ( mailbox -- )
f wait-for-close-timeout ;
TUPLE: linked-error thread ;
TUPLE: linked-error error thread ;
: <linked-error> ( error thread -- linked )
{ set-delegate set-linked-error-thread }
linked-error construct ;
C: <linked-error> linked-error
: ?linked dup linked-error? [ rethrow ] when ;
TUPLE: linked-thread supervisor ;
TUPLE: linked-thread < thread supervisor ;
M: linked-thread error-in-thread
[ <linked-error> ] keep
linked-thread-supervisor mailbox-put ;
[ <linked-error> ] [ supervisor>> ] bi mailbox-put ;
: <linked-thread> ( quot name mailbox -- thread' )
>r <thread> linked-thread construct-delegate r>
over set-linked-thread-supervisor ;
>r linked-thread new-thread r> >>supervisor ;
: spawn-linked-to ( quot name mailbox -- thread )
<linked-thread> [ (spawn) ] keep ;

4
extra/concurrency/messaging/messaging-tests.factor
View File

@ -4,7 +4,7 @@
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
match quotations concurrency.messaging concurrency.mailboxes
concurrency.count-downs ;
concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
@ -30,7 +30,7 @@ IN: concurrency.messaging.tests
"crash" throw
] "Linked test" spawn-linked drop
receive
] [ delegate "crash" = ] must-fail-with
] [ error>> "crash" = ] must-fail-with
MATCH-VARS: ?from ?to ?value ;
SYMBOL: increment

2
extra/db/mysql/mysql.factor
View File

@ -9,7 +9,7 @@ TUPLE: mysql-statement ;
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
drop ;
;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;

5
extra/editors/vim/generate-syntax/generate-syntax.factor
View File

@ -1,9 +1,10 @@
! Generate a new factor.vim file for syntax highlighting
USING: http.server.templating.fhtml io.files ;
USING: http.server.templating http.server.templating.fhtml
io.files ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
"misc/factor.vim.fgen" resource-path
"misc/factor.vim.fgen" resource-path <fhtml>
"misc/factor.vim" resource-path
template-convert ;

2
extra/farkup/farkup-tests.factor
View File

@ -54,7 +54,7 @@ IN: farkup.tests
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test

20
extra/farkup/farkup.factor
View File

@ -1,11 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel memoize namespaces peg sequences strings
html.elements xml.entities xmode.code2html splitting
io.streams.string html peg.parsers html.elements sequences.deep
unicode.categories ;
USING: arrays io io.styles kernel memoize namespaces peg
sequences strings html.elements xml.entities xmode.code2html
splitting io.streams.string html peg.parsers html.elements
sequences.deep unicode.categories ;
IN: farkup
<PRIVATE
: delimiters ( -- string )
"*_^~%[-=|\\\n" ; inline
@ -53,7 +55,13 @@ MEMO: eq ( -- parser )
: render-code ( string mode -- string' )
>r string-lines r>
[ [ htmlize-lines ] with-html-stream ] with-string-writer ;
[
[
H{ { wrap-margin f } } [
htmlize-lines
] with-nesting
] with-html-stream
] with-string-writer ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
@ -144,6 +152,8 @@ MEMO: paragraph ( -- parser )
[ "<p>" swap "</p>" 3array ] unless
] action ;
PRIVATE>
PEG: parse-farkup ( -- parser )
[
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,

3
extra/help/handbook/handbook.factor
View File

@ -3,7 +3,7 @@ namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
quotations io.streams.byte-array io.encodings.string
classes.builtin ;
classes.builtin parser ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
@ -25,6 +25,7 @@ $nl
{ { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
{ { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
{ { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
{ { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
{ { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
{ { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }

4
extra/html/html-tests.factor
View File

@ -3,7 +3,9 @@ namespaces tools.test xml.writer sbufs sequences html.private ;
IN: html.tests
: make-html-string
[ with-html-stream ] with-string-writer ;
[ with-html-stream ] with-string-writer ; inline
[ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop

2
extra/html/html.factor
View File

@ -194,7 +194,7 @@ M: html-stream stream-nl ( stream -- )
! Utilities
: with-html-stream ( quot -- )
stdio get <html-stream> swap with-stream* ;
stdio get <html-stream> swap with-stream* ; inline
: xhtml-preamble
"<?xml version=\"1.0\"?>" write-html

25
extra/http/http-tests.factor
View File

@ -1,5 +1,6 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences ;
io.streams.string kernel arrays splitting sequences
assocs io.sockets ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -136,10 +137,12 @@ io.encodings.ascii ;
[ ] [
[
<dispatcher>
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder
"extra/http/test" resource-path <static> >>default
<action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
"quit" add-responder
<dispatcher>
"extra/http/test" resource-path <static> >>default
"nested" add-responder
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
@ -148,7 +151,17 @@ io.encodings.ascii ;
[ t ] [
"extra/http/test/foo.html" resource-path ascii file-contents
"http://localhost:1237/foo.html" http-get =
"http://localhost:1237/nested/foo.html" http-get =
] unit-test
! Try with a slightly malformed request
[ t ] [
"localhost" 1237 <inet> ascii <client> [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
readln drop
read-header USE: prettyprint
] with-stream dup . "location" swap at "/" head?
] unit-test
[ "Goodbye" ] [

15
extra/http/http.factor
View File

@ -394,14 +394,17 @@ body ;
[ unparse-cookies "set-cookie" pick set-at ] when*
write-header ;
: write-response-body ( response -- response )
dup body>> {
{ [ dup not ] [ drop ] }
{ [ dup string? ] [ write ] }
{ [ dup callable? ] [ call ] }
[ stdio get stream-copy ]
: body>quot ( body -- quot )
{
{ [ dup not ] [ drop [ ] ] }
{ [ dup string? ] [ [ write ] curry ] }
{ [ dup callable? ] [ ] }
[ [ stdio get stream-copy ] curry ]
} cond ;
: write-response-body ( response -- response )
dup body>> body>quot call ;
M: response write-response ( respose -- )
write-response-version
write-response-code

9
extra/http/server/auth/login/boilerplate.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h1><t:write-title /></h1>
<t:call-next-template />
</t:chloe>

77
extra/http/server/auth/login/edit-profile.fhtml
View File

@ -1,77 +0,0 @@
<% USING: http.server.components http.server.auth.login
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>Edit profile</h1>
<form method="POST" action="edit-profile">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-view %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Current password:</td>
<td><% "password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you don't want to change your current password, leave this field blank.</td>
</tr>
<tr>
<td>New password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you are changing your password, enter it twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
</table>
<p><input type="submit" value="Update" />
<% {
{ [ login-failed? get ] [ "invalid password" render-error ] }
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

77
extra/http/server/auth/login/edit-profile.xml Normal file
View File

@ -0,0 +1,77 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Edit Profile</t:title>
<t:form action="edit-profile">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:view component="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
<td><t:edit component="realname" /></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<th class="field-label">Current password:</th>
<td><t:edit component="password" /></td>
</tr>
<tr>
<td></td>
<td>If you don't want to change your current password, leave this field blank.</td>
</tr>
<tr>
<th class="field-label">New password:</th>
<td><t:edit component="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
<td><t:edit component="verify-password" /></td>
</tr>
<tr>
<td></td>
<td>If you are changing your password, enter it twice to ensure it is correct.</td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
<td><t:edit component="email" /></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
</table>
<p>
<input type="submit" value="Update" />
<t:if var="http.server.auth.login:login-failed?">
<t:error>invalid password</t:error>
</t:if>
<t:if var="http.server.auth.login:password-mismatch?">
<t:error>passwords do not match</t:error>
</t:if>
</p>
</t:form>
</t:chloe>

84
extra/http/server/auth/login/login.factor
View File

@ -1,20 +1,31 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http.server.actions http.server.components http.server.sessions
http.server.templating.fhtml http.server.validators
http.server.auth http sequences io.files namespaces hashtables
base64 io combinators sequences io.files namespaces hashtables
fry io.sockets arrays threads locals qualified continuations
destructors ;
destructors
html.elements
http
http.server
http.server.auth
http.server.auth.providers
http.server.auth.providers.null
http.server.actions
http.server.components
http.server.forms
http.server.sessions
http.server.boilerplate
http.server.templating
http.server.templating.chloe
http.server.validators ;
IN: http.server.auth.login
QUALIFIED: smtp
SYMBOL: post-login-url
SYMBOL: login-failed?
TUPLE: login users ;
TUPLE: login < dispatcher users ;
: users login get users>> ;
@ -31,11 +42,15 @@ M: user-saver dispose
: save-user-after ( user -- )
<user-saver> add-always-destructor ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"
3append <chloe> ;
! ! ! Login
: <login-form>
"login" <form>
"resource:extra/http/server/auth/login/login.fhtml" >>edit-template
"login" login-template >>edit-template
"username" <username>
t >>required
add-field
@ -77,7 +92,7 @@ M: user-saver dispose
: <register-form> ( -- form )
"register" <form>
"resource:extra/http/server/auth/login/register.fhtml" >>edit-template
"register" login-template >>edit-template
"username" <username>
t >>required
add-field
@ -130,7 +145,7 @@ SYMBOL: user-exists?
successful-login
login get responder>> init-user-profile
login get default>> responder>> init-user-profile
] >>submit
] ;
@ -138,7 +153,7 @@ SYMBOL: user-exists?
: <edit-profile-form> ( -- form )
"edit-profile" <form>
"resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
"edit-profile" login-template >>edit-template
"username" <username> add-field
"realname" <string> add-field
"password" <password> add-field
@ -178,7 +193,7 @@ SYMBOL: previous-page
"password" value uid users check-login
[ login-failed? on validation-failed ] unless
"new-password" value set-password
"new-password" value >>password
] unless
"realname" value >>realname
@ -233,7 +248,7 @@ SYMBOL: lost-password-from
: <recover-form-1> ( -- form )
"register" <form>
"resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template
"recover-1" login-template >>edit-template
"username" <username>
t >>required
add-field
@ -262,14 +277,15 @@ SYMBOL: lost-password-from
send-password-email
] when*
"resource:extra/http/server/auth/login/recover-2.fhtml" serve-template
"recover-2" login-template serve-template
] >>submit
] ;
: <recover-form-3>
"new-password" <form>
"resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template
"username" <username> <hidden>
"recover-3" login-template >>edit-template
"username" <username>
hidden >>renderer
t >>required
add-field
"new-password" <password>
@ -278,7 +294,8 @@ SYMBOL: lost-password-from
"verify-password" <password>
t >>required
add-field
"ticket" <string> <hidden>
"ticket" <string>
hidden >>renderer
t >>required
add-field ;
@ -315,8 +332,7 @@ SYMBOL: lost-password-from
"new-password" value >>password
users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template
"recover-4" login-template serve-template
] [
<400>
] if*
@ -342,38 +358,46 @@ C: <protected> protected
"login" f <permanent-redirect> ;
M: protected call-responder ( path responder -- response )
logged-in-user sget [
dup save-user-after
logged-in-user sget dup [
save-user-after
request get request-url previous-page sset
responder>> call-responder
] [
2drop
3drop
request get method>> { "GET" "HEAD" } member?
[ show-login-page ] [ <400> ] if
] if ;
M: login call-responder ( path responder -- response )
dup login set
delegate call-responder ;
call-next-method ;
: <login-boilerplate> ( responder -- responder' )
<boilerplate>
"boilerplate" login-template >>template ;
: <login> ( responder -- auth )
login <webapp>
login new-dispatcher
swap <protected> >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
<login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ;
! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> <protected> "edit-profile" add-responder ;
<edit-profile-action> <protected> <login-boilerplate>
"edit-profile" add-responder ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
<register-action> <login-boilerplate>
"register" add-responder ;
: allow-password-recovery ( login -- login )
<recover-action-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ;
<recover-action-1> <login-boilerplate>
"recover-password" add-responder
<recover-action-3> <login-boilerplate>
"new-password" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;

46
extra/http/server/auth/login/login.fhtml
View File

@ -1,46 +0,0 @@
<% USING: http.server.auth.login http.server.components http.server
kernel namespaces ; %>
<html>
<body>
<h1>Login required</h1>
<form method="POST" action="login">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
</tr>
</table>
<p><input type="submit" value="Log in" />
<%
login-failed? get
[ "Invalid username or password" render-error ] when
%>
</p>
</form>
<p>
<% allow-registration? [ %>
<a href="<% "register" f write-link %>">Register</a>
<% ] when %>
<% allow-password-recovery? [ %>
<a href="<% "recover-password" f write-link %>">
Recover Password
</a>
<% ] when %>
</p>
</body>
</html>

44
extra/http/server/auth/login/login.xml Normal file
View File

@ -0,0 +1,44 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Login</t:title>
<t:form action="login">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:edit component="username" /></td>
</tr>
<tr>
<th class="field-label">Password:</th>
<td><t:edit component="password" /></td>
</tr>
</table>
<p>
<input type="submit" value="Log in" />
<t:if var="http.server.auth.login:login-failed?">
<t:error>invalid username or password</t:error>
</t:if>
</p>
</t:form>
<p>
<t:if code="http.server.auth.login:login-failed?">
<t:a href="register">Register</t:a>
</t:if>
|
<t:if code="http.server.auth.login:allow-password-recovery?">
<t:a href="recover-password">Recover Password</t:a>
</t:if>
</p>
</t:chloe>

41
extra/http/server/auth/login/recover-1.fhtml
View File

@ -1,41 +0,0 @@
<% USING: http.server.components http.server ; %>
<html>
<body>
<h1>Recover lost password: step 1 of 4</h1>
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<form method="POST" action="recover-password">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td>Captcha:</td>
<td><% "captcha" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
</tr>
</table>
<input type="submit" value="Recover password" />
</form>
</body>
</html>

39
extra/http/server/auth/login/recover-1.xml Normal file
View File

@ -0,0 +1,39 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 1 of 4</t:title>
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<t:form action="recover-password">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:edit component="username" /></td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
<td><t:edit component="email" /></td>
</tr>
<tr>
<th class="field-label">Captcha:</th>
<td><t:edit component="captcha" /></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
</tr>
</table>
<input type="submit" value="Recover password" />
</t:form>
</t:chloe>

9
extra/http/server/auth/login/recover-2.fhtml
View File

@ -1,9 +0,0 @@
<% USING: http.server.components ; %>
<html>
<body>
<h1>Recover lost password: step 2 of 4</h1>
<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
</body>
</html>

9
extra/http/server/auth/login/recover-2.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 2 of 4</t:title>
<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
</t:chloe>

46
extra/http/server/auth/login/recover-3.fhtml
View File

@ -1,46 +0,0 @@
<% USING: http.server.components http.server.auth.login http.server
namespaces kernel combinators ; %>
<html>
<body>
<h1>Recover lost password: step 3 of 4</h1>
<p>Choose a new password for your account.</p>
<form method="POST" action="new-password">
<% hidden-form-field %>
<table>
<% "username" component render-edit %>
<% "ticket" component render-edit %>
<tr>
<td>Password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify password:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p><input type="submit" value="Set password" />
<% password-mismatch? get [
"passwords do not match" render-error
] when %>
</p>
</form>
</body>
</html>

43
extra/http/server/auth/login/recover-3.xml Normal file
View File

@ -0,0 +1,43 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 3 of 4</t:title>
<p>Choose a new password for your account.</p>
<t:form action="new-password">
<table>
<t:edit component="username" />
<t:edit component="ticket" />
<tr>
<th class="field-label">Password:</th>
<td><t:edit component="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify password:</th>
<td><t:edit component="verify-password" /></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p>
<input type="submit" value="Set password" />
<t:if var="http.server.auth.login:password-mismatch?">
<t:error>passwords do not match</t:error>
</t:if>
</p>
</t:form>
</t:chloe>

10
extra/http/server/auth/login/recover-4.fhtml
View File

@ -1,10 +0,0 @@
<% USING: http.server ; %>
<html>
<body>
<h1>Recover lost password: step 4 of 4</h1>
<p>Your password has been reset.
You may now <a href="<% "login" f write-link %>">log in</a>.</p>
</body>
</html>

9
extra/http/server/auth/login/recover-4.xml Executable file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Recover lost password: step 4 of 4</t:title>
<p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>
</t:chloe>

77
extra/http/server/auth/login/register.fhtml
View File

@ -1,77 +0,0 @@
<% USING: http.server.components http.server.auth.login
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>New user registration</h1>
<form method="POST" action="register">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-edit %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
<tr>
<td>Captcha:</td>
<td><% "captcha" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
</tr>
</table>
<p><input type="submit" value="Register" />
<% {
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ user-exists? get ] [ "username taken" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

79
extra/http/server/auth/login/register.xml Normal file
View File

@ -0,0 +1,79 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>New User Registration</t:title>
<t:form action="register">
<table>
<tr>
<th class="field-label">User name:</th>
<td><t:edit component="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
<td><t:edit component="realname" /></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<th class="field-label">Password:</th>
<td><t:edit component="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
<td><t:edit component="verify-password" /></td>
</tr>
<tr>
<td></td>
<td>Enter your password twice to ensure it is correct.</td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
<td><t:edit component="email" /></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
<tr>
<th class="field-label">Captcha:</th>
<td><t:edit component="captcha" /></td>
</tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
</tr>
</table>
<p>
<input type="submit" value="Register" />
<t:if var="http.server.auth.login:user-exists?">
<t:error>username taken</t:error>
</t:if>
<t:if var="http.server.auth.login:password-mismatch?">
<t:error>passwords do not match</t:error>
</t:if>
</p>
</t:form>
</t:chloe>

2
extra/http/server/auth/providers/assoc/assoc-tests.factor
View File

@ -26,7 +26,7 @@ namespaces accessors kernel ;
[ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ ] [ "user" get "fdasf" >>password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

2
extra/http/server/auth/providers/db/db-tests.factor
View File

@ -31,7 +31,7 @@ users-in-db "provider" set
[ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" set-password drop ] unit-test
[ ] [ "user" get "fdasf" >>password drop ] unit-test
[ ] [ "user" get "provider" get update-user ] unit-test

2
extra/http/server/auth/providers/providers.factor
View File

@ -17,8 +17,6 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
: set-password ( user password -- user ) >>password ;
! Password recovery support
:: issue-ticket ( email username provider -- user/f )

49
extra/http/server/boilerplate/boilerplate.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings
io io.streams.string
http.server
http.server.templating ;
IN: http.server.boilerplate
TUPLE: boilerplate responder template ;
: <boilerplate> f boilerplate boa ;
SYMBOL: title
: set-title ( string -- )
title get >box ;
: write-title ( -- )
title get value>> write ;
SYMBOL: style
: add-style ( string -- )
"\n" style get push-all
style get push-all ;
: write-style ( -- )
style get >string write ;
SYMBOL: next-template
: call-next-template ( -- )
next-template get write ;
M: f call-template drop call-next-template ;
: with-boilerplate ( body template -- )
[
title get [ <box> title set ] unless
style get [ SBUF" " clone style set ] unless
swap with-string-writer next-template set
call-template
] with-scope ; inline
M: boilerplate call-responder
[ responder>> call-responder clone ] [ template>> ] bi
[ [ with-boilerplate ] 2curry ] curry change-body ;

38
extra/http/server/components/components-tests.factor
View File

@ -1,7 +1,11 @@
IN: http.server.components.tests
USING: http.server.components http.server.validators
namespaces tools.test kernel accessors
tuple-syntax mirrors http.server.actions ;
USING: http.server.components http.server.forms
http.server.validators namespaces tools.test kernel accessors
tuple-syntax mirrors http.server.actions
http.server.templating.fhtml
io.streams.string io.streams.null ;
\ render-edit must-infer
validation-failed? off
@ -46,8 +50,8 @@ TUPLE: test-tuple text number more-text ;
: <test-form> ( -- form )
"test" <form>
"resource:extra/http/server/components/test/form.fhtml" >>view-template
"resource:extra/http/server/components/test/form.fhtml" >>edit-template
"resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
"resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
"text" <string>
t >>required
add-field
@ -99,11 +103,31 @@ TUPLE: test-tuple text number more-text ;
"123" "n" get validate value>>
] unit-test
[ ] [ "n" get t >>integer drop ] unit-test
[ ] [ "i" <integer> "i" set ] unit-test
[ 3 ] [
"3" "n" get validate
"3" "i" get validate
] unit-test
[ t ] [
"3.9" "i" get validate validation-error?
] unit-test
H{ } clone values set
[ ] [ 3 "i" set-value ] unit-test
[ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test
[ ] [ [ "i" get render-edit ] with-null-stream ] unit-test
[ ] [ "t" <text> "t" set ] unit-test
[ ] [ "hello world" "t" set-value ] unit-test
[ ] [ [ "t" get render-edit ] with-null-stream ] unit-test
] with-scope
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test
[ ] [ "password" <password> "p" set ] unit-test

310
extra/http/server/components/components.factor
View File

@ -2,23 +2,47 @@
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements http.server.validators accessors namespaces
kernel io math.parser assocs classes words classes.tuple arrays
sequences io.files http.server.templating.fhtml
http.server.actions splitting mirrors hashtables fry
sequences splitting mirrors hashtables fry combinators
continuations math ;
IN: http.server.components
! Renderer protocol
GENERIC: render-view* ( value renderer -- )
GENERIC: render-edit* ( value id renderer -- )
TUPLE: field type ;
C: <field> field
M: field render-view* drop write ;
M: field render-edit*
<input type>> =type [ =id ] [ =name ] bi =value input/> ;
: render-error ( message -- )
<span "error" =class span> write </span> ;
TUPLE: hidden < field ;
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
M: hidden render-view* 2drop ;
! Component protocol
SYMBOL: components
TUPLE: component id required default ;
TUPLE: component id required default renderer ;
: component ( name -- component )
dup components get at
[ ] [ "No such component: " prepend throw ] ?if ;
GENERIC: init ( component -- component )
M: component init ;
GENERIC: validate* ( value component -- result )
GENERIC: render-view* ( value component -- )
GENERIC: render-edit* ( value component -- )
GENERIC: render-error* ( reason value component -- )
GENERIC: component-string ( value component -- string )
SYMBOL: values
@ -26,6 +50,41 @@ SYMBOL: values
: set-value values get set-at ;
: blank-values H{ } clone values set ;
: from-tuple <mirror> values set ;
: values-tuple values get mirror-object ;
: render-view ( component -- )
[ id>> value ] [ component-string ] [ renderer>> ] tri
render-view* ;
<PRIVATE
: render-edit-string ( string component -- )
[ id>> ] [ renderer>> ] bi render-edit* ;
: render-edit-error ( component -- )
[ id>> value ] keep
[ [ value>> ] dip render-edit-string ]
[ drop reason>> render-error ] 2bi ;
: value-or-default ( component -- value )
[ id>> value ] [ default>> ] bi or ;
: render-edit-value ( component -- )
[ value-or-default ]
[ component-string ]
[ render-edit-string ]
tri ;
PRIVATE>
: render-edit ( component -- )
dup id>> value validation-error?
[ render-edit-error ] [ render-edit-value ] if ;
: validate ( value component -- result )
'[
,
@ -36,206 +95,143 @@ SYMBOL: values
] [ validate* ] if
] with-validator ;
: render-view ( component -- )
[ id>> value ] [ render-view* ] bi ;
: render-error ( error -- )
<span "error" =class span> write </span> ;
: render-edit ( component -- )
dup id>> value dup validation-error? [
[ reason>> ] [ value>> ] bi rot render-error*
] [
swap [ default>> or ] keep render-edit*
] if ;
: <component> ( id class -- component )
\ component new
swap construct-delegate
swap >>id ; inline
! Forms
TUPLE: form view-template edit-template components ;
: <form> ( id -- form )
form <component>
V{ } clone >>components ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
: with-form ( form quot -- )
>r components>> components r> with-variable ; inline
: set-defaults ( form -- )
[
components get [
swap values get [
swap default>> or
] change-at
] assoc-each
] with-form ;
: view-form ( form -- )
dup view-template>> '[ , run-template ] with-form ;
: edit-form ( form -- )
dup edit-template>> '[ , run-template ] with-form ;
: validate-param ( id component -- )
[ [ params get at ] [ validate ] bi* ]
[ drop set-value ] 2bi ;
: (validate-form) ( form -- error? )
[
validation-failed? off
components get [ validate-param ] assoc-each
validation-failed? get
] with-form ;
: validate-form ( form -- )
(validate-form) [ validation-failed ] when ;
: blank-values H{ } clone values set ;
: from-tuple <mirror> values set ;
: values-tuple values get mirror-object ;
! ! !
! Canned components: for simple applications and prototyping
! ! !
: render-input ( value component type -- )
<input
=type
id>> [ =id ] [ =name ] bi
=value
input/> ;
! Hidden fields
TUPLE: hidden ;
: <hidden> ( component -- component )
hidden construct-delegate ;
M: hidden render-view*
2drop ;
M: hidden render-edit*
>r dup number? [ number>string ] when r>
"hidden" render-input ;
: new-component ( id class renderer -- component )
swap new
swap >>renderer
swap >>id
init ; inline
! String input fields
TUPLE: string min-length max-length ;
TUPLE: string < component one-line min-length max-length ;
: <string> ( id -- component ) string <component> ;
: new-string ( id class -- component )
"text" <field> new-component
t >>one-line ; inline
: <string> ( id -- component )
string new-string ;
M: string validate*
[ v-one-line ] [
[ min-length>> [ v-min-length ] when* ]
[ max-length>> [ v-max-length ] when* ]
bi
] bi* ;
[ one-line>> [ v-one-line ] when ]
[ min-length>> [ v-min-length ] when* ]
[ max-length>> [ v-max-length ] when* ]
tri ;
M: string render-view*
drop write ;
M: string render-edit*
"text" render-input ;
M: string render-error*
"text" render-input render-error ;
M: string component-string
drop ;
! Username fields
TUPLE: username ;
TUPLE: username < string ;
M: username init
2 >>min-length
20 >>max-length ;
: <username> ( id -- component )
<string> username construct-delegate
2 >>min-length
20 >>max-length ;
username new-string ;
M: username validate*
delegate validate* v-one-word ;
call-next-method v-one-word ;
! E-mail fields
TUPLE: email ;
TUPLE: email < string ;
: <email> ( id -- component )
<string> email construct-delegate
email new-string
5 >>min-length
60 >>max-length ;
M: email validate*
delegate validate* dup empty? [ v-email ] unless ;
call-next-method dup empty? [ v-email ] unless ;
! Don't send passwords back to the user
TUPLE: password-renderer < field ;
: password-renderer T{ password-renderer f "password" } ;
: blank-password >r >r drop "" r> r> ;
M: password-renderer render-edit*
blank-password call-next-method ;
! Password fields
TUPLE: password ;
TUPLE: password < string ;
M: password init
6 >>min-length
60 >>max-length ;
: <password> ( id -- component )
<string> password construct-delegate
6 >>min-length
60 >>max-length ;
password new-string
password-renderer >>renderer ;
M: password validate*
delegate validate* v-one-word ;
M: password render-edit*
>r drop f r> "password" render-input ;
M: password render-error*
render-edit* render-error ;
call-next-method v-one-word ;
! Number fields
TUPLE: number min-value max-value integer ;
TUPLE: number < string min-value max-value ;
: <number> ( id -- component ) number <component> ;
: <number> ( id -- component )
number new-string ;
M: number validate*
[ v-number ] [
[ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
tri
bi
] bi* ;
M: number render-view*
drop number>string write ;
M: number component-string
drop dup [ number>string ] when ;
M: number render-edit*
>r number>string r> "text" render-input ;
! Integer fields
TUPLE: integer < number ;
M: number render-error*
"text" render-input render-error ;
: <integer> ( id -- component )
integer new-string ;
M: integer validate*
call-next-method v-integer ;
! Simple captchas
TUPLE: captcha < string ;
: <captcha> ( id -- component )
captcha new-string ;
M: captcha validate*
drop v-captcha ;
! Text areas
TUPLE: text ;
TUPLE: textarea-renderer rows cols ;
: <text> ( id -- component ) text <component> ;
: new-textarea-renderer ( class -- renderer )
new
60 >>cols
20 >>rows ;
M: text validate* drop ;
: <textarea-renderer> ( -- renderer )
textarea-renderer new-textarea-renderer ;
M: text render-view*
M: textarea-renderer render-view*
drop write ;
: render-textarea
M: textarea-renderer render-edit*
<textarea
id>> [ =id ] [ =name ] bi
[ rows>> [ number>string =rows ] when* ]
[ cols>> [ number>string =cols ] when* ] bi
[ =id ]
[ =name ] bi
textarea>
write
</textarea> ;
M: text render-edit*
render-textarea ;
TUPLE: text < string ;
M: text render-error*
render-textarea render-error ;
: new-text ( id class -- component )
new-string
f >>one-line
<textarea-renderer> >>renderer ;
! Simple captchas
TUPLE: captcha ;
: <captcha> ( id -- component )
<string> captcha construct-delegate ;
M: captcha validate*
drop v-captcha ;
: <text> ( id -- component )
text new-text ;

18
extra/http/server/components/farkup/farkup.factor
View File

@ -1,13 +1,17 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting http.server.components kernel io sequences
farkup ;
USING: splitting kernel io sequences farkup accessors
http.server.components ;
IN: http.server.components.farkup
TUPLE: farkup ;
TUPLE: farkup-renderer < textarea-renderer ;
: <farkup-renderer>
farkup-renderer new-textarea-renderer ;
M: farkup-renderer render-view*
drop string-lines "\n" join convert-farkup write ;
: <farkup> ( id -- component )
<text> farkup construct-delegate ;
M: farkup render-view*
drop string-lines "\n" join convert-farkup write ;
<text>
<farkup-renderer> >>renderer ;

57
extra/http/server/crud/crud.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces db.tuples math.parser
accessors fry locals hashtables
http.server
http.server.actions
http.server.components
http.server.forms
http.server.validators ;
IN: http.server.crud
USING: kernel namespaces db.tuples math.parser http.server
http.server.actions http.server.components
http.server.validators accessors fry locals hashtables ;
:: <view-action> ( form ctor -- action )
<action>
@ -19,29 +23,18 @@ http.server.validators accessors fry locals hashtables ;
: <id-redirect> ( id next -- response )
swap number>string "id" associate <permanent-redirect> ;
:: <create-action> ( form ctor next -- action )
<action>
[ f ctor call from-tuple form set-defaults ] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
f ctor call from-tuple
form validate-form
values-tuple insert-tuple
"id" value next <id-redirect>
] >>submit ;
:: <edit-action> ( form ctor next -- action )
<action>
{ { "id" [ v-number ] } } >>get-params
[ "id" get ctor call select-tuple from-tuple ] >>init
{ { "id" [ [ v-number ] v-optional ] } } >>get-params
[
"id" get ctor call
"id" get
[ select-tuple from-tuple ]
[ from-tuple form set-defaults ]
if
] >>init
[
"text/html" <content>
@ -53,7 +46,8 @@ http.server.validators accessors fry locals hashtables ;
form validate-form
values-tuple update-tuple
values-tuple
"id" value [ update-tuple ] [ insert-tuple ] if
"id" value next <id-redirect>
] >>submit ;
@ -67,3 +61,16 @@ http.server.validators accessors fry locals hashtables ;
next f <permanent-redirect>
] >>submit ;
:: <list-action> ( form ctor -- action )
<action>
[
"text/html" <content>
[
blank-values
f ctor call select-tuples "list" set-value
form view-form
] >>body
] >>display ;

4
extra/http/server/db/db.factor
View File

@ -9,8 +9,8 @@ TUPLE: db-persistence responder db params ;
C: <db-persistence> db-persistence
: connect-db ( db-persistence -- )
[ db>> ] [ params>> ] bi make-db
[ db set ] [ db-open ] [ add-always-destructor ] tri ;
[ db>> ] [ params>> ] bi make-db db-open
[ db set ] [ add-always-destructor ] bi ;
M: db-persistence call-responder
[ connect-db ] [ responder>> call-responder ] bi ;

70
extra/http/server/forms/forms.factor Normal file
View File

@ -0,0 +1,70 @@
USING: kernel accessors assocs namespaces io.files sequences fry
http.server.actions
http.server.components
http.server.validators
http.server.templating ;
IN: http.server.forms
TUPLE: form < component
view-template edit-template summary-template
components ;
M: form init V{ } clone >>components ;
: <form> ( id -- form )
form f new-component ;
: add-field ( form component -- form )
dup id>> pick components>> set-at ;
: with-form ( form quot -- )
>r components>> components r> with-variable ; inline
: set-defaults ( form -- )
[
components get [
swap values get [
swap default>> or
] change-at
] assoc-each
] with-form ;
: view-form ( form -- )
dup view-template>> '[ , call-template ] with-form ;
: edit-form ( form -- )
dup edit-template>> '[ , call-template ] with-form ;
: summary-form ( form -- )
dup summary-template>> '[ , call-template ] with-form ;
: validate-param ( id component -- )
[ [ params get at ] [ validate ] bi* ]
[ drop set-value ] 2bi ;
: (validate-form) ( form -- error? )
[
validation-failed? off
components get [ validate-param ] assoc-each
validation-failed? get
] with-form ;
: validate-form ( form -- )
(validate-form) [ validation-failed ] when ;
! List components
TUPLE: list-renderer form ;
C: <list-renderer> list-renderer
M: list-renderer render-view*
form>> [
[ >r from-tuple r> summary-form ] with-scope
] curry each ;
TUPLE: list < component ;
: <list> ( id form -- list )
list swap <list-renderer> new-component ;
M: list component-string drop ;

10
extra/http/server/server.factor
View File

@ -105,8 +105,13 @@ SYMBOL: form-hook
TUPLE: dispatcher default responders ;
: new-dispatcher ( class -- dispatcher )
new
404-responder get >>default
H{ } clone >>responders ; inline
: <dispatcher> ( -- dispatcher )
404-responder get H{ } clone dispatcher boa ;
dispatcher new-dispatcher ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
@ -125,9 +130,6 @@ M: dispatcher call-responder ( path dispatcher -- response )
2drop redirect-with-/
] if ;
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )

19
extra/http/server/sessions/sessions.factor
View File

@ -17,9 +17,10 @@ M: object init-session* drop ;
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
>r <sessions-in-memory> session-manager boa
r> construct-delegate ; inline
: new-session-manager ( responder class -- responder' )
new
<sessions-in-memory> >>sessions
swap >>responder ; inline
SYMBOLS: session session-id session-changed? ;
@ -64,18 +65,18 @@ M: session-saver dispose
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: null-sessions ;
TUPLE: null-sessions < session-manager ;
: <null-sessions>
null-sessions <session-manager> ;
null-sessions new-session-manager ;
M: null-sessions call-responder ( path responder -- response )
H{ } clone f call-responder/session ;
TUPLE: url-sessions ;
TUPLE: url-sessions < session-manager ;
: <url-sessions> ( responder -- responder' )
url-sessions <session-manager> ;
url-sessions new-session-manager ;
: session-id-key "factorsessid" ;
@ -107,10 +108,10 @@ M: url-sessions call-responder ( path responder -- response )
2drop nip new-url-session
] if ;
TUPLE: cookie-sessions ;
TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
cookie-sessions new-session-manager ;
: current-cookie-session ( responder -- id namespace/f )
request get session-id-key get-cookie dup

97
extra/http/server/templating/chloe/chloe-tests.factor Normal file
View File

@ -0,0 +1,97 @@
USING: http.server.templating http.server.templating.chloe
http.server.components http.server.boilerplate tools.test
io.streams.string kernel sequences ascii boxes namespaces xml
splitting ;
IN: http.server.templating.chloe.tests
[ "foo" ]
[ "<a href=\"foo\">blah</a>" string>xml "href" required-attr ]
unit-test
[ "<a name=\"foo\">blah</a>" string>xml "href" required-attr ]
[ "href attribute is required" = ]
must-fail-with
[ f ] [ f parse-query-attr ] unit-test
[ f ] [ "" parse-query-attr ] unit-test
[ H{ { "a" "b" } } ] [
blank-values
"b" "a" set-value
"a" parse-query-attr
] unit-test
[ H{ { "a" "b" } { "c" "d" } } ] [
blank-values
"b" "a" set-value
"d" "c" set-value
"a,c" parse-query-attr
] unit-test
: run-template
with-string-writer [ "\r\n\t" member? not ] subset
"?>" split1 nip ; inline
: test-template ( name -- template )
"resource:extra/http/server/templating/chloe/test/"
swap
".xml" 3append <chloe> ;
[ "Hello world" ] [
[
"test1" test-template call-template
] run-template
] unit-test
[ "Blah blah" "Hello world" ] [
[
<box> title set
[
"test2" test-template call-template
] run-template
title get box>
] with-scope
] unit-test
[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
[
[
"test2" test-template call-template
] "test3" test-template with-boilerplate
] run-template
] unit-test
: test4-aux? t ;
[ "True" ] [
[
"test4" test-template call-template
] run-template
] unit-test
: test5-aux? f ;
[ "" ] [
[
"test5" test-template call-template
] run-template
] unit-test
SYMBOL: test6-aux?
[ "True" ] [
[
test6-aux? on
"test6" test-template call-template
] run-template
] unit-test
SYMBOL: test7-aux?
[ "" ] [
[
test7-aux? off
"test7" test-template call-template
] run-template
] unit-test

168
extra/http/server/templating/chloe/chloe.factor Normal file
View File

@ -0,0 +1,168 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays
io.files io.encodings.utf8 html.elements unicode.case
tuple-syntax xml xml.data xml.writer xml.utilities
http.server
http.server.auth
http.server.components
http.server.sessions
http.server.templating
http.server.boilerplate ;
IN: http.server.templating.chloe
! Chloe is Ed's favorite web designer
TUPLE: chloe path ;
C: <chloe> chloe
DEFER: process-template
: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
: chloe-tag? ( tag -- ? )
{
{ [ dup tag? not ] [ f ] }
{ [ dup chloe-ns names-match? not ] [ f ] }
[ t ]
} cond nip ;
SYMBOL: tags
: required-attr ( tag name -- value )
dup rot at*
[ nip ] [ drop " attribute is required" append throw ] if ;
: optional-attr ( tag name -- value )
swap at ;
: write-title-tag ( tag -- )
drop
"head" tags get member? "title" tags get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
: style-tag ( tag -- )
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
] unless
utf8 file-contents
] [
drop children>string
] if add-style ;
: write-style-tag ( tag -- )
drop <style> write-style </style> ;
: component-attr ( tag -- name )
"component" required-attr ;
: view-tag ( tag -- )
component-attr component render-view ;
: edit-tag ( tag -- )
component-attr component render-edit ;
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: a-start-tag ( tag -- )
<a
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi link>string =href
a> ;
: process-tag-children ( tag -- )
[ process-template ] each ;
: a-tag ( tag -- )
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: form-start-tag ( tag -- )
<form
"POST" =method
tag-attrs print-attrs
form>
hidden-form-field ;
: form-tag ( tag -- )
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: attr>var ( value -- word/f )
attr>word dup symbol? [
"Must be a symbol: " swap append throw
] unless ;
: if-satisfied? ( tag -- ? )
{
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
[ "var" optional-attr [ attr>var get ] [ t ] if* ]
[ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
[ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
} cleave 4array [ ] all? ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
: error-tag ( tag -- )
children>string render-error ;
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ [ process-template ] each ] }
{ "title" [ children>string set-title ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "view" [ view-tag ] }
{ "edit" [ edit-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }
{ "if" [ if-tag ] }
{ "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ]
} case ;
: process-tag ( tag -- )
{
[ name-tag >lower tags get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tags get pop* ]
} cleave ;
: process-template ( xml -- )
{
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;
: process-chloe ( xml -- )
[
V{ } clone tags set
{
[ xml-prolog write-prolog ]
[ xml-before write-chunk ]
[ process-template ]
[ xml-after write-chunk ]
} cleave
] with-scope ;
M: chloe call-template
path>> utf8 <file-reader> read-xml process-chloe ;

5
extra/http/server/templating/chloe/test/test1.xml Normal file
View File

@ -0,0 +1,5 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
Hello world
</t:chloe>

6
extra/http/server/templating/chloe/test/test2.xml Normal file
View File

@ -0,0 +1,6 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Hello world</t:title>
Blah blah
</t:chloe>

5
extra/http/server/templating/chloe/test/test3-aux.xml Normal file
View File

@ -0,0 +1,5 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Hello world</t:title>
</t:chloe>

12
extra/http/server/templating/chloe/test/test3.xml Normal file
View File

@ -0,0 +1,12 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<head>
<t:write-title />
</head>
<body>
<t:call-next-template />
</body>
</html>
</t:chloe>

9
extra/http/server/templating/chloe/test/test4.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if code="http.server.templating.chloe.tests:test4-aux?">
True
</t:if>
</t:chloe>

9
extra/http/server/templating/chloe/test/test5.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if code="http.server.templating.chloe.tests:test5-aux?">
True
</t:if>
</t:chloe>

9
extra/http/server/templating/chloe/test/test6.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if var="http.server.templating.chloe.tests:test6-aux?">
True
</t:if>
</t:chloe>

9
extra/http/server/templating/chloe/test/test7.xml Normal file
View File

@ -0,0 +1,9 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if var="http.server.templating.chloe.tests:test7-aux?">
True
</t:if>
</t:chloe>

6
extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -1,13 +1,13 @@
USING: io io.files io.streams.string io.encodings.utf8
http.server.templating.fhtml kernel tools.test sequences
parser ;
http.server.templating http.server.templating.fhtml kernel
tools.test sequences parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"resource:extra/http/server/templating/fhtml/test/"
prepend
[
".fhtml" append [ run-template ] with-string-writer
".fhtml" append <fhtml> [ call-template ] with-string-writer
] keep
".html" append utf8 file-contents = ;

49
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -1,25 +1,22 @@
! Copyright (C) 2005 Alex Chapman
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel parser namespaces io
io.files io.streams.string html html.elements source-files
debugger combinators math quotations generic strings splitting
accessors http.server.static http.server assocs
io.encodings.utf8 fry ;
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting
accessors assocs fry
parser io io.files io.streams.string io.encodings.utf8 source-files
html html.elements
http.server.static http.server http.server.templating ;
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
! See apps/http-server/test/ or libs/furnace/ for template usage
! examples
! We use a custom lexer so that %> ends a token even if not
! followed by whitespace
TUPLE: template-lexer ;
TUPLE: template-lexer < lexer ;
: <template-lexer> ( lines -- lexer )
<lexer> template-lexer construct-delegate ;
template-lexer new-lexer ;
M: template-lexer skip-word
[
@ -33,18 +30,18 @@ M: template-lexer skip-word
DEFER: <% delimiter
: check-<% ( lexer -- col )
"<%" over lexer-line-text rot lexer-column start* ;
"<%" over line-text>> rot column>> start* ;
: found-<% ( accum lexer col -- accum )
[
over lexer-line-text
>r >r lexer-column r> r> subseq parsed
over line-text>>
>r >r column>> r> r> subseq parsed
\ write-html parsed
] 2keep 2 + swap set-lexer-column ;
] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
dup lexer-line-text swap lexer-column tail
[ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed
] keep next-line ;
@ -75,9 +72,13 @@ DEFER: <% delimiter
: html-error. ( error -- )
<pre> error. </pre> ;
: run-template ( filename -- )
TUPLE: fhtml path ;
C: <fhtml> fhtml
M: fhtml call-template ( filename -- )
'[
, [
, path>> [
"quiet" on
parser-notes off
templating-vocab use+
@ -88,16 +89,8 @@ DEFER: <% delimiter
] with-file-vocabs
] assert-depth ;
: template-convert ( infile outfile -- )
utf8 [ run-template ] with-file-writer ;
! responder integration
: serve-template ( name -- response )
"text/html" <content>
swap '[ , run-template ] >>body ;
! file responder integration
: enable-fhtml ( responder -- responder )
[ serve-template ]
[ <fhtml> serve-template ]
"application/x-factor-server-page"
pick special>> set-at ;

13
extra/http/server/templating/templating.factor Normal file
View File

@ -0,0 +1,13 @@
USING: accessors kernel fry io.encodings.utf8 io.files
http.server ;
IN: http.server.templating
GENERIC: call-template ( template -- )
: template-convert ( template output -- )
utf8 [ call-template ] with-file-writer ;
! responder integration
: serve-template ( template -- response )
"text/html" <content>
swap '[ , call-template ] >>body ;

6
extra/http/server/validators/validators.factor
View File

@ -11,8 +11,7 @@ TUPLE: validation-error value reason ;
C: <validation-error> validation-error
: with-validator ( value quot -- result )
[ validation-failed? on <validation-error> ] recover ;
inline
[ validation-failed? on <validation-error> ] recover ; inline
: v-default ( str def -- str )
over empty? spin ? ;
@ -20,6 +19,9 @@ C: <validation-error> validation-error
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
: v-optional ( str quot -- str )
over empty? [ 2drop f ] [ call ] if ; inline
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make

2
extra/io/monitors/monitors.factor
View File

@ -27,7 +27,7 @@ M: monitor timeout timeout>> ;
M: monitor set-timeout (>>timeout) ;
: construct-monitor ( path mailbox class -- monitor )
: new-monitor ( path mailbox class -- monitor )
new
swap >>queue
swap >>path ; inline

2
extra/io/monitors/recursive/recursive-tests.factor
View File

@ -21,7 +21,7 @@ M: dummy-monitor dispose
M: mock-io-backend (monitor)
nip
over exists? [
dummy-monitor construct-monitor
dummy-monitor new-monitor
dummy-monitor-created get [ 1+ ] change-i drop
] [
"Does not exist" throw

2
extra/io/monitors/recursive/recursive.factor
View File

@ -98,7 +98,7 @@ M: recursive-monitor dispose
: <recursive-monitor> ( path mailbox -- monitor )
>r (normalize-path) r>
recursive-monitor construct-monitor
recursive-monitor new-monitor
H{ } clone >>children
<promise> >>ready
dup start-pump-thread

2
extra/io/unix/backend/backend.factor
View File

@ -32,7 +32,7 @@ M: input-task io-task-container drop reads>> ;
M: output-task io-task-container drop writes>> ;
: construct-mx ( class -- obj )
: new-mx ( class -- obj )
new
H{ } clone >>reads
H{ } clone >>writes ; inline

2
extra/io/unix/epoll/epoll.factor
View File

@ -13,7 +13,7 @@ TUPLE: epoll-mx < mx events ;
256 ; inline
: <epoll-mx> ( -- mx )
epoll-mx construct-mx
epoll-mx new-mx
max-events epoll_create dup io-error over set-mx-fd
max-events "epoll-event" <c-array> over set-epoll-mx-events ;

4
extra/io/unix/kqueue/kqueue.factor
View File

@ -16,7 +16,7 @@ TUPLE: kqueue-mx < mx events monitors ;
256 ; inline
: <kqueue-mx> ( -- mx )
kqueue-mx construct-mx
kqueue-mx new-mx
H{ } clone >>monitors
kqueue dup io-error >>fd
max-events "kevent" <c-array> >>events ;
@ -142,7 +142,7 @@ TUPLE: vnode-monitor < monitor fd ;
: <vnode-monitor> ( path mailbox -- monitor )
>r [ O_RDONLY 0 open dup io-error ] keep r>
vnode-monitor construct-monitor swap >>fd
vnode-monitor new-monitor swap >>fd
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
M: vnode-monitor dispose

2
extra/io/unix/linux/monitors/monitors.factor
View File

@ -10,7 +10,7 @@ IN: io.unix.linux.monitors
TUPLE: linux-monitor < monitor wd ;
: <linux-monitor> ( wd path mailbox -- monitor )
linux-monitor construct-monitor
linux-monitor new-monitor
swap >>wd ;
SYMBOL: watches

2
extra/io/unix/macosx/macosx.factor
View File

@ -13,7 +13,7 @@ TUPLE: macosx-monitor < monitor handle ;
] curry each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
path mailbox macosx-monitor construct-monitor
path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle ;

2
extra/io/unix/select/select.factor
View File

@ -14,7 +14,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
little-endian? [ BIN: 11000 bitxor ] unless ; inline
: <select-mx> ( -- mx )
select-mx construct-mx
select-mx new-mx
FD_SETSIZE 8 * <bit-array> >>read-fdset
FD_SETSIZE 8 * <bit-array> >>write-fdset ;

2
extra/io/windows/nt/monitors/monitors.factor
View File

@ -98,7 +98,7 @@ TUPLE: win32-monitor < monitor port ;
M:: winnt (monitor) ( path recursive? mailbox -- monitor )
[
path mailbox win32-monitor construct-monitor
path mailbox win32-monitor new-monitor
path open-directory \ win32-monitor-port <buffered-port>
recursive? >>recursive
>>port

2
extra/peg/ebnf/ebnf-tests.factor
View File

@ -295,3 +295,5 @@ main = Primary
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
"x[i][j].y" primary parse-result-ast
] unit-test
'ebnf' compile must-infer

41
extra/peg/peg.factor
View File

@ -100,21 +100,21 @@ C: <head> peg-head
: setup-growth ( h p -- )
pos set dup involved-set>> clone >>eval-set drop ;
:: (grow-lr) ( h p r m -- )
h p setup-growth
r eval-rule
dup m stop-growth? [
drop
: (grow-lr) ( h p r m -- )
>r >r [ setup-growth ] 2keep r> r>
>r dup eval-rule r> swap
dup pick stop-growth? [
4drop drop
] [
m update-m
h p r m (grow-lr)
over update-m
(grow-lr)
] if ; inline
:: grow-lr ( h p r m -- ast )
h p heads get set-at
h p r m (grow-lr)
p heads get delete-at
m pos>> pos set m ans>>
: grow-lr ( h p r m -- ast )
>r >r [ heads get set-at ] 2keep r> r>
pick over >r >r (grow-lr) r> r>
swap heads get delete-at
dup pos>> pos set ans>>
; inline
:: (setup-lr) ( r l s -- )
@ -240,8 +240,21 @@ GENERIC: (compile) ( parser -- quot )
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
] if* ;
SYMBOL: delayed
: fixup-delayed ( -- )
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
delayed get [
call compiled-parser 1quotation 0 1 <effect> define-declared
] assoc-each ;
: compile ( parser -- word )
[ compiled-parser ] with-compilation-unit ;
[
H{ } clone delayed [
compiled-parser fixup-delayed
] with-variable
] with-compilation-unit ;
: compiled-parse ( state word -- result )
swap [ execute ] with-packrat ; inline
@ -451,7 +464,7 @@ M: delay-parser (compile) ( parser -- quot )
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ;
quot>> gensym [ delayed get set-at ] keep 1quotation ;
TUPLE: box-parser quot ;

33
extra/project-euler/164/164.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (c) 2008 Eric Mertens
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.ranges sequences ;
IN: project-euler.164
! http://projecteuler.net/index.php?section=problems&id=164
! DESCRIPTION
! -----------
! How many 20 digit numbers n (without any leading zero) exist such
! that no three consecutive digits of n have a sum greater than 9?
! SOLUTION
! --------
<PRIVATE
: next-keys ( key -- keys )
[ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
: next-table ( assoc -- assoc )
H{ } clone swap
[ swap next-keys [ pick at+ ] with each ] assoc-each ;
: init-table ( -- assoc )
9 [1,b] [ 1array 1 ] H{ } map>assoc ;
PRIVATE>
: euler164 ( -- n )
init-table 19 [ next-table ] times values sum ;

1
extra/sequences/lib/summary.txt Normal file
View File

@ -0,0 +1 @@
Non-core sequence words

1
extra/sequences/next/summary.txt Normal file
View File

@ -0,0 +1 @@
Iteration with access to next element

2
extra/serialize/serialize.factor
View File

@ -246,7 +246,7 @@ SYMBOL: deserialized
(deserialize) <wrapper> ;
:: (deserialize-seq) ( exemplar quot -- seq )
deserialize-cell exemplar new
deserialize-cell exemplar new-sequence
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline

2
extra/state-parser/state-parser.factor
View File

@ -97,7 +97,7 @@ SYMBOL: prolog-data
#! advance spot to after the substring.
[ [
dup slip swap dup [ get-char , ] unless
] skip-until ] "" make nip ;
] skip-until ] "" make nip ; inline
: rest ( -- string )
[ f ] take-until ;

2
extra/trees/splay/summary.txt
View File

@ -1 +1 @@
Splay Trees
Splay trees

62
extra/update/update.factor Normal file
View File

@ -0,0 +1,62 @@
USING: kernel system sequences io.files io.launcher bootstrap.image
builder.util builder.release.branch ;
IN: update
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-command ( cmd -- ) to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-pull-clean ( -- )
image parent-directory
[
{ "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
run-command
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-clean-image ( -- url )
"http://factorcode.org/images/clean/" my-boot-image-name append ;
: download-clean-image ( -- ) { "wget" remote-clean-image } run-command ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-clean ( -- ) { gnu-make "clean" } run-command ;
: make ( -- ) { gnu-make } run-command ;
: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rebuild ( -- )
image parent-directory
[
download-clean-image
make-clean
make
boot
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: update ( -- )
image parent-directory
[
git-id
git-pull-clean
git-id
= not
[ rebuild ]
when
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: update

26
extra/webapps/todo/edit-todo.xml Normal file
View File

@ -0,0 +1,26 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:title>Edit Item</t:title>
<t:form action="edit">
<t:edit component="id" />
<table>
<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
<tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
<t:a href="view" query="id">View</t:a>
|
<t:form action="delete" class="inline">
<t:edit component="id" />
<button type="submit" class="link-button link">Delete</button>
</t:form>
</t:chloe>

45
extra/webapps/todo/page.xml Normal file
View File

@ -0,0 +1,45 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<head>
<t:write-title />
<t:style>
body, button {
font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
color:#444;
}
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
.field-label {
text-align: right;
}
</t:style>
<t:write-style />
</head>
<body>
<t:call-next-template />
</body>
</t:chloe>
</html>

Some files were not shown because too many files have changed in this diff Show More