.gdb_history
*.*.marks
.*.swp
-reverse-complement-in.txt
-reverse-complement-out.txt
+temp
+logs
+work
+misc/wordsize
\ No newline at end of file
EXE_OBJS = $(PLAF_EXE_OBJS)
-default:
+default: misc/wordsize
+ make `./misc/target`
+
+help:
@echo "Run 'make' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
- cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+ mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+ ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
install_name_tool \
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+misc/wordsize: misc/wordsize.c
+ gcc misc/wordsize.c -o misc/wordsize
+
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor*.*
gcc.
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
-3.3 or earlier.
+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' (or 'gmake' on *BSD) with no parameters to see a list of
targets and build options. Then run 'make' with the appropriate target
HELP: alien-invoke-error
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
- { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
+ { "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "The symbol or library could not be found." }
{ "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
HELP: alien-indirect-error
{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
- { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
+ { "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
}
HELP: alien-callback-error
{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
- { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
+ { "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
}
{ $subsection alien-invoke }
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
{ $subsection alien-indirect }
-"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
-$nl
-"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ;
+"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ;
ARTICLE: "alien-callback-gc" "Callbacks and code GC"
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
-IN: temporary
+IN: alien.tests
USING: alien alien.accessors byte-arrays arrays kernel
kernel.private namespaces tools.test sequences libc math system
-prettyprint ;
+prettyprint layouts ;
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
-HELP: memory>byte-array ( base len -- string )
-{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
+HELP: memory>byte-array
+{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
-HELP: memory>char-string ( base len -- string )
-{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
-{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ;
-
-HELP: memory>u16-string ( base len -- string )
-{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
-{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ;
-
-HELP: byte-array>memory ( string base -- )
+HELP: byte-array>memory
{ $values { "byte-array" byte-array } { "base" c-ptr } }
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
-HELP: string>char-memory ( string base -- )
-{ $values { "string" string } { "base" c-ptr } }
-{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
-{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
-
-HELP: string>u16-memory ( string base -- )
-{ $values { "string" string } { "base" c-ptr } }
-{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
-{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
-
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
$nl
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
{ $subsection alien>char-string }
-{ $subsection alien>u16-string }
-{ $subsection memory>char-string }
-{ $subsection memory>u16-string }
-{ $subsection string>char-memory }
-{ $subsection string>u16-memory } ;
+{ $subsection alien>u16-string } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
-IN: temporary
+IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ;
generator.registers assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
-system compiler.units ;
+layouts system compiler.units io.files io.encodings.binary ;
IN: alien.c-types
DEFER: <int>
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
-: memory>char-string ( alien len -- string )
- memory>byte-array >string ;
-
-DEFER: c-ushort-array>
-
-: memory>u16-string ( alien len -- string )
- [ memory>byte-array ] keep 2/ c-ushort-array> >string ;
-
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
-: string>char-memory ( string base -- )
- >r B{ } like r> byte-array>memory ;
-
DEFER: >c-ushort-array
: string>u16-memory ( string base -- )
r> add*
] when ;
+: malloc-file-contents ( path -- alien )
+ binary file-contents malloc-byte-array ;
+
[
[ alien-cell ]
[ set-alien-cell ]
-IN: temporary\r
+IN: alien.compiler.tests\r
USING: alien alien.c-types alien.syntax compiler kernel\r
namespaces namespaces tools.test sequences inference words\r
arrays parser quotations continuations inference.backend effects\r
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
-compiler.errors continuations ;
+compiler.errors continuations layouts ;
IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect
] if ;
: do-callback ( quot token -- )
- init-error-handler
+ init-catchstack
dup 2 setenv
slip
wait-to-return ; inline
-IN: temporary
+IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ;
USING: arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ;
-IN: temporary
+IN: arrays.tests
[ -2 { "a" "b" "c" } nth ] must-fail
[ 10 { "a" "b" "c" } nth ] must-fail
{ $description "Applies a quotation to each entry in the assoc." }
{ $examples
{ $example
+ "USING: assocs kernel math prettyprint ;"
"H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }"
"0 swap [ nip + ] assoc-each ."
"64"
-IN: temporary
+IN: assocs.tests
USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
USING: sequences arrays bit-arrays kernel tools.test math
random ;
-IN: temporary
+IN: bit-arrays.tests
[ 100 ] [ 100 <bit-array> length ] unit-test
-IN: temporary\r
+IN: bit-vectors.tests\r
USING: tools.test bit-vectors vectors sequences kernel math ;\r
\r
[ 0 ] [ 123 <bit-vector> length ] unit-test\r
"cpu." cpu append require
+: enable-compiler ( -- )
+ [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ default-recompile-hook ] recompile-hook set-global ;
+
+enable-compiler
+
nl
"Compiling some words to speed up bootstrap..." write flush
malloc free memcpy
} compile
-: enable-compiler ( -- )
- [ compiled-usages recompile ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
-
-enable-compiler
-
" done" print flush
-IN: temporary
+IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test ;
\ ' must-infer
splitting growable classes tuples words.private
io.binary io.files vocabs vocabs.loader source-files
definitions debugger float-arrays quotations.private
-sequences.private combinators ;
+sequences.private combinators io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
M: fixnum '
#! When generating a 32-bit image on a 64-bit system,
#! some fixnums should be bignums.
- dup most-negative-fixnum most-positive-fixnum between?
+ dup
+ bootstrap-most-negative-fixnum
+ bootstrap-most-positive-fixnum between?
[ tag-fixnum ] [ >bignum ' ] if ;
! Floats
"Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
- [ (write-image) ] with-file-writer ;
+ binary <file-writer> [ (write-image) ] with-stream ;
PRIVATE>
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone changed-words set
-[ drop ] recompile-hook set
+
+! Trivial recompile hook. We don't want to touch the code heap
+! during stage1 bootstrap, it would just waste time.
+[ drop { } ] recompile-hook set
call
call
"strings"
"strings.private"
"system"
+ "system.private"
"threads.private"
"tools.profiler.private"
"tuples"
}
{
{ "object" "kernel" }
- "?"
+ "compiled?"
{ "compiled?" "words" }
f
}
{ "fopen" "io.streams.c" }
{ "fgetc" "io.streams.c" }
{ "fread" "io.streams.c" }
+ { "fputc" "io.streams.c" }
{ "fwrite" "io.streams.c" }
{ "fflush" "io.streams.c" }
{ "fclose" "io.streams.c" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
- { "(os-envs)" "system" }
+ { "(os-envs)" "system.private" }
+ { "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.stage1
USING: arrays debugger generic hashtables io assocs
kernel.private kernel math memory namespaces parser
prettyprint sequences vectors words system splitting
init io.files bootstrap.image bootstrap.image.private vocabs
-vocabs.loader system ;
+vocabs.loader system debugger continuations ;
{ "resource:core" } vocab-roots set
[
"resource:core/bootstrap/stage2.factor"
dup resource-exists? [
- run-file
+ [ run-file ]
+ [
+ :c
+ dup print-error flush
+ "listener" vocab
+ [ restarts. vocab-main execute ]
+ [ die ] if*
+ ] recover
] [
"Cannot find " write write "." print
"Please move " write image write " to the same directory as the Factor sources," print
: compile-remaining ( -- )
"Compiling remaining words..." print flush
- vocabs [
- words "compile" "compiler" lookup execute
- ] each ;
+ vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
! Wrap everything in a catch which starts a listener so
! you can see what went wrong, instead of dealing with a
! fep
-[
- ! We time bootstrap
- millis >r
- default-image-name "output-image" set-global
+! We time bootstrap
+millis >r
- "math help handbook compiler tools ui ui.tools io" "include" set-global
- "" "exclude" set-global
+default-image-name "output-image" set-global
- parse-command-line
+"math help handbook compiler tools ui ui.tools io" "include" set-global
+"" "exclude" set-global
- "-no-crossref" cli-args member? [ do-crossref ] unless
+parse-command-line
- ! Set dll paths
- wince? [ "windows.ce" require ] when
- winnt? [ "windows.nt" require ] when
+"-no-crossref" cli-args member? [ do-crossref ] unless
- "deploy-vocab" get [
- "stage2: deployment mode" print
- ] [
- "listener" require
- "none" require
- ] if
+! Set dll paths
+wince? [ "windows.ce" require ] when
+winnt? [ "windows.nt" require ] when
- [
- load-components
+"deploy-vocab" get [
+ "stage2: deployment mode" print
+] [
+ "listener" require
+ "none" require
+] if
+
+[
+ load-components
- run-bootstrap-init
+ run-bootstrap-init
- "bootstrap.compiler" vocab [
- compile-remaining
- ] when
- ] with-compiler-errors
- :errors
+ "bootstrap.compiler" vocab [
+ compile-remaining
+ ] when
+] with-compiler-errors
+:errors
- f error set-global
- f error-continuation set-global
+f error set-global
+f error-continuation set-global
- "deploy-vocab" get [
- "tools.deploy.shaker" run
- ] [
- [
- boot
- do-init-hooks
- [
- parse-command-line
- run-user-init
- "run" get run
- stdio get [ stream-flush ] when*
- ] [ print-error 1 exit ] recover
- ] set-boot-quot
-
- millis r> - dup bootstrap-time set-global
- print-report
-
- "output-image" get resource-path save-image-and-exit
- ] if
+"deploy-vocab" get [
+ "tools.deploy.shaker" run
] [
- :c
- print-error restarts.
- "listener" vocab-main execute
- 1 exit
-] recover
+ [
+ boot
+ do-init-hooks
+ [
+ parse-command-line
+ run-user-init
+ "run" get run
+ stdio get [ stream-flush ] when*
+ ] [ print-error 1 exit ] recover
+ ] set-boot-quot
+
+ millis r> - dup bootstrap-time set-global
+ print-report
+
+ "output-image" get resource-path save-image-and-exit
+] if
{ $errors "Throws an error if the box is empty." } ;\r
\r
HELP: ?box\r
-{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } }\r
+{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" "a boolean" } }\r
{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;\r
\r
ARTICLE: "boxes" "Boxes"\r
-IN: temporary\r
+IN: boxes.tests\r
USING: boxes namespaces tools.test ;\r
\r
[ ] [ <box> "b" set ] unit-test\r
\r
: ?box ( box -- value/f ? )\r
dup box-full? [ box> t ] [ drop f f ] if ;\r
+\r
+: if-box? ( box quot -- )\r
+ >r ?box r> [ drop ] if ; inline\r
-IN: temporary\r
+IN: byte-arrays.tests\r
USING: tools.test byte-arrays ;\r
\r
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test\r
-IN: temporary\r
+IN: byte-vectors.tests\r
USING: tools.test byte-vectors vectors sequences kernel ;\r
\r
[ 0 ] [ 123 <byte-vector> length ] unit-test\r
\r
<PRIVATE\r
\r
-: byte-array>vector ( byte-array capacity -- byte-vector )\r
+: byte-array>vector ( byte-array length -- byte-vector )\r
byte-vector construct-boa ; inline\r
\r
PRIVATE>\r
-USING: generic help.markup help.syntax kernel kernel.private
+USING: help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes.union classes.mixin
classes.predicate ;
ARTICLE: "builtin-classes" "Built-in classes"
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
$nl
-"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
-"Built-in type numbers can be converted to classes, and vice versa:"
-{ $subsection type>class }
-{ $subsection type-number }
"The set of built-in classes is a class:"
{ $subsection builtin-class }
{ $subsection builtin-class? }
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
-{ $examples { $example "USE: classes" "1.0 class ." "float" } { $example "USE: classes" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $class-description "The class of built-in classes." }
{ $examples
"The class of arrays is a built-in class:"
- { $example "USE: classes" "array builtin-class? ." "t" }
- "However, a literal array is not a built-in class; it is not even a class:"
- { $example "USE: classes" "{ 1 2 3 } builtin-class? ." "f" }
+ { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
+ "However, an instance of the array class is not a built-in class; it is not even a class:"
+ { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
} ;
HELP: tuple-class
{ $class-description "The class of tuple class words." }
-{ $examples { $example "USE: classes\nTUPLE: name title first last ;\nname tuple-class? ." "t" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: typemap
{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
HELP: class-empty?
{ $values { "class" "a class" } { "?" "a boolean" } }
{ $description "Tests if a class is a union class with no members." }
-{ $examples { $example "USE: classes" "null class-empty? ." "t" } } ;
+{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ;
HELP: (class<)
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
-{ sort-classes methods order } related-words
-
HELP: lookup-union
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
tools.test vectors words quotations classes io.streams.string
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ;
-IN: temporary
+IN: classes.tests
H{ } "s" set
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
-DEFER: bah
-FORGET: bah
+! DEFER: bah
+! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test generic see and parsing
-[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
+[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes
[ union-1 ] [ fixnum float class-or ] unit-test
-"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
+"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
[ object ] [ fixnum float class-or ] unit-test
-"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
+"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ t ] [ mx1 integer class< ] unit-test
[ t ] [ mx1 number class< ] unit-test
-"IN: temporary USE: arrays INSTANCE: array mx1" eval
+"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
[ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
-[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
+[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
[ ] [
{
"USING: sequences ;"
- "IN: temporary"
+ "IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
[ ] [
{
"USING: hashtables ;"
- "IN: temporary"
+ "IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
: (define-class) ( word props -- )
over reset-class
- over reset-generic
- over define-symbol
+ over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
t "class" set-word-prop ;
{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
{ $examples
- { $example "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
+ { $example "USING: combinators math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
HELP: recursive-hashcode
-IN: temporary
+IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words ;
USING: namespaces tools.test kernel command-line ;
-IN: temporary
+IN: command-line.tests
[
[ f ] [ "-no-user-init" cli-arg ] unit-test
USING: generator help.markup help.syntax words io parser
-assocs words.private sequences ;
+assocs words.private sequences compiler.units ;
IN: compiler
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
$nl
-"The main entry points to the optimizing compiler:"
-{ $subsection compile }
-{ $subsection recompile }
-{ $subsection recompile-all }
+"The main entry point to the optimizing compiler:"
+{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
-{ $subsection decompile }
-"The optimizing compiler can also compile and call a single quotation:"
-{ $subsection compile-call } ;
+{ $subsection decompile } ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
ABOUT: "compiler"
-HELP: compile
-{ $values { "seq" "a sequence of words" } }
-{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
-
-HELP: recompile
-{ $values { "seq" "a sequence of words" } }
-{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
-
-HELP: compile-call
-{ $values { "quot" "a quotation" } }
-{ $description "Compiles and runs a quotation." }
-{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
-
-HELP: recompile-all
-{ $description "Recompiles all words." } ;
-
HELP: decompile
{ $values { "word" word } }
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
+
+HELP: optimized-recompile-hook
+{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
+{ $description "Compile a set of words." }
+{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
inference.state generator debugger math.parser prettyprint words
compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs
-generic ;
+generic inference ;
IN: compiler
-: compiled-usages ( words -- seq )
- [ [ dup ] H{ } map>assoc dup ] keep [
- compiled-usage [ nip +inlined+ eq? ] assoc-subset update
- ] with each keys ;
-
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
compile-loop
] if ;
-: recompile ( words -- )
+: decompile ( word -- )
+ f 2array 1array t modify-code-heap ;
+
+: optimized-recompile-hook ( words -- alist )
[
H{ } clone compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
compiled get >alist
- dup [ drop crossref? ] assoc-contains?
- modify-code-heap
- ] with-scope ; inline
-
-: compile ( words -- )
- [ compiled? not ] subset recompile ;
-
-: compile-call ( quot -- )
- H{ } clone changed-words
- [ define-temp dup 1array compile ] with-variable
- execute ;
+ ] with-scope ;
: recompile-all ( -- )
- [ all-words recompile ] with-compiler-errors ;
-
-: decompile ( word -- )
- f 2array 1array t modify-code-heap ;
+ forget-errors all-words compile ;
{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
HELP: compiler-errors.
-{ $values { "errors" "an assoc mapping words to errors" } }
-{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
+{ $values { "type" symbol } }
+{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
-USING: tools.test compiler quotations math kernel sequences
-assocs namespaces ;
-IN: temporary
+USING: tools.test quotations math kernel sequences
+assocs namespaces compiler.units ;
+IN: compiler.tests
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
-IN: temporary
-USING: compiler kernel kernel.private memory math
+IN: compiler.tests
+USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
-IN: temporary
-USING: arrays compiler kernel kernel.private math math.constants
-math.private sequences strings tools.test words continuations
-sequences.private hashtables.private byte-arrays strings.private
-system random layouts vectors.private sbufs.private
-strings.private slots.private alien alien.accessors
-alien.c-types alien.syntax namespaces libc sequences.private ;
+IN: compiler.tests
+USING: arrays compiler.units kernel kernel.private math
+math.constants math.private sequences strings tools.test words
+continuations sequences.private hashtables.private byte-arrays
+strings.private system random layouts vectors.private
+sbufs.private strings.private slots.private alien
+alien.accessors alien.c-types alien.syntax namespaces libc
+sequences.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
-USING: compiler tools.test kernel kernel.private
+USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
-IN: temporary
+IN: compiler.tests
! Test empty word
[ ] [ [ ] compile-call ] unit-test
-IN: temporary
+IN: compiler.tests
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting sorting ;
! Testing templates machinery without compiling anything
-IN: temporary
+IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ;
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
words definitions compiler.units io combinators ;
-IN: temporary
+IN: compiler.tests
! Oops!
[ 5000 ] [ [ 5000 ] compile-call ] unit-test
-IN: temporary
-USING: kernel tools.test compiler ;
+IN: compiler.tests
+USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;
{ { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
} }
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
+
+HELP: compile
+{ $values { "words" "a sequence of words" } }
+{ $description "Compiles a set of words." } ;
+
+HELP: compile-call
+{ $values { "quot" "a quotation" } }
+{ $description "Compiles and runs a quotation." } ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables ;
+vocabs definitions hashtables init ;
IN: compiler.units
SYMBOL: old-definitions
SYMBOL: definition-observers
-definition-observers global [ V{ } like ] change-at
-
GENERIC: definitions-changed ( assoc obj -- )
+[ V{ } clone definition-observers set-global ]
+"compiler.units" add-init-hook
+
: add-definition-observer ( obj -- )
definition-observers get push ;
dup changed-words get update
dup dup changed-vocabs update ;
+: compile ( words -- )
+ recompile-hook get call
+ dup [ drop crossref? ] assoc-contains?
+ modify-code-heap ;
+
+SYMBOL: post-compile-tasks
+
+: after-compilation ( quot -- )
+ post-compile-tasks get push ;
+
+: call-recompile-hook ( -- )
+ changed-words get keys
+ compiled-usages recompile-hook get call ;
+
+: call-post-compile-tasks ( -- )
+ post-compile-tasks get [ call ] each ;
+
: finish-compilation-unit ( -- )
- changed-words get keys recompile-hook get call
+ call-recompile-hook
+ call-post-compile-tasks
+ dup [ drop crossref? ] assoc-contains? modify-code-heap
changed-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
H{ } clone changed-words set
H{ } clone forgotten-definitions set
+ V{ } clone post-compile-tasks set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
[ ] cleanup
] with-scope ; inline
-: default-recompile-hook
- [ f ] { } map>assoc
- dup [ drop crossref? ] assoc-contains?
- modify-code-heap ;
+: compile-call ( quot -- )
+ [ define-temp ] with-compilation-unit execute ;
+
+: default-recompile-hook ( words -- alist )
+ [ f ] { } map>assoc ;
recompile-hook global
[ [ default-recompile-hook ] or ]
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
-threads assocs words quotations ;
+assocs words quotations ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
"Two words raise an error in the innermost error handler for the current dynamic extent:"
{ $subsection throw }
{ $subsection rethrow }
-"Two words for establishing an error handler:"
+"Words for establishing an error handler:"
{ $subsection cleanup }
{ $subsection recover }
+{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ;
{ $subsection namestack }
{ $subsection set-namestack }
{ $subsection catchstack }
-{ $subsection set-catchstack }
-"The continuations implementation has hooks for single-steppers:"
-{ $subsection walker-hook }
-{ $subsection set-walker-hook }
-{ $subsection (continue-with) } ;
+{ $subsection set-catchstack } ;
ARTICLE: "continuations" "Continuations"
"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
-HELP: (continue-with)
-{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
-
HELP: continue
{ $values { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
{ $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
+HELP: ignore-errors
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
+
HELP: rethrow
{ $values { "error" object } }
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
{ $values { "error" "an error" } }
{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
$low-level-note ;
-
-HELP: init-error-handler
-{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
-
-HELP: break
-{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words
kernel.private ;
-IN: temporary
+IN: continuations.tests
: (callcc1-test)
swap 1- tuck swap ?push
SYMBOL: error
SYMBOL: error-continuation
+SYMBOL: error-thread
SYMBOL: restarts
<PRIVATE
#! with a declaration.
f { object } declare ;
+: init-catchstack V{ } clone 1 setenv ;
+
PRIVATE>
: catchstack ( -- catchstack ) catchstack* clone ; inline
PRIVATE>
-: set-walker-hook ( quot -- ) 3 setenv ; inline
-
-: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
-
: continue-with ( obj continuation -- )
- [
- walker-hook [ >r 2array r> ] when* (continue-with)
- ] 2 (throw) ;
+ [ (continue-with) ] 2 (throw) ;
: continue ( continuation -- )
f swap continue-with ;
SYMBOL: thread-error-hook
: rethrow ( error -- * )
+ dup save-error
catchstack* empty? [
thread-error-hook get-global
[ 1 (throw) ] [ die ] if*
] when
- dup save-error c> continue-with ;
+ c> continue-with ;
: recover ( try recovery -- )
>r [ swap >c call c> drop ] curry r> ifcc ; inline
+: ignore-errors ( quot -- )
+ [ drop ] recover ; inline
+
: cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry
recover r> call ; inline
condition-continuation
[ <restart> ] curry { } assoc>map
append ;
-
-<PRIVATE
-
-: init-error-handler ( -- )
- V{ } clone set-catchstack
- ! VM calls on error
- [
- continuation error-continuation set-global rethrow
- ] 5 setenv
- ! VM adds this to kernel errors, so that user-space
- ! can identify them
- "kernel-error" 6 setenv ;
-
-PRIVATE>
-
-! Debugging support
-: with-walker-hook ( continuation -- )
- [ swap set-walker-hook (continue) ] curry callcc1 ;
-
-SYMBOL: break-hook
-
-: break ( -- )
- continuation callstack
- over set-continuation-call
- walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
-
-GENERIC: (step-into) ( obj -- )
-
-M: wrapper (step-into) wrapped break ;
-M: object (step-into) break ;
-M: callable (step-into) \ break add* break ;
-IN: temporary
+IN: cpu.arm.assembler.tests
USING: assembler-arm math test namespaces sequences kernel
quotations ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
-generator.registers generator.fixup generator system
+generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line
-compiler io vocabs.loader ;
+compiler compiler.units io vocabs.loader ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
- [ sse2? ] compile-call [
+ [ optimized-recompile-hook ] recompile-hook [
+ [ sse2? ] compile-call
+ ] with-variable
+ [
" - yes" print
"cpu.x86.sse2" require
] [
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
-alien alien.accessors alien.compiler alien.structs slots
+layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
USING: cpu.x86.assembler kernel tools.test namespaces ;
-IN: temporary
+IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences
-words system ;
+words system layouts ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system ;
+help generic.standard continuations system debugger.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
-HELP: debug-help
-{ $description "Print a synopsis of useful debugger words." } ;
-
HELP: error-hook
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
HELP: assert-depth
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
+
+HELP: init-debugger
+{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ;
-IN: temporary\r
+IN: debugger.tests\r
USING: debugger kernel continuations tools.test ;\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
strings io.styles vectors words system splitting math.parser
tuples continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs ;
+generic.standard vocabs threads threads.private init
+kernel.private libc ;
IN: debugger
GENERIC: error. ( error -- )
: :get ( variable -- value )
error-continuation get continuation-name assoc-stack ;
+: :vars ( -- )
+ error-continuation get continuation-name namestack. ;
+
: :res ( n -- )
1- restarts get-global nth f restarts set-global restart ;
dup length [ restart. ] 2each
] if ;
-: debug-help ( -- )
- nl
- "Debugger commands:" print
- nl
- ":help - documentation for this error" print
- ":s - data stack at exception time" print
- ":r - retain stack at exception time" print
- ":c - call stack at exception time" print
- ":edit - jump to source location (parse errors only)" print
-
- ":get ( var -- value ) accesses variables at time of the error" print
- flush ;
-
: print-error ( error -- )
[ error. flush ] curry
[ global [ "Error in print-error!" print drop ] bind ]
SYMBOL: error-hook
-[ print-error restarts. debug-help ] error-hook set-global
+[
+ print-error
+ restarts.
+ nl
+ "Type :help for debugging help." print flush
+] error-hook set-global
: try ( quot -- )
[ error-hook get call ] recover ;
M: no-vocab summary
drop "Vocabulary does not exist" ;
+
+M: check-ptr summary
+ drop "Memory allocation failed" ;
+
+M: double-free summary
+ drop "Free failed since memory is not allocated" ;
+
+M: realloc-error summary
+ drop "Memory reallocation failed" ;
+
+: error-in-thread. ( -- )
+ error-thread get-global
+ "Error in thread " write
+ [
+ dup thread-id #
+ " (" % dup thread-name %
+ ", " % dup thread-quot unparse-short % ")" %
+ ] "" make swap write-object ":" print nl ;
+
+! Hooks
+M: thread error-in-thread ( error thread -- )
+ initial-thread get-global eq? [
+ die drop
+ ] [
+ global [
+ error-in-thread. print-error flush
+ ] bind
+ ] if ;
+
+<PRIVATE
+
+: init-debugger ( -- )
+ V{ } clone set-catchstack
+ ! VM calls on error
+ [
+ self error-thread set-global
+ continuation error-continuation set-global
+ rethrow
+ ] 5 setenv
+ ! VM adds this to kernel errors, so that user-space
+ ! can identify them
+ "kernel-error" 6 setenv ;
+
+PRIVATE>
+
+[ init-debugger ] "debugger" add-init-hook
-IN: temporary
+IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units ;
: xref ( defspec -- ) dup uses crossref get add-vertex ;
-: usage ( defspec -- seq ) crossref get at keys ;
+: usage ( defspec -- seq ) \ f or crossref get at keys ;
GENERIC: redefined* ( defspec -- )
USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint
math ;
-IN: temporary
+IN: dlists.tests
[ t ] [ <dlist> dlist-empty? ] unit-test
{ $values { "effect" effect } { "string" string } }
{ $description "Turns a stack effect object into a string mnemonic." }
{ $examples
- { $example "USE: effects" "1 2 <effect> effect>string print" "( object -- object object )" }
+ { $example "USING: effects io ;" "1 2 <effect> effect>string print" "( object -- object object )" }
} ;
HELP: stack-effect
-IN: temporary
+IN: effects.tests
USING: effects tools.test ;
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
-IN: temporary
+IN: float-arrays.tests
USING: float-arrays tools.test ;
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
-IN: temporary\r
+IN: float-vectors.tests\r
USING: tools.test float-vectors vectors sequences kernel ;\r
\r
[ 0 ] [ 123 <float-vector> length ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
-quotations strings alien system combinators math.bitfields
-words.private cpu.architecture ;
+quotations strings alien layouts system combinators
+math.bitfields words.private cpu.architecture ;
IN: generator.fixup
: no-stack-frame -1 ; inline
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
HELP: word-dataflow
-{ $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } }
+{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } }
{ $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
HELP: define-intrinsics
-USING: help.markup help.syntax generic.math generic.standard
-words classes definitions kernel alien combinators sequences
-math quotations ;
+USING: help.markup help.syntax words classes definitions kernel
+alien sequences math quotations generic.standard generic.math
+combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"
"New generic words can be defined:"
{ $subsection define-generic }
{ $subsection define-simple-generic }
-"Methods are tuples:"
-{ $subsection <method> }
"Methods can be added to existing generic words:"
{ $subsection define-method }
"Method definitions can be looked up:"
{ $subsection methods }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
-"Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
+"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
{ $subsection make-generic }
+"Low-level method constructor:"
+{ $subsection <method> }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
{ $subsection method-spec } ;
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
+HELP: method-body
+{ $class-description "The class of method bodies, which are words with special word properties set." } ;
+
HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
-{ $description "Looks up a method definition." }
-{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
+{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
+{ $description "Looks up a method definition." } ;
{ method define-method POSTPONE: M: } related-words
HELP: <method>
-{ $values { "def" "a quotation" } { "method" "a new method definition" } }
-{ $description "Creates a new "{ $link method } " instance." } ;
+{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
+{ $description "Creates a new method." } ;
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
$low-level-note ;
HELP: define-method
-{ $values { "method" quotation } { "class" class } { "generic" generic } }
+{ $values { "quot" quotation } { "class" class } { "generic" generic } }
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
HELP: implementors
HELP: forget-methods
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
+
+{ sort-classes methods order } related-words
prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting
compiler.units ;
-IN: temporary
+IN: generic.tests
GENERIC: foobar ( x -- y )
M: object foobar drop "Hello world" ;
[ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions
-"IN: temporary GENERIC: unhappy ( x -- x )" eval
+"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
[
- "IN: temporary M: dictionary unhappy ;" eval
+ "IN: generic.tests M: dictionary unhappy ;" eval
] must-fail
-[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
+[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
TUPLE: redefinition-test-tuple ;
-"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval
+"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
[ t ] [
[
redefinition-test-generic ,
- "IN: temporary TUPLE: redefinition-test-tuple ;" eval
+ "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
redefinition-test-generic ,
] { } make all-equal?
] unit-test
PREDICATE: word generic "combination" word-prop >boolean ;
-M: generic definer drop f f ;
-
M: generic definition drop f ;
: make-generic ( word -- )
dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ;
-TUPLE: method word def specializer generic loc ;
-
: method ( class generic -- method/f )
"methods" word-prop at ;
: methods ( word -- assoc )
"methods" word-prop
[ keys sort-classes ] keep
- [ dupd at method-word ] curry { } map>assoc ;
+ [ dupd at ] curry { } map>assoc ;
TUPLE: check-method class generic ;
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
-: make-method-def ( quot word combination -- quot )
+: make-method-def ( quot class generic -- quot )
"combination" word-prop method-prologue swap append ;
-PREDICATE: word method-body "method" word-prop >boolean ;
+PREDICATE: word method-body "method-def" word-prop >boolean ;
M: method-body stack-effect
- "method" word-prop method-generic stack-effect ;
+ "method-generic" word-prop stack-effect ;
-: <method-word> ( quot class generic -- word )
- [ make-method-def ] 2keep
- method-word-name f <word>
- dup rot define
- dup xref ;
+: method-word-props ( quot class generic -- assoc )
+ [
+ "method-generic" set
+ "method-class" set
+ "method-def" set
+ ] H{ } make-assoc ;
: <method> ( quot class generic -- method )
check-method
- [ <method-word> ] 3keep f \ method construct-boa
- dup method-word over "method" set-word-prop ;
+ [ make-method-def ] 3keep
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ tuck set-word-props
+ dup rot define ;
: redefine-method ( quot class generic -- )
- [ method set-method-def ] 3keep
+ [ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep
- method method-word swap define ;
+ method swap define ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
! Definition protocol
M: method-spec where
- dup first2 method [ method-loc ] [ second where ] ?if ;
+ dup first2 method [ ] [ second ] ?if where ;
-M: method-spec set-where first2 method set-method-loc ;
+M: method-spec set-where
+ first2 method set-where ;
-M: method-spec definer drop \ M: \ ; ;
+M: method-spec definer
+ drop \ M: \ ; ;
M: method-spec definition
- first2 method dup [ method-def ] when ;
+ first2 method dup
+ [ "method-def" word-prop ] when ;
: forget-method ( class generic -- )
check-method
[ delete-at* ] with-methods
- [ method-word forget ] [ drop ] if ;
+ [ forget-word ] [ drop ] if ;
+
+M: method-spec forget*
+ first2 forget-method ;
+
+M: method-body definer
+ drop \ M: \ ; ;
+
+M: method-body definition
+ "method-def" word-prop ;
-M: method-spec forget* first2 forget-method ;
+M: method-body forget*
+ dup "method-class" word-prop
+ swap "method-generic" word-prop
+ forget-method ;
: implementors* ( classes -- words )
all-words [
M: generic subwords
dup "methods" word-prop values
- swap "default-method" word-prop add
- [ method-word ] map ;
+ swap "default-method" word-prop add ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;
USING: kernel generic help.markup help.syntax math classes
-generic.math ;
+sequences quotations ;
+IN: generic.math
HELP: math-upgrade
-{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
+{ $values { "class1" class } { "class2" class } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
-{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
+{ $examples { $example "USING: generic.math math kernel prettyprint ;" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
HELP: no-math-method
-{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } }
+{ $values { "left" "an object" } { "right" "an object" } { "generic" generic } }
{ $description "Throws a " { $link no-math-method } " error." }
{ $error-description "Thrown by generic words using the " { $link math-combination } " method combination if there is no suitable method defined for the two inputs." } ;
HELP: math-method
-{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } }
+{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
+{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
HELP: math-combination
-{ $values { "word" "a generic word" } { "quot" "a quotation" } }
+{ $values { "word" generic } { "quot" quotation } }
{ $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two."
$nl
"The math method combination is used for binary operators such as " { $link + } " and " { $link * } "."
{ $class-description "The class of generic words using " { $link math-combination } "." } ;
HELP: last/first
-{ $values { "seq" "a sequence" } { "pair" "a two-element array" } }
+{ $values { "seq" sequence } { "pair" "a two-element array" } }
{ $description "Creates an array holding the first and last element of the sequence." } ;
: applicable-method ( generic class -- quot )
over method
- [ method-word word-def ]
+ [ word-def ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )
-USING: generic help.markup help.syntax sequences
-generic.standard ;
+USING: generic help.markup help.syntax sequences ;
+IN: generic.standard
HELP: no-method
{ $values { "object" "an object" } { "generic" "a generic word" } }
] if ;
: default-method ( word -- pair )
- "default-method" word-prop method-word
+ "default-method" word-prop
object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot )
ABOUT: "growable"
HELP: set-fill
-{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } }
+{ $values { "n" "a new fill pointer" } { "seq" growable } }
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
{ $side-effects "seq" }
-{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
+{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
HELP: underlying
-{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } }
+{ $values { "seq" growable } { "underlying" "the underlying sequence" } }
{ $contract "Outputs the underlying storage of a resizable sequence." } ;
HELP: set-underlying
-{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } }
+{ $values { "underlying" sequence } { "seq" growable } }
{ $contract "Modifies the underlying storage of a resizable sequence." }
-{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
+{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
HELP: capacity
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
{ $description "Computes the new size of a resizable sequence." } ;
HELP: ensure
-{ $values { "n" "a positive integer" } { "seq" "a resizable sequence" } }
+{ $values { "n" "a positive integer" } { "seq" growable } }
{ $description "If " { $snippet "n" } " is less than the length of the sequence, does nothing. Otherwise, if " { $snippet "n" } " also exceeds the capacity of the underlying storage, the underlying storage is grown, and the fill pointer is reset. Finally, if " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done."
$nl
"This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the resizable sequence protocol (see " { $link "growable" } ")."
USING: math sequences classes growable tools.test kernel
layouts ;
-IN: temporary
+IN: growable.tests
! erg found this one
[ fixnum ] [
{ $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 "USE: hashtables" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
+ { $example "USING: hashtables 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
- "USE: combinators.lib"
+ "USING: hashtables prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
"f"
} ;
-IN: temporary
+IN: hashtables.tests
USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors ;
+ math.private sequences sequences.private vectors ;
IN: hashtables
<PRIVATE
2 fixnum+fast over wrap ; inline
: (key@) ( key keys i -- array n ? )
- #! cond form expanded by hand for better interpreter speed
- 3dup swap array-nth dup ((tombstone)) eq? [
- 2drop probe (key@)
- ] [
- dup ((empty)) eq? [
- 3drop nip f f
- ] [
- = [ rot drop t ] [ probe (key@) ] if
- ] if
- ] if ; inline
+ 3dup swap array-nth
+ dup ((empty)) eq?
+ [ 3drop nip f f ]
+ [
+ =
+ [ rot drop t ]
+ [ probe (key@) ]
+ if
+ ]
+ if ; inline
: key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline
swap <hash-array> over set-hash-array init-hash ;
: (new-key@) ( key keys i -- keys n empty? )
- #! cond form expanded by hand for better interpreter speed
3dup swap array-nth dup ((empty)) eq? [
2drop rot drop t
] [
{ $subsection min-heap? }
{ $subsection <min-heap> }
"Max-heaps sort their elements so that the maximum element is first:"
-{ $subsection min-heap }
-{ $subsection min-heap? }
-{ $subsection <min-heap> }
+{ $subsection max-heap }
+{ $subsection max-heap? }
+{ $subsection <max-heap> }
"Both obey a protocol."
$nl
"Queries:"
{ $subsection heap-empty? }
-{ $subsection heap-length }
+{ $subsection heap-size }
{ $subsection heap-peek }
"Insertion:"
{ $subsection heap-push }
+{ $subsection heap-push* }
{ $subsection heap-push-all }
"Removal:"
{ $subsection heap-pop* }
-{ $subsection heap-pop } ;
+{ $subsection heap-pop }
+{ $subsection heap-delete } ;
ABOUT: "heaps"
HELP: <min-heap>
{ $values { "min-heap" min-heap } }
-{ $description "Create a new " { $link min-heap } "." }
-{ $see-also <max-heap> } ;
+{ $description "Create a new " { $link min-heap } "." } ;
HELP: <max-heap>
{ $values { "max-heap" max-heap } }
-{ $description "Create a new " { $link max-heap } "." }
-{ $see-also <min-heap> } ;
+{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
-{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
-{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
-{ $side-effects "heap" }
-{ $see-also heap-push-all heap-pop } ;
+{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
+{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
+{ $side-effects "heap" } ;
+
+HELP: heap-push*
+{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
+{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
+{ $side-effects "heap" } ;
HELP: heap-push-all
-{ $values { "assoc" assoc } { "heap" heap } }
+{ $values { "assoc" assoc } { "heap" "a heap" } }
{ $description "Push every key/value pair of an assoc onto a heap." }
-{ $side-effects "heap" }
-{ $see-also heap-push heap-pop } ;
+{ $side-effects "heap" } ;
HELP: heap-peek
-{ $values { "heap" heap } { "key" object } { "value" object } }
-{ $description "Outputs the first element in the heap, leaving it in the heap." }
-{ $see-also heap-pop heap-pop* } ;
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
-{ $values { "heap" heap } }
-{ $description "Removes the first element from the heap." }
-{ $side-effects "heap" }
-{ $see-also heap-pop heap-push heap-peek } ;
+{ $values { "heap" "a heap" } }
+{ $description "Remove the first element from the heap." }
+{ $side-effects "heap" } ;
HELP: heap-pop
-{ $values { "heap" heap } { "key" object } { "value" object } }
-{ $description "Outputs the first element in the heap and removes it from the heap." }
-{ $side-effects "heap" }
-{ $see-also heap-pop* heap-push heap-peek } ;
+{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $description "Output and remove the first element in the heap." }
+{ $side-effects "heap" } ;
HELP: heap-empty?
-{ $values { "heap" heap } { "?" "a boolean" } }
-{ $description "Tests if a " { $link heap } " has no nodes." }
-{ $see-also heap-length heap-peek } ;
+{ $values { "heap" "a heap" } { "?" "a boolean" } }
+{ $description "Tests if a heap has no nodes." } ;
+
+HELP: heap-size
+{ $values { "heap" "a heap" } { "n" integer } }
+{ $description "Returns the number of key/value pairs in the heap." } ;
-HELP: heap-length
-{ $values { "heap" heap } { "n" integer } }
-{ $description "Returns the number of key/value pairs in the heap." }
-{ $see-also heap-empty? } ;
+HELP: heap-delete
+{ $values { "entry" entry } { "heap" "a heap" } }
+{ $description "Remove the specified entry from the heap." }
+{ $errors "Throws an error if the entry is from another heap or if it has already been deleted." }
+{ $side-effects "heap" } ;
-! Copyright 2007 Ryan Murphy
+! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
-heaps heaps.private ;
-IN: temporary
+heaps heaps.private math.parser random assocs sequences sorting ;
+IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
[ <max-heap> heap-pop ] must-fail
! Binary Min Heap
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
-{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
-{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
-
-[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
-[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
-
-[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
- <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
- 3 [ dup heap-pop* ] times
-] unit-test
+{ t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
+{ f } [ t 5 f <entry> t 3 f <entry> T{ max-heap } heap-compare ] unit-test
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
-[ 0 ] [ <max-heap> heap-length ] unit-test
-[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
-
-[ { { 1 2 } { 3 4 } { 5 6 } } ] [
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
- [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
-] unit-test
-[ { { 1 2 } } ] [
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
- [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
-] unit-test
-[ { } ] [
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
- [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
-] unit-test
+[ 0 ] [ <max-heap> heap-size ] unit-test
+[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
+
+: heap-sort ( alist -- keys )
+ <min-heap> [ heap-push-all ] keep heap-pop-all ;
+
+: random-alist ( n -- alist )
+ [
+ [
+ (random) dup number>string swap set
+ ] times
+ ] H{ } make-assoc ;
+
+: test-heap-sort ( n -- ? )
+ random-alist dup >alist sort-keys swap heap-sort = ;
+
+14 [
+ [ t ] swap [ 2^ test-heap-sort ] curry unit-test
+] each
+
+: test-entry-indices ( n -- ? )
+ random-alist
+ <min-heap> [ heap-push-all ] keep
+ heap-data dup length swap [ entry-index ] map sequence= ;
+
+14 [
+ [ t ] swap [ 2^ test-entry-indices ] curry unit-test
+] each
+
+: delete-random ( seq -- elt )
+ dup length random dup pick nth >r swap delete-nth r> ;
+
+: sort-entries ( entries -- entries' )
+ [ [ entry-key ] compare ] sort ;
+
+: delete-test ( n -- ? )
+ [
+ random-alist
+ <min-heap> [ heap-push-all ] keep
+ dup heap-data clone swap
+ ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
+ heap-data
+ [ [ entry-key ] map ] 2apply
+ [ natural-sort ] 2apply ;
+
+11 [
+ [ t ] swap [ 2^ delete-test sequence= ] curry unit-test
+] each
-! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
+! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
+! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences arrays assocs ;
+USING: kernel math sequences arrays assocs sequences.private
+growable ;
IN: heaps
MIXIN: priority-queue
-GENERIC: heap-push ( value key heap -- )
+GENERIC: heap-push* ( value key heap -- entry )
GENERIC: heap-peek ( heap -- value key )
GENERIC: heap-pop* ( heap -- )
GENERIC: heap-pop ( heap -- value key )
-GENERIC: heap-delete ( key heap -- )
-GENERIC: heap-delete* ( key heap -- old ? )
+GENERIC: heap-delete ( entry heap -- )
GENERIC: heap-empty? ( heap -- ? )
-GENERIC: heap-length ( heap -- n )
-GENERIC# heap-pop-while 2 ( heap pred quot -- )
+GENERIC: heap-size ( heap -- n )
<PRIVATE
-TUPLE: heap data ;
+
+: heap-data delegate ; inline
: <heap> ( class -- heap )
- >r V{ } clone heap construct-boa r>
- construct-delegate ; inline
+ >r V{ } clone r> construct-delegate ; inline
+
+TUPLE: entry value key heap index ;
+
+: <entry> ( value key heap -- entry ) f entry construct-boa ;
+
PRIVATE>
TUPLE: min-heap ;
INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
+M: priority-queue heap-empty? ( heap -- ? )
+ heap-data empty? ;
+
+M: priority-queue heap-size ( heap -- n )
+ heap-data length ;
+
<PRIVATE
-: left ( n -- m ) 2 * 1+ ; inline
-: right ( n -- m ) 2 * 2 + ; inline
-: up ( n -- m ) 1- 2 /i ; inline
-: left-value ( n heap -- obj ) >r left r> nth ; inline
-: right-value ( n heap -- obj ) >r right r> nth ; inline
-: up-value ( n vec -- obj ) >r up r> nth ; inline
-: swap-up ( n vec -- ) >r dup up r> exchange ; inline
-: last-index ( vec -- n ) length 1- ; inline
+
+: left ( n -- m ) 1 shift 1 + ; inline
+
+: right ( n -- m ) 1 shift 2 + ; inline
+
+: up ( n -- m ) 1- 2/ ; inline
+
+: data-nth ( n heap -- entry )
+ heap-data nth-unsafe ; inline
+
+: up-value ( n heap -- entry )
+ >r up r> data-nth ; inline
+
+: left-value ( n heap -- entry )
+ >r left r> data-nth ; inline
+
+: right-value ( n heap -- entry )
+ >r right r> data-nth ; inline
+
+: data-set-nth ( entry n heap -- )
+ >r [ swap set-entry-index ] 2keep r>
+ heap-data set-nth-unsafe ;
+
+: data-push ( entry heap -- n )
+ dup heap-size [
+ swap 2dup heap-data ensure 2drop data-set-nth
+ ] keep ; inline
+
+: data-pop ( heap -- entry )
+ heap-data pop ; inline
+
+: data-pop* ( heap -- )
+ heap-data pop* ; inline
+
+: data-peek ( heap -- entry )
+ heap-data peek ; inline
+
+: data-first ( heap -- entry )
+ heap-data first ; inline
+
+: data-exchange ( m n heap -- )
+ [ tuck data-nth >r data-nth r> ] 3keep
+ tuck >r >r data-set-nth r> r> data-set-nth ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ first ] compare 0 ; inline
+
+: (heap-compare) drop [ entry-key ] compare 0 ; inline
+
M: min-heap heap-compare (heap-compare) > ;
+
M: max-heap heap-compare (heap-compare) < ;
: heap-bounds-check? ( m heap -- ? )
- heap-data length >= ; inline
+ heap-size >= ; inline
: left-bounds-check? ( m heap -- ? )
>r left r> heap-bounds-check? ; inline
: right-bounds-check? ( m heap -- ? )
>r right r> heap-bounds-check? ; inline
-: up-heap-continue? ( vec heap -- ? )
- >r [ last-index ] keep [ up-value ] keep peek r>
+: continue? ( m up[m] heap -- ? )
+ [ data-nth swap ] keep [ data-nth ] keep
heap-compare ; inline
-: up-heap ( vec heap -- )
- 2dup up-heap-continue? [
- >r dup last-index [ over swap-up ] keep
- up 1+ head-slice r> up-heap
+DEFER: up-heap
+
+: (up-heap) ( n heap -- )
+ >r dup up r>
+ 3dup continue? [
+ [ data-exchange ] 2keep up-heap
] [
- 2drop
+ 3drop
] if ;
+: up-heap ( n heap -- )
+ over 0 > [ (up-heap) ] [ 2drop ] if ;
+
: (child) ( m heap -- n )
- dupd
- [ heap-data left-value ] 2keep
- [ heap-data right-value ] keep heap-compare
+ 2dup right-value
+ >r 2dup left-value r>
+ rot heap-compare
[ right ] [ left ] if ;
: child ( m heap -- n )
- 2dup right-bounds-check? [ drop left ] [ (child) ] if ;
+ 2dup right-bounds-check?
+ [ drop left ] [ (child) ] if ;
: swap-down ( m heap -- )
- [ child ] 2keep heap-data exchange ;
+ [ child ] 2keep data-exchange ;
DEFER: down-heap
-: down-heap-continue? ( heap m heap -- m heap ? )
- [ heap-data nth ] 2keep child pick
- dupd [ heap-data nth swapd ] keep heap-compare ;
-
: (down-heap) ( m heap -- )
- 2dup down-heap-continue? [
- -rot [ swap-down ] keep down-heap
- ] [
+ [ child ] 2keep swapd
+ 3dup continue? [
3drop
+ ] [
+ [ data-exchange ] 2keep down-heap
] if ;
: down-heap ( m heap -- )
PRIVATE>
-M: priority-queue heap-push ( value key heap -- )
- >r swap 2array r>
- [ heap-data push ] keep
- [ heap-data ] keep
- up-heap ;
+M: priority-queue heap-push* ( value key heap -- entry )
+ [ <entry> dup ] keep [ data-push ] keep up-heap ;
+
+: heap-push ( value key heap -- ) heap-push* drop ;
: heap-push-all ( assoc heap -- )
[ swapd heap-push ] curry assoc-each ;
-M: priority-queue heap-peek ( heap -- value key )
- heap-data first first2 swap ;
+: >entry< ( entry -- key value )
+ { entry-value entry-key } get-slots ;
-M: priority-queue heap-pop* ( heap -- )
- dup heap-data length 1 > [
- [ heap-data pop ] keep
- [ heap-data set-first ] keep
- 0 swap down-heap
+M: priority-queue heap-peek ( heap -- value key )
+ data-first >entry< ;
+
+: entry>index ( entry heap -- n )
+ over entry-heap eq? [
+ "Invalid entry passed to heap-delete" throw
+ ] unless
+ entry-index ;
+
+M: priority-queue heap-delete ( entry heap -- )
+ [ entry>index ] keep
+ 2dup heap-size 1- = [
+ nip data-pop*
] [
- heap-data pop*
+ [ nip data-pop ] 2keep
+ [ data-set-nth ] 2keep
+ down-heap
] if ;
-M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
-
-M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
-
-M: priority-queue heap-length ( heap -- n ) heap-data length ;
+M: priority-queue heap-pop* ( heap -- )
+ dup data-first swap heap-delete ;
-: (heap-pop-while) ( heap pred quot -- )
- pick heap-empty? [
- 3drop
- ] [
- [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
- roll [ (heap-pop-while) ] [ 3drop ] if
- ] if ;
+M: priority-queue heap-pop ( heap -- value key )
+ dup data-first [ swap heap-delete ] keep >entry< ;
-M: priority-queue heap-pop-while ( heap pred quot -- )
- [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
+: heap-pop-all ( heap -- alist )
+ [ dup heap-empty? not ]
+ [ dup heap-pop swap 2array ]
+ [ ] unfold nip ;
recursive-state get at ;
: inline? ( word -- ? )
- dup "method" word-prop
- [ method-generic inline? ] [ "inline" word-prop ] ?if ;
+ dup "method-generic" word-prop swap or "inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
-IN: temporary
+IN: inference.class.tests
USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
-system ;
+system layouts ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
[ HEX: ff bitand 0 HEX: ff between? ]
\ >= inlined?
] unit-test
+
+[ t ] [
+ [ HEX: ff swap HEX: ff bitand >= ]
+ \ >= inlined?
+] unit-test
+
+
continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string io.timeouts
-sequences.private ;
-IN: temporary
+io.thread sequences.private ;
+IN: inference.tests
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
\ error. must-infer
! Test odds and ends
-\ idle-thread must-infer
+\ io-thread must-infer
! Incorrect stack declarations on inline recursive words should
! be caught
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector compiler.units ;
+words words.private assocs inspector compiler.units
+system.private ;
IN: inference.known-words
! Shuffle words
\ fwrite { string alien } { } <effect> set-primitive-effect
+\ fputc { object alien } { } <effect> set-primitive-effect
+
\ fread { integer string } { object } <effect> set-primitive-effect
\ fflush { alien } { } <effect> set-primitive-effect
\ (os-envs) { } { array } <effect> set-primitive-effect
+\ (set-os-envs) { array } { } <effect> set-primitive-effect
+
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
-IN: temporary
-USING: tools.test inference.state ;
+IN: inference.state.tests
+USING: tools.test inference.state words ;
SYMBOL: a
SYMBOL: b
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel ;
+USING: assocs namespaces sequences kernel words ;
IN: inference.state
! Nesting state to solve recursion
! Words that the current dataflow IR depends on
SYMBOL: dependencies
-SYMBOL: +inlined+
-SYMBOL: +called+
-
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
-IN: temporary
+IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
quotations inference ;
--- /dev/null
+IN: init.tests
+USING: init namespaces sequences math tools.test kernel ;
+
+[ t ] [
+ init-hooks get [ first "libc" = ] find drop
+ init-hooks get [ first "io.backend" = ] find drop <
+] unit-test
dup init-hooks get at [ over call ] unless
init-hooks get set-at ;
-: boot ( -- ) init-namespaces init-error-handler ;
+: boot ( -- ) init-namespaces init-catchstack ;
: boot-quot ( -- quot ) 20 getenv ;
USING: kernel tools.test math namespaces prettyprint
sequences inspector io.streams.string ;
-IN: temporary
+IN: inspector.tests
[ 1 2 3 ] describe
f describe
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
: describe ( obj -- ) H{ } describe* ;
+: namestack. ( seq -- )
+ [
+ [ global eq? not ] subset
+ [ keys ] map concat prune
+ ] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
+
+: .vars ( -- )
+ namestack namestack. ;
+
SYMBOL: inspector-hook
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
-IN: temporary\r
+IN: io.backend.tests\r
USING: tools.test io.backend kernel ;\r
\r
[ ] [ "a" normalize-pathname drop ] unit-test\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: init kernel system namespaces ;
+USING: init kernel system namespaces io io.encodings io.encodings.utf8 ;
IN: io.backend
SYMBOL: io-backend
HOOK: init-io io-backend ( -- )
-HOOK: init-stdio io-backend ( -- )
+HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
+
+: init-stdio ( -- )
+ (init-stdio) utf8 <encoder> stderr set-global
+ utf8 <encoder-duplex> stdio set-global ;
HOOK: io-multiplex io-backend ( ms -- )
M: object normalize-pathname ;
-: set-io-backend ( backend -- )
+: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio ;
[ init-io embedded? [ init-stdio ] unless ]
-USING: io.binary tools.test ;
-IN: temporary
+USING: io.binary tools.test classes math ;
+IN: io.binary.tests
-[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
-[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
+[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
+[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test
+
+[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test
USING: kernel math sequences ;
IN: io.binary
-: le> ( seq -- x ) B{ } like byte-array>bignum ;
+: le> ( seq -- x ) B{ } like byte-array>bignum >integer ;
: be> ( seq -- x ) <reversed> le> ;
: mask-byte ( x -- y ) HEX: ff bitand ; inline
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- str ) [ nth-byte ] with "" map-as ;
+: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
: >be ( x n -- str ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
HELP: lines-crc32
-{ $values { "lines" "a sequence of strings" } { "n" integer } }
+{ $values { "seq" "a sequence of strings" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
ARTICLE: "io.crc32" "CRC32 checksum calculation"
+Daniel Ehrenberg
Slava Pestov
IN: io.encodings.binary
HELP: binary
-{ $class-description "This is the encoding descriptor for binary I/O." } ;
+{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ;
-USING: kernel io.encodings ;
-
-TUPLE: binary ;
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+IN: io.encodings.binary SYMBOL: binary
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.encodings
+
+ABOUT: "encodings"
+
+ARTICLE: "io.encodings" "I/O encodings"
+"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream."
+{ $subsection "encodings-constructors" }
+{ $subsection "encodings-descriptors" }
+{ $subsection "encodings-protocol" } ;
+
+ARTICLE: "encodings-constructors" "Constructing an encoded stream"
+{ $subsection <encoder> }
+{ $subsection <decoder> }
+{ $subsection <encoder-duplex> } ;
+
+HELP: <encoder> ( stream encoding -- newstream )
+{ $values { "stream" "an output stream" }
+ { "encoding" "an encoding descriptor" }
+ { "newstream" "an encoded output stream" } }
+{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
+
+HELP: <decoder> ( stream encoding -- newstream )
+{ $values { "stream" "an input stream" }
+ { "encoding" "an encoding descriptor" }
+ { "newstream" "an encoded output stream" } }
+{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
+
+HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
+{ $values { "stream-in" "an input stream" }
+ { "stream-out" "an output stream" }
+ { "encoding" "an encoding descriptor" }
+ { "duplex" "an encoded duplex stream" } }
+{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ;
+
+{ <encoder> <decoder> <encoder-duplex> } related-words
+
+ARTICLE: "encodings-descriptors" "Encoding descriptors"
+"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
+$nl { $vocab-link "io.encodings.utf8" }
+$nl { $vocab-link "io.encodings.ascii" }
+$nl { $vocab-link "io.encodings.binary" }
+$nl { $vocab-link "io.encodings.utf16" } ;
+
+ARTICLE: "encodings-protocol" "Encoding protocol"
+"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
+{ $subsection decode-step }
+{ $subsection init-decoder }
+{ $subsection stream-write-encoded } ;
+
+HELP: decode-step ( buf char encoding -- )
+{ $values { "buf" "A string buffer which characters can be pushed to" }
+ { "char" "An octet which is read from a stream" }
+ { "encoding" "An encoding descriptor tuple" } }
+{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
+
+HELP: stream-write-encoded ( string stream encoding -- )
+{ $values { "string" "a string" }
+ { "stream" "an output stream" }
+ { "encoding" "an encoding descriptor" } }
+{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
+
+HELP: init-decoder ( stream encoding -- encoding )
+{ $values { "stream" "an input stream" }
+ { "encoding" "an encoding descriptor" } }
+{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
+
+{ init-decoder decode-step stream-write-encoded } related-words
--- /dev/null
+USING: io.files io.streams.string io
+tools.test kernel io.encodings.ascii ;
+IN: io.streams.encodings.tests
+
+: <resource-reader> ( resource -- stream )
+ resource-path ascii <file-reader> ;
+
+[ { } ]
+[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
+unit-test
+
+: lines-test ( stream -- line1 line2 )
+ [ readln readln ] with-stream ;
+
+[
+ "This is a line."
+ "This is another line."
+] [
+ "/core/io/test/windows-eol.txt" <resource-reader> lines-test
+] unit-test
+
+[
+ "This is a line."
+ "This is another line."
+] [
+ "/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+] unit-test
+
+[
+ "This is a line."
+ "This is another line."
+] [
+ "/core/io/test/unix-eol.txt" <resource-reader> lines-test
+] unit-test
+
+[
+ "1234"
+] [
+ "Hello world\r\n1234" <string-reader>
+ dup stream-readln drop
+ 4 swap stream-read
+] unit-test
+
+[
+ "1234"
+] [
+ "Hello world\r\n1234" <string-reader>
+ dup stream-readln drop
+ 4 swap stream-read-partial
+] unit-test
+
+[
+ CHAR: 1
+] [
+ "Hello world\r\n1234" <string-reader>
+ dup stream-readln drop
+ stream-read1
+] unit-test
-! Copyright (C) 2006, 2007 Daniel Ehrenberg.
+! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain
-namespaces unicode growable strings io classes io.streams.c
-continuations ;
+USING: math kernel sequences sbufs vectors namespaces
+growable strings io classes continuations combinators
+io.styles io.streams.plain io.encodings.binary splitting
+io.streams.duplex byte-arrays ;
IN: io.encodings
-TUPLE: encode-error ;
+! The encoding descriptor protocol
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
+GENERIC: decode-step ( buf char encoding -- )
+M: object decode-step drop swap push ;
+
+GENERIC: init-decoder ( stream encoding -- encoding )
+M: tuple-class init-decoder construct-empty init-decoder ;
+M: object init-decoder nip ;
+
+GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
+M: object stream-write-encoded drop stream-write ;
+
+! Decoding
TUPLE: decode-error ;
SYMBOL: begin
-: decoded ( buf ch -- buf ch state )
+: push-decoded ( buf ch -- buf ch state )
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
- CHAR: replacement-character decoded ;
-
-: finish-decoding ( buf ch state -- str )
- begin eq? [ decode-error ] unless drop "" like ;
-
-: start-decoding ( seq length -- buf ch state seq )
- <sbuf> 0 begin roll ;
-
-GENERIC: decode-step ( buf byte ch state encoding -- buf ch state )
-
-: decode ( seq quot -- string )
- >r dup length start-decoding r>
- [ -rot ] swap compose each
- finish-decoding ; inline
+ ! This is the replacement character
+ HEX: fffd push-decoded ;
: space ( resizable -- room-left )
dup underlying swap [ length ] 2apply - ;
: end-read-loop ( buf ch state stream quot -- string/f )
2drop 2drop >string f like ;
-: decode-read-loop ( buf ch state stream encoding -- string/f )
- >r >r pick r> r> rot full? [ end-read-loop ] [
+: decode-read-loop ( buf stream encoding -- string/f )
+ pick full? [ 2drop >string ] [
over stream-read1 [
- -rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop
- ] [ end-read-loop ] if*
+ -rot tuck >r >r >r dupd r> decode-step r> r>
+ decode-read-loop
+ ] [ 2drop >string f like ] if*
] if ;
: decode-read ( length stream encoding -- string )
- >r swap start-decoding r>
- decode-read-loop ;
+ rot <sbuf> -rot decode-read-loop ;
+
+TUPLE: decoder code cr ;
+: <decoder> ( stream encoding -- newstream )
+ dup binary eq? [ drop ] [
+ dupd init-decoder { set-delegate set-decoder-code }
+ decoder construct
+ ] if ;
+
+: cr+ t swap set-decoder-cr ; inline
+
+: cr- f swap set-decoder-cr ; inline
+
+: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
-: <decoding> ( stream decoding-class -- decoded-stream )
- construct-delegate <line-reader> ;
+: line-ends\r ( stream str -- str ) swap cr+ ; inline
-: <encoding> ( stream encoding-class -- encoded-stream )
- construct-delegate <plain-writer> ;
+: line-ends\n ( stream str -- str )
+ over decoder-cr over empty? and
+ [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
-GENERIC: encode-string ( string encoding -- byte-array )
-M: tuple-class encode-string construct-empty encode-string ;
+: handle-readln ( stream str ch -- str )
+ {
+ { f [ line-ends/eof ] }
+ { CHAR: \r [ line-ends\r ] }
+ { CHAR: \n [ line-ends\n ] }
+ } case ;
-MIXIN: encoding-stream
+: fix-read ( stream string -- string )
+ over decoder-cr [
+ over cr-
+ "\n" ?head [
+ swap stream-read1 [ add ] when*
+ ] [ nip ] if
+ ] [ nip ] if ;
-M: encoding-stream stream-read1 1 swap stream-read ;
+M: decoder stream-read
+ tuck { delegate decoder-code } get-slots decode-read fix-read ;
-M: encoding-stream stream-read
- [ delegate ] keep decode-read ;
+M: decoder stream-read-partial stream-read ;
-M: encoding-stream stream-read-partial stream-read ;
+: decoder-read-until ( stream delim -- ch )
+ ! Copied from { c-reader stream-read-until }!!!
+ over stream-read1 dup [
+ dup pick memq? [ 2nip ] [ , decoder-read-until ] if
+ ] [
+ 2nip
+ ] if ;
-M: encoding-stream stream-read-until
+M: decoder stream-read-until
! Copied from { c-reader stream-read-until }!!!
- [ swap read-until-loop ] "" make
+ [ swap decoder-read-until ] "" make
swap over empty? over not and [ 2drop f f ] when ;
-M: encoding-stream stream-write1
+: fix-read1 ( stream char -- char )
+ over decoder-cr [
+ over cr-
+ dup CHAR: \n = [
+ drop stream-read1
+ ] [ nip ] if
+ ] [ nip ] if ;
+
+M: decoder stream-read1
+ 1 swap stream-read f like [ first ] [ f ] if* ;
+
+M: decoder stream-readln ( stream -- str )
+ "\r\n" over stream-read-until handle-readln ;
+
+! Encoding
+
+TUPLE: encode-error ;
+
+: encode-error ( -- * ) \ encode-error construct-empty throw ;
+
+TUPLE: encoder code ;
+: <encoder> ( stream encoding -- newstream )
+ dup binary eq? [ drop ] [
+ construct-empty { set-delegate set-encoder-code }
+ encoder construct
+ ] if ;
+
+M: encoder stream-write1
>r 1string r> stream-write ;
-M: encoding-stream stream-write
- [ encode-string ] keep delegate stream-write ;
+M: encoder stream-write
+ { delegate encoder-code } get-slots stream-write-encoded ;
+
+M: encoder dispose delegate dispose ;
+
+INSTANCE: encoder plain-writer
-M: encoding-stream dispose delegate dispose ;
+! Rebinding duplex streams which have not read anything yet
-GENERIC: underlying-stream ( encoded-stream -- delegate )
-M: encoding-stream underlying-stream delegate ;
+: reencode ( stream encoding -- newstream )
+ over encoder? [ >r delegate r> ] when <encoder> ;
-GENERIC: set-underlying-stream ( new-underlying stream -- )
-M: encoding-stream set-underlying-stream set-delegate ;
+: redecode ( stream encoding -- newstream )
+ over decoder? [ >r delegate r> ] when <decoder> ;
-: set-encoding ( encoding stream -- ) ! This doesn't work now
- [ underlying-stream swap construct-delegate ] keep
- set-underlying-stream ;
+: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
+ tuck reencode >r redecode r> <duplex-stream> ;
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: io.encodings.latin1
-
-HELP: latin1
-{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;
+++ /dev/null
-USING: io io.encodings strings kernel ;
-IN: io.encodings.latin1
-
-TUPLE: latin1 ;
-
-M: latin1 stream-read delegate stream-read >string ;
-
-M: latin1 stream-read-until delegate stream-read-until >string ;
-
-M: latin1 stream-read-partial delegate stream-read-partial >string ;
+++ /dev/null
-ISO 8859-1 encoding/decoding
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax byte-arrays strings ;
+IN: io.encodings.string
+
+ARTICLE: "io.encodings.string" "Encoding and decoding strings"
+"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
+{ $subsection encode }
+{ $subsection decode } ;
+
+HELP: decode
+{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" }
+ { "string" string } }
+{ $description "Decodes the byte array using the given encoding, outputting a string" } ;
+
+HELP: encode
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
+{ $description "Encodes the given string into a byte array with the given encoding." } ;
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: strings io.encodings.utf8 io.encodings.utf16
+io.encodings.string tools.test ;
+IN: io.encodings.string.tests
+
+[ "hello" ] [ "hello" utf8 decode ] unit-test
+[ "he" ] [ "\0h\0e" utf16be decode ] unit-test
+
+[ "hello" ] [ "hello" utf8 encode >string ] unit-test
+[ "\0h\0e" ] [ "he" utf16be encode >string ] unit-test
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.streams.byte-array ;
+IN: io.encodings.string
+
+: decode ( byte-array encoding -- string )
+ <byte-reader> contents ;
+
+: encode ( string encoding -- byte-array )
+ [ write ] with-byte-writer ;
--- /dev/null
+Encoding and decoding strings
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding/decoding
+++ /dev/null
-USING: help.markup help.syntax io.encodings strings ;
-IN: io.encodings.utf16
-
-ARTICLE: "io.utf16" "Working with UTF16-encoded data"
-"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences."
-{ $subsection encode-utf16le }
-{ $subsection encode-utf16be }
-{ $subsection decode-utf16le }
-{ $subsection decode-utf16be }
-"Support for UTF16 data with a byte order mark:"
-{ $subsection encode-utf16 }
-{ $subsection decode-utf16 } ;
-
-ABOUT: "io.utf16"
-
-HELP: decode-utf16
-{ $values { "seq" "a sequence of bytes" } { "str" string } }
-{ $description "Decodes a sequence of bytes representing a Unicode string in UTF16 format. The bytes must begin with a UTF16 byte order mark, which determines if the input is in little or big endian. To decode data without a byte order mark, use " { $link decode-utf16le } " or " { $link decode-utf16be } "." }
-{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
-
-HELP: decode-utf16be
-{ $values { "seq" "a sequence of bytes" } { "str" string } }
-{ $description "Decodes a sequence of bytes representing a Unicode string in big endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." }
-{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
-
-HELP: decode-utf16le
-{ $values { "seq" "a sequence of bytes" } { "str" string } }
-{ $description "Decodes a sequence of bytes representing a Unicode string in little endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." }
-{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
-
-{ decode-utf16 decode-utf16le decode-utf16be } related-words
-
-HELP: encode-utf16be
-{ $values { "str" string } { "seq" "a sequence of bytes" } }
-{ $description "Encodes a Unicode string as a sequence of bytes in big endian UTF16 format." } ;
-
-HELP: encode-utf16le
-{ $values { "str" string } { "seq" "a sequence of bytes" } }
-{ $description "Encodes a Unicode string as a sequence of bytes in little endian UTF16 format." } ;
-
-HELP: encode-utf16
-{ $values { "str" string } { "seq" "a sequence of bytes" } }
-{ $description "Encodes a Unicode string as a sequence of bytes in UTF16 format with a byte order mark." } ;
-
-{ encode-utf16 encode-utf16be encode-utf16le } related-words
+++ /dev/null
-USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings
-io unicode ;
-
-: decode-w/stream ( array encoding -- newarray )
- >r >sbuf dup reverse-here r> <decoding> contents >array ;
-
-: encode-w/stream ( array encoding -- newarray )
- >r SBUF" " clone tuck r> <encoding> stream-write >array ;
-
-[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test
-
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test
-
-[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test
-
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test
-
-[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test
-[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test
-
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2007 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays ;
-IN: io.encodings.utf16
-
-SYMBOL: double
-SYMBOL: quad1
-SYMBOL: quad2
-SYMBOL: quad3
-SYMBOL: ignore
-
-: do-ignore ( -- ch state ) 0 ignore ;
-
-: append-nums ( byte ch -- ch )
- 8 shift bitor ;
-
-: end-multibyte ( buf byte ch -- buf ch state )
- append-nums decoded ;
-
-: begin-utf16be ( buf byte -- buf ch state )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad1 ]
- [ drop do-ignore ] if
- ] [ double ] if ;
-
-: handle-quad2be ( byte ch -- ch state )
- swap dup -2 shift BIN: 110111 number= [
- >r 2 shift r> BIN: 11 bitand bitor quad3
- ] [ 2drop do-ignore ] if ;
-
-: decode-utf16be-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop begin-utf16be ] }
- { double [ end-multibyte ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ handle-quad2be ] }
- { quad3 [ append-nums HEX: 10000 + decoded ] }
- { ignore [ 2drop push-replacement ] }
- } case ;
-
-: decode-utf16be ( seq -- str )
- [ decode-utf16be-step ] decode ;
-
-: handle-double ( buf byte ch -- buf ch state )
- swap dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad2 ]
- [ 2drop push-replacement ] if
- ] [ end-multibyte ] if ;
-
-: handle-quad3le ( buf byte ch -- buf ch state )
- swap dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 + decoded
- ] [ 2drop push-replacement ] if ;
-
-: decode-utf16le-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop double ] }
- { double [ handle-double ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ 10 shift bitor quad3 ] }
- { quad3 [ handle-quad3le ] }
- } case ;
-
-: decode-utf16le ( seq -- str )
- [ decode-utf16le-step ] decode ;
-
-: encode-first
- -10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
-
-: encode-second
- BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
-
-: char>utf16be ( char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- dup encode-first swap , ,
- encode-second swap , ,
- ] [ h>b/b , , ] if ;
-
-: encode-utf16be ( str -- seq )
- [ [ char>utf16be ] each ] B{ } make ;
-
-: char>utf16le ( char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- dup encode-first , ,
- encode-second , ,
- ] [ h>b/b swap , , ] if ;
-
-: encode-utf16le ( str -- seq )
- [ [ char>utf16le ] each ] B{ } make ;
-
-: bom-le B{ HEX: ff HEX: fe } ; inline
-
-: bom-be B{ HEX: fe HEX: ff } ; inline
-
-: encode-utf16 ( str -- seq )
- encode-utf16le bom-le swap append ;
-
-: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
-
-: decode-utf16 ( seq -- str )
- {
- { [ start-utf16le? ] [ decode-utf16le ] }
- { [ start-utf16be? ] [ decode-utf16be ] }
- { [ t ] [ decode-error ] }
- } cond ;
-
-TUPLE: utf16le ;
-INSTANCE: utf16le encoding-stream
-
-M: utf16le encode-string drop encode-utf16le ;
-M: utf16le decode-step drop decode-utf16le-step ;
-
-TUPLE: utf16be ;
-INSTANCE: utf16be encoding-stream
-
-M: utf16be encode-string drop encode-utf16be ;
-M: utf16be decode-step drop decode-utf16be-step ;
-
-TUPLE: utf16 encoding ;
-INSTANCE: utf16 encoding-stream
-M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary?
-M: utf16 set-underlying-stream delegate set-delegate ; ! necessary?
-
-M: utf16 encode-string
- >r encode-utf16le r>
- dup utf16-encoding [ drop ]
- [ t swap set-utf16-encoding bom-le swap append ] if ;
-
-: bom>le/be ( bom -- le/be )
- dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ decode-error ] if
- ] if ;
-
-: read-bom ( utf16 -- encoding )
- 2 over delegate stream-read bom>le/be construct-empty
- [ swap set-utf16-encoding ] keep ;
-
-M: utf16 decode-step
- ! inefficient: checks if bom is done many times
- ! This should transform itself into utf16be or utf16le after reading BOM
- dup utf16-encoding [ ] [ read-bom ] ?if decode-step ;
-USING: help.markup help.syntax io.encodings strings ;
+USING: help.markup help.syntax io.encodings strings io.files ;
IN: io.encodings.utf8
ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
-"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences."
-{ $subsection encode-utf8 }
-{ $subsection decode-utf8 } ;
+"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:"
+{ $subsection utf8 } ;
-ABOUT: "io.encodings.utf8"
-
-HELP: decode-utf8
-{ $values { "seq" "a sequence of bytes" } { "str" string } }
-{ $description "Decodes a sequence of bytes representing a Unicode string in UTF8 format." }
-{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ;
+HELP: utf8
+{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ;
-HELP: encode-utf8
-{ $values { "str" string } { "seq" "a sequence of bytes" } }
-{ $description "Encodes a Unicode string as a sequence of bytes in UTF8 format." } ;
+ABOUT: "io.encodings.utf8"
-USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings
-sequences strings arrays unicode ;
+USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ;
+IN: io.encodings.utf8.tests
: decode-utf8-w/stream ( array -- newarray )
- >sbuf dup reverse-here utf8 <decoding> contents ;
+ utf8 decode >array ;
: encode-utf8-w/stream ( array -- newarray )
- SBUF" " clone tuck utf8 <encoding> stream-write >array ;
+ utf8 encode >array ;
-[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test
-[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
+[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream ] unit-test
[ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test
-! Copyright (C) 2006, 2007 Daniel Ehrenberg.
+! Copyright (C) 2006, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors growable io continuations
-namespaces io.encodings combinators strings io.streams.c ;
+namespaces io.encodings combinators strings ;
IN: io.encodings.utf8
! Decoding UTF-8
+TUPLE: utf8 ch state ;
+
SYMBOL: double
SYMBOL: triple
SYMBOL: triple2
: begin-utf8 ( buf byte -- buf ch state )
{
- { [ dup -7 shift zero? ] [ decoded ] }
+ { [ dup -7 shift zero? ] [ push-decoded ] }
{ [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
} cond ;
: end-multibyte ( buf byte ch -- buf ch state )
- f append-nums [ decoded ] unless* ;
+ f append-nums [ push-decoded ] unless* ;
: decode-utf8-step ( buf byte ch state -- buf ch state )
{
{ quad3 [ end-multibyte ] }
} case ;
-: decode-utf8 ( seq -- str )
- [ decode-utf8-step ] decode ;
+: unpack-state ( encoding -- ch state )
+ { utf8-ch utf8-state } get-slots ;
+
+: pack-state ( ch state encoding -- )
+ { set-utf8-ch set-utf8-state } set-slots ;
+
+M: utf8 decode-step ( buf char encoding -- )
+ [ unpack-state decode-utf8-step ] keep pack-state drop ;
+
+M: utf8 init-decoder nip begin over set-utf8-state ;
! Encoding UTF-8
: encoded ( char -- )
- BIN: 111111 bitand BIN: 10000000 bitor , ;
+ BIN: 111111 bitand BIN: 10000000 bitor write1 ;
: char>utf8 ( char -- )
{
- { [ dup -7 shift zero? ] [ , ] }
+ { [ dup -7 shift zero? ] [ write1 ] }
{ [ dup -11 shift zero? ] [
- dup -6 shift BIN: 11000000 bitor ,
+ dup -6 shift BIN: 11000000 bitor write1
encoded
] }
{ [ dup -16 shift zero? ] [
- dup -12 shift BIN: 11100000 bitor ,
+ dup -12 shift BIN: 11100000 bitor write1
dup -6 shift encoded
encoded
] }
{ [ t ] [
- dup -18 shift BIN: 11110000 bitor ,
+ dup -18 shift BIN: 11110000 bitor write1
dup -12 shift encoded
dup -6 shift encoded
encoded
] }
} cond ;
-: encode-utf8 ( str -- seq )
- [ [ char>utf8 ] each ] B{ } make ;
-
-! Interface for streams
-
-TUPLE: utf8 ;
-INSTANCE: utf8 encoding-stream
-
-M: utf8 encode-string drop encode-utf8 ;
-M: utf8 decode-step drop decode-utf8-step ;
-! In the future, this should detect and ignore a BOM at the beginning
+M: utf8 stream-write-encoded
+ ! For efficiency, this should be modified to avoid variable reads
+ drop [ [ char>utf8 ] each ] with-stream* ;
Slava Pestov
+Daniel Ehrenberg
USING: help.markup help.syntax io io.styles strings
-io.backend io.files.private ;
+io.backend io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
+"File streams:"
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $subsection <file-appender> }
+"Utility combinators:"
+{ $subsection with-file-reader }
+{ $subsection with-file-writer }
+{ $subsection with-file-appender }
+{ $subsection file-contents }
+{ $subsection file-lines } ;
+
+ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
{ $subsection parent-directory }
{ $subsection file-name }
{ $subsection last-path-separator }
{ $subsection path+ }
-"File system meta-data:"
+"Pathnames relative to Factor's install directory:"
+{ $subsection resource-path }
+{ $subsection ?resource-path }
+"Pathnames relative to Factor's temporary files directory:"
+{ $subsection temp-directory }
+{ $subsection temp-file }
+"Pathname presentations:"
+{ $subsection pathname }
+{ $subsection <pathname> } ;
+
+ARTICLE: "directories" "Directories"
+"Current and home directories:"
+{ $subsection cwd }
+{ $subsection cd }
+{ $subsection with-directory }
+{ $subsection home }
+"Directory listing:"
+{ $subsection directory }
+{ $subsection directory* }
+"Creating directories:"
+{ $subsection make-directory }
+{ $subsection make-directories } ;
+
+ARTICLE: "fs-meta" "File meta-data"
+{ $subsection file-info }
+{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
{ $subsection file-length }
{ $subsection file-modified }
-{ $subsection stat }
-"Directory listing:"
-{ $subsection directory }
-"File management:"
+{ $subsection stat } ;
+
+ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
+"Operations for deleting and copying files come in two forms:"
+{ $list
+ { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
+ { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
+}
+"The operations for moving and copying files come in three flavors:"
+{ $list
+ { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
+ { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
+ { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
+}
+"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file."
+$nl
+"Deleting files:"
{ $subsection delete-file }
-{ $subsection make-directory }
{ $subsection delete-directory }
-"Current and home directories:"
-{ $subsection home }
-{ $subsection cwd }
-{ $subsection cd }
-"Pathnames relative to the Factor install directory:"
-{ $subsection resource-path }
-{ $subsection ?resource-path }
-"Pathname presentations:"
-{ $subsection pathname }
-{ $subsection <pathname> }
+{ $subsection delete-tree }
+"Moving files:"
+{ $subsection move-file }
+{ $subsection move-file-into }
+{ $subsection move-files-into }
+"Copying files:"
+{ $subsection copy-file }
+{ $subsection copy-file-into }
+{ $subsection copy-files-into }
+"Copying directory trees recursively:"
+{ $subsection copy-tree }
+{ $subsection copy-tree-into }
+{ $subsection copy-trees-into }
+"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
+
+ARTICLE: "io.files" "Basic file operations"
+"The " { $vocab-link "io.files" } " vocabulary provides basic support for working with files."
+{ $subsection "pathnames" }
+{ $subsection "file-streams" }
+{ $subsection "fs-meta" }
+{ $subsection "directories" }
+{ $subsection "delete-move-copy" }
{ $see-also "os" } ;
-ABOUT: "file-streams"
+ABOUT: "io.files"
+
+HELP: path-separator?
+{ $values { "ch" "a code point" } { "?" "a boolean" } }
+{ $description "Tests if the code point is a platform-specific path separator." }
+{ $examples
+ "On Unix:"
+ { $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" }
+} ;
+
+HELP: parent-directory
+{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
+{ $description "Strips the last component off a pathname." }
+{ $examples { $example "USING: io io.files ;" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
+
+HELP: file-name
+{ $values { "path" "a pathname string" } { "string" string } }
+{ $description "Outputs the last component of a pathname string." }
+{ $examples
+ { $example "USING: io.files prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
+ { $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
+} ;
+
+! need a $class-description file-info
+
+HELP: file-info
+ { $values { "path" "a pathname string" }
+ { "info" "a file-info tuple" } }
+ { $description "Queries the file system for meta data. "
+ "If path refers to a symbolic link, it is followed."
+ "If the file does not exist, an exception is thrown." } ;
+! need a see also to link-info
+
+HELP: link-info
+ { $values { "path" "a pathname string" }
+ { "info" "a file-info tuple" } }
+ { $description "Queries the file system for meta data. "
+ "If path refers to a symbolic link, information about "
+ "the symbolic link itself is returned."
+ "If the file does not exist, an exception is thrown." } ;
+! need a see also to file-info
HELP: <file-reader>
-{ $values { "path" "a pathname string" } { "stream" "an input stream" } }
-{ $description "Outputs an input stream for reading from the specified pathname." }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
+ { "stream" "an input stream" } }
+{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: <file-writer>
-{ $values { "path" "a pathname string" } { "stream" "an output stream" } }
-{ $description "Outputs an output stream for writing to the specified pathname. The file's length is truncated to zero." }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
+{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: <file-appender>
-{ $values { "path" "a pathname string" } { "stream" "an output stream" } }
-{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
+{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-reader
-{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-writer
-{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
-{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
+{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender
-{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
-{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
+{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
+HELP: file-lines
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } }
+{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
+HELP: file-contents
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
+{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: cwd
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
-{ cd cwd } related-words
+{ cd cwd with-directory } related-words
+
+HELP: with-directory
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Changes the current working directory for the duration of a quotation's execution." }
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
HELP: stat ( path -- directory? permissions length modified )
{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
+HELP: directory*
+{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } }
+{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
+{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
+
HELP: file-length
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
-HELP: parent-directory
-{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
-{ $description "Strips the last component off a pathname." }
-{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
-
-HELP: file-name
-{ $values { "path" "a pathname string" } { "string" string } }
-{ $description "Outputs the last component of a pathname string." }
-{ $examples
- { "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
- { "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
-} ;
-
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
{ $description "Creates a directory." }
{ $errors "Throws an error if the directory could not be created." } ;
+HELP: make-directories
+{ $values { "path" "a pathname string" } }
+{ $description "Creates a directory and any parent directories which do not yet exist." }
+{ $errors "Throws an error if the directories could not be created." } ;
+
HELP: delete-directory
{ $values { "path" "a pathname string" } }
{ $description "Deletes a directory. The directory must be empty." }
{ $errors "Throws an error if the directory could not be deleted." } ;
+
+HELP: touch-file
+{ $values { "path" "a pathname string" } }
+{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." }
+{ $errors "Throws an error if the file could not be touched." } ;
+
+HELP: delete-tree
+{ $values { "path" "a pathname string" } }
+{ $description "Deletes a file or directory, recursing into subdirectories." }
+{ $errors "Throws an error if the deletion fails." }
+{ $warning "Misuse of this word can lead to catastrophic data loss." } ;
+
+HELP: move-file
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Moves or renames a file." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
+
+HELP: move-file-into
+{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
+{ $description "Moves a file to another directory without renaming it." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
+
+HELP: move-files-into
+{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
+{ $description "Moves a set of files to another directory." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
+
+HELP: copy-file
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Copies a file." }
+{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
+{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
+
+HELP: copy-file-into
+{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
+{ $description "Copies a file to another directory." }
+{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
+
+HELP: copy-files-into
+{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
+{ $description "Copies a set of files to another directory." }
+{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
+
+HELP: copy-tree
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Copies a directory tree recursively." }
+{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
+{ $errors "Throws an error if the copy operation fails." } ;
+
+HELP: copy-tree-into
+{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
+{ $description "Copies a directory tree to another directory, recursively." }
+{ $errors "Throws an error if the copy operation fails." } ;
+
+HELP: copy-trees-into
+{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
+{ $description "Copies a set of directory trees to another directory, recursively." }
+{ $errors "Throws an error if the copy operation fails." } ;
+
+
-IN: temporary
-USING: tools.test io.files io threads kernel continuations ;
+IN: io.files.tests
+USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [
- "test-foo.txt" resource-path [
- "Hello world." print
- ] with-file-writer
+ { "Hello world." }
+ "test-foo.txt" temp-file ascii set-file-lines
] unit-test
[ ] [
- "test-foo.txt" resource-path <file-appender> [
+ "test-foo.txt" temp-file ascii [
"Hello appender." print
- ] with-stream
+ ] with-file-appender
] unit-test
[ ] [
- "test-bar.txt" resource-path <file-appender> [
+ "test-bar.txt" temp-file ascii [
"Hello appender." print
- ] with-stream
+ ] with-file-appender
] unit-test
[ "Hello world.\nHello appender.\n" ] [
- "test-foo.txt" resource-path file-contents
+ "test-foo.txt" temp-file ascii file-contents
] unit-test
[ "Hello appender.\n" ] [
- "test-bar.txt" resource-path file-contents
+ "test-bar.txt" temp-file ascii file-contents
] unit-test
-[ ] [ "test-foo.txt" resource-path delete-file ] unit-test
+[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
-[ ] [ "test-bar.txt" resource-path delete-file ] unit-test
+[ ] [ "test-bar.txt" temp-file delete-file ] unit-test
-[ f ] [ "test-foo.txt" resource-path exists? ] unit-test
+[ f ] [ "test-foo.txt" temp-file exists? ] unit-test
-[ f ] [ "test-bar.txt" resource-path exists? ] unit-test
+[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
-[ ] [ "test-blah" resource-path make-directory ] unit-test
+[ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [
- "test-blah/fooz" resource-path <file-writer> dispose
+ "test-blah/fooz" temp-file ascii <file-writer> dispose
] unit-test
[ t ] [
- "test-blah/fooz" resource-path exists?
+ "test-blah/fooz" temp-file exists?
] unit-test
-[ ] [ "test-blah/fooz" resource-path delete-file ] unit-test
+[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test
-[ ] [ "test-blah" resource-path delete-directory ] unit-test
+[ ] [ "test-blah" temp-file delete-directory ] unit-test
-[ f ] [ "test-blah" resource-path exists? ] unit-test
+[ f ] [ "test-blah" temp-file exists? ] unit-test
-[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
+[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
-[ ] [ "test-quux.txt" resource-path delete-file ] unit-test
+[ ] [ "test-quux.txt" temp-file delete-file ] unit-test
-[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
+[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
-[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
-[ t ] [ "quux-test.txt" resource-path exists? ] unit-test
+[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
+[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
-[ ] [ "quux-test.txt" resource-path delete-file ] unit-test
+[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
+[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
+
+[ ] [
+ { "Hi" }
+ "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines
+] unit-test
+
+[ ] [
+ "delete-tree-test" temp-file delete-tree
+] unit-test
+
+[ ] [
+ "copy-tree-test/a/b/c" temp-file make-directories
+] unit-test
+
+[ ] [
+ "Foobar"
+ "copy-tree-test/a/b/c/d" temp-file
+ ascii set-file-contents
+] unit-test
+
+[ ] [
+ "copy-tree-test" temp-file
+ "copy-destination" temp-file copy-tree
+] unit-test
+
+[ "Foobar" ] [
+ "copy-destination/a/b/c/d" temp-file ascii file-contents
+] unit-test
+
+[ ] [
+ "copy-destination" temp-file delete-tree
+] unit-test
+
+[ ] [
+ "copy-tree-test" temp-file
+ "copy-destination" temp-file copy-tree-into
+] unit-test
+
+[ "Foobar" ] [
+ "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents
+] unit-test
+
+[ ] [
+ "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into
+] unit-test
+
+[ "Foobar" ] [
+ "d" temp-file ascii file-contents
+] unit-test
+
+[ ] [ "d" temp-file delete-file ] unit-test
+
+[ ] [ "copy-destination" temp-file delete-tree ] unit-test
+
+[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
+
+[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.files
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
-system combinators splitting sbufs continuations ;
+system combinators splitting sbufs continuations io.encodings
+io.encodings.binary ;
+IN: io.files
-HOOK: cd io-backend ( path -- )
+HOOK: (file-reader) io-backend ( path -- stream )
-HOOK: cwd io-backend ( -- path )
+HOOK: (file-writer) io-backend ( path -- stream )
-HOOK: <file-reader> io-backend ( path -- stream )
+HOOK: (file-appender) io-backend ( path -- stream )
-HOOK: <file-writer> io-backend ( path -- stream )
+: <file-reader> ( path encoding -- stream )
+ swap (file-reader) swap <decoder> ;
-HOOK: <file-appender> io-backend ( path -- stream )
+: <file-writer> ( path encoding -- stream )
+ swap (file-writer) swap <encoder> ;
-HOOK: delete-file io-backend ( path -- )
+: <file-appender> ( path encoding -- stream )
+ swap (file-appender) swap <encoder> ;
HOOK: rename-file io-backend ( from to -- )
-HOOK: make-directory io-backend ( path -- )
-
-HOOK: delete-directory io-backend ( path -- )
-
+! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
-HOOK: root-directory? io-backend ( path -- ? )
-
-M: object root-directory? ( path -- ? ) path-separator? ;
-
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
>r right-trim-separators "/" r>
left-trim-separators 3append ;
-: stat ( path -- directory? permissions length modified )
- normalize-pathname (stat) ;
-
-: file-length ( path -- n ) stat 4array third ;
-
-: file-modified ( path -- n ) stat >r 3drop r> ; inline
-
-: exists? ( path -- ? ) file-modified >boolean ;
-
-: directory? ( path -- ? ) stat 3drop ;
-
-: special-directory? ( name -- ? )
- { "." ".." } member? ;
+: last-path-separator ( path -- n ? )
+ [ length 1- ] keep [ path-separator? ] find-last* ;
-: fixup-directory ( path seq -- newseq )
- [
- dup string?
- [ tuck path+ directory? 2array ] [ nip ] if
- ] with map
- [ first special-directory? not ] subset ;
+HOOK: root-directory? io-backend ( path -- ? )
-: directory ( path -- seq )
- normalize-directory dup (directory) fixup-directory ;
+M: object root-directory? ( path -- ? ) path-separator? ;
-: last-path-separator ( path -- n ? )
- [ length 1- ] keep [ path-separator? ] find-last* ;
+: special-directory? ( name -- ? ) { "." ".." } member? ;
TUPLE: no-parent-directory path ;
{ [ t ] [ drop ] }
} cond ;
-: resource-path ( path -- newpath )
- \ resource-path get [ image parent-directory ] unless*
- swap path+ ;
+TUPLE: file-info type size permissions modified ;
-: ?resource-path ( path -- newpath )
- "resource:" ?head [ resource-path ] when ;
+HOOK: file-info io-backend ( path -- info )
+HOOK: link-info io-backend ( path -- info )
-: resource-exists? ( path -- ? )
- ?resource-path exists? ;
+SYMBOL: +regular-file+
+SYMBOL: +directory+
+SYMBOL: +character-device+
+SYMBOL: +block-device+
+SYMBOL: +fifo+
+SYMBOL: +symbolic-link+
+SYMBOL: +socket+
+SYMBOL: +unknown+
+
+! File metadata
+: stat ( path -- directory? permissions length modified )
+ normalize-pathname (stat) ;
+
+: file-length ( path -- n ) stat drop 2nip ;
+
+: file-modified ( path -- n ) stat >r 3drop r> ;
+
+: file-permissions ( path -- perm ) stat 2drop nip ;
+
+: exists? ( path -- ? ) file-modified >boolean ;
+
+: directory? ( path -- ? ) stat 3drop ;
+
+! Current working directory
+HOOK: cd io-backend ( path -- )
+
+HOOK: cwd io-backend ( -- path )
+
+: with-directory ( path quot -- )
+ cwd [ cd ] curry rot cd [ ] cleanup ; inline
+
+! Creating directories
+HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-pathname right-trim-separators {
] }
} cond drop ;
+! Directory listings
+: fixup-directory ( path seq -- newseq )
+ [
+ dup string?
+ [ tuck path+ directory? 2array ] [ nip ] if
+ ] with map
+ [ first special-directory? not ] subset ;
+
+: directory ( path -- seq )
+ normalize-directory dup (directory) fixup-directory ;
+
+: directory* ( path -- seq )
+ dup directory [ first2 >r path+ r> 2array ] with map ;
+
+! Touching files
+HOOK: touch-file io-backend ( path -- )
+
+! Deleting files
+HOOK: delete-file io-backend ( path -- )
+
+HOOK: delete-directory io-backend ( path -- )
+
+: (delete-tree) ( path dir? -- )
+ [
+ dup directory* [ (delete-tree) ] assoc-each
+ delete-directory
+ ] [ delete-file ] if ;
+
+: delete-tree ( path -- )
+ dup directory? (delete-tree) ;
+
+: to-directory over file-name path+ ;
+
+! Moving and renaming files
+HOOK: move-file io-backend ( from to -- )
+
+: move-file-into ( from to -- )
+ to-directory move-file ;
+
+: move-files-into ( files to -- )
+ [ move-file-into ] curry each ;
+
+! Copying files
HOOK: copy-file io-backend ( from to -- )
M: object copy-file
dup parent-directory make-directories
- <file-writer> [
- swap <file-reader> [
+ binary <file-writer> [
+ swap binary <file-reader> [
swap stream-copy
] with-disposal
] with-disposal ;
-: copy-directory ( from to -- )
- dup make-directories
- >r dup directory swap r> [
- >r >r first r> over path+ r> rot path+ copy-file
- ] 2curry each ;
+: copy-file-into ( from to -- )
+ to-directory copy-file ;
-: home ( -- dir )
- {
- { [ winnt? ] [ "USERPROFILE" os-env ] }
- { [ wince? ] [ "" resource-path ] }
- { [ unix? ] [ "HOME" os-env ] }
- } cond ;
+: copy-files-into ( files to -- )
+ [ copy-file-into ] curry each ;
+
+DEFER: copy-tree-into
+
+: copy-tree ( from to -- )
+ over directory? [
+ >r dup directory swap r> [
+ >r swap first path+ r> copy-tree-into
+ ] 2curry each
+ ] [
+ copy-file
+ ] if ;
+: copy-tree-into ( from to -- )
+ to-directory copy-tree ;
+
+: copy-trees-into ( files to -- )
+ [ copy-tree-into ] curry each ;
+
+! Special paths
+: resource-path ( path -- newpath )
+ \ resource-path get [ image parent-directory ] unless*
+ swap path+ ;
+
+: ?resource-path ( path -- newpath )
+ "resource:" ?head [ resource-path ] when ;
+
+: resource-exists? ( path -- ? )
+ ?resource-path exists? ;
+
+! Pathname presentations
TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
-: file-lines ( path -- seq ) <file-reader> lines ;
-
-: file-contents ( path -- str )
- dup <file-reader> swap file-length <sbuf>
- [ stream-copy ] keep >string ;
+: file-lines ( path encoding -- seq )
+ <file-reader> lines ;
-: with-file-reader ( path quot -- )
+: with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline
-: with-file-writer ( path quot -- )
+: file-contents ( path encoding -- str )
+ dupd [ file-length read ] with-file-reader ;
+
+: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
-: with-file-appender ( path quot -- )
+: set-file-lines ( seq path encoding -- )
+ [ [ print ] each ] with-file-writer ;
+
+: set-file-contents ( str path encoding -- )
+ [ write ] with-file-writer ;
+
+: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline
+
+: temp-directory ( -- path )
+ "temp" resource-path
+ dup exists? not
+ [ dup make-directory ]
+ when ;
+
+: temp-file ( name -- path ) temp-directory swap path+ ;
+
+! Home directory
+: home ( -- dir )
+ {
+ { [ winnt? ] [ "USERPROFILE" os-env ] }
+ { [ wince? ] [ "" resource-path ] }
+ { [ unix? ] [ "HOME" os-env ] }
+ } cond ;
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
+"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code."
+$nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl
"Three words are required for input streams:"
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio" "The default stream"
-"Various words take an implicit stream parameter from a variable to reduce stack shuffling."
+"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:"
+{ $list
+ { "Code becomes simpler because there is no need to keep a stream around on the stack." }
+ { "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." }
+ { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." }
+}
+"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" <file-reader>"
+ "dup stream-readln number>string over stream-read 16 group"
+ "swap dispose"
+}
+"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" <file-reader> ["
+ " dup stream-readln number>string over stream-read"
+ " 16 group"
+ "] with-disposal"
+}
+"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" <file-reader> ["
+ " readln number>string read 16 group"
+ "] with-stream"
+}
+"The default stream is stored in a dynamically-scoped variable:"
{ $subsection stdio }
"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user."
{ $subsection read1 }
ARTICLE: "streams" "Streams"
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium."
+$nl
+"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "."
{ $subsection "stream-protocol" }
{ $subsection "stdio" }
{ $subsection "stream-utils" }
-{ $see-also "io.streams.string" "io.streams.lines" "io.streams.plain" "io.streams.duplex" } ;
+{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ;
ABOUT: "streams"
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-read1
{ $values { "stream" "an input stream" } { "ch/f" "a character or " { $link f } } }
{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-read
{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-read-until
{ $values { "seps" string } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } }
{ $contract "Reads characters from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-write1
{ $values { "ch" "a character" } { "stream" "an output stream" } }
{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link write1 } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-write
{ $values { "str" string } { "stream" "an output stream" } }
{ $contract "Writes a string of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link write } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-flush
{ $values { "stream" "an output stream" } }
{ $contract "Waits for any pending output to complete." }
{ $notes "With many output streams, written output is buffered and not sent to the underlying resource until either the buffer is full, or this word is called." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link flush } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-nl
{ $values { "stream" "an output stream" } }
{ $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-format
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-block-stream
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
$nl
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
-{ $notes "Instead of calling this word directly, use " { $link with-nesting } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-nesting } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-write-table
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
-{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link tabular-output } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-cell-stream
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
-{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-span-stream
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
-{ $notes "Instead of calling this word directly, use " { $link with-style } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link with-style } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-print
{ $values { "str" string } { "stream" "an output stream" } }
{ $description "Writes a newline-terminated string." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link print } "; see " { $link "stdio" } "." }
$io-error ;
HELP: stream-copy
HELP: readln
{ $values { "str/f" "a string or " { $link f } } }
-{ $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
+{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read1
{ $values { "ch/f" "a character or " { $link f } } }
-{ $contract "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
+{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read
{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } }
-{ $contract "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
+{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read-until
HELP: write
{ $values { "str" string } }
-{ $contract "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: flush
-{ $contract "Waits for any pending output to the " { $link stdio } " stream to complete." }
+{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." }
$io-error ;
HELP: nl
-{ $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: format
{ $values { "str" string } { "style" "a hashtable" } }
-{ $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
-{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
+{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
USING: arrays io io.files kernel math parser strings system
-tools.test words namespaces ;
-IN: temporary
+tools.test words namespaces io.encodings.latin1
+io.encodings.binary ;
+IN: io.tests
[ f ] [
"resource:/core/io/test/no-trailing-eol.factor" run-file
- "foo" "temporary" lookup
+ "foo" "io.tests" lookup
] unit-test
: <resource-reader> ( resource -- stream )
- resource-path <file-reader> ;
+ resource-path latin1 <file-reader> ;
[
"This is a line.\rThis is another line.\r"
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
-[ "" ] [
+[
"/core/io/test/binary.txt" <resource-reader>
[ 0.2 read ] with-stream
-] unit-test
+] must-fail
[
{
] unit-test
[ ] [
- image [
+ image binary [
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
--- /dev/null
+USING: help.syntax help.markup io byte-arrays quotations ;
+IN: io.streams.byte-array
+
+ABOUT: "io.streams.byte-array"
+
+ARTICLE: "io.streams.byte-array" "Byte-array streams"
+"Byte array streams:"
+{ $subsection <byte-reader> }
+{ $subsection <byte-writer> }
+"Utility combinators:"
+{ $subsection with-byte-reader }
+{ $subsection with-byte-writer } ;
+
+HELP: <byte-reader>
+{ $values { "byte-array" byte-array }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte reader" } }
+{ $description "Creates an input stream reading from a byte array using an encoding." } ;
+
+HELP: <byte-writer>
+{ $values { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte writer" } }
+{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
+
+HELP: with-byte-reader
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation } { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream for reading from a byte array using an encoding." } ;
+
+HELP: with-byte-writer
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+ { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an output stream writing data to a byte array using an encoding." } ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
- 512 <byte-vector> swap <encoding> ;
+ 512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream*
>byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
- >r >byte-vector dup reverse-here r> <decoding> ;
+ >r >byte-vector dup reverse-here r> <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
>r <byte-reader> r> with-stream ; inline
"C streams are found in the " { $vocab-link "io.streams.c" } " vocabulary; they are " { $link "stream-protocol" } " implementations which read and write C " { $snippet "FILE*" } " handles."
{ $subsection <c-reader> }
{ $subsection <c-writer> }
-{ $subsection <duplex-c-stream> }
"Underlying primitives used to implement the above:"
{ $subsection fopen }
{ $subsection fwrite }
{ $description "Creates a stream which writes data by calling C standard library functions." }
{ $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ;
-HELP: <duplex-c-stream>
-{ $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } { "stream" "a new stream" } }
-{ $description "Creates a stream which reads and writes data by calling C standard library functions, wrapping the input portion in a " { $link line-reader } " and the output portion in a " { $link plain-writer } "." } ;
-
HELP: fopen ( path mode -- alien )
{ $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } }
{ $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." }
-USING: tools.test io.files io io.streams.c ;
-IN: temporary
+USING: tools.test io.files io io.streams.c
+io.encodings.ascii strings ;
+IN: io.streams.c.tests
[ "hello world" ] [
- "test.txt" resource-path [
- "hello world" write
- ] with-file-writer
+ "hello world" "test.txt" temp-file ascii set-file-contents
- "test.txt" resource-path "rb" fopen <c-reader> contents
+ "test.txt" temp-file "rb" fopen <c-reader> contents
+ >string
] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private namespaces io
-strings sequences math generic threads.private classes
-io.backend io.streams.lines io.streams.plain io.streams.duplex
-io.files continuations ;
+USING: kernel kernel.private namespaces io io.encodings
+sequences math generic threads.private classes io.backend
+io.streams.duplex io.files continuations byte-arrays ;
IN: io.streams.c
TUPLE: c-writer handle ;
C: <c-writer> c-writer
M: c-writer stream-write1
- >r 1string r> stream-write ;
+ c-writer-handle fputc ;
M: c-writer stream-write
c-writer-handle fwrite ;
C: <c-reader> c-reader
M: c-reader stream-read
- >r >fixnum r> c-reader-handle fread ;
+ c-reader-handle fread ;
M: c-reader stream-read-partial
stream-read ;
] if ;
M: c-reader stream-read-until
- [ swap read-until-loop ] "" make swap
+ [ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;
M: c-reader dispose
c-reader-handle fclose ;
-: <duplex-c-stream> ( in out -- stream )
- >r <c-reader> <line-reader> r>
- <c-writer> <plain-writer>
- <duplex-stream> ;
-
M: object init-io ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 38 getenv ;
-M: object init-stdio
- stdin-handle stdout-handle <duplex-c-stream> stdio set-global
- stderr-handle <c-writer> <plain-writer> stderr set-global ;
+M: object (init-stdio)
+ stdin-handle <c-reader>
+ stdout-handle <c-writer>
+ stderr-handle <c-writer> ;
-M: object io-multiplex (sleep) ;
+M: object io-multiplex 60 60 * 1000 * or (sleep) ;
-M: object <file-reader>
- "rb" fopen <c-reader> <line-reader> ;
+M: object (file-reader)
+ "rb" fopen <c-reader> ;
-M: object <file-writer>
- "wb" fopen <c-writer> <plain-writer> ;
+M: object (file-writer)
+ "wb" fopen <c-writer> ;
-M: object <file-appender>
- "ab" fopen <c-writer> <plain-writer> ;
+M: object (file-appender)
+ "ab" fopen <c-writer> ;
: show ( msg -- )
#! A word which directly calls primitives. It is used to
#! print stuff from contexts where the I/O system would
#! otherwise not work (tools.deploy.shaker, the I/O
#! multiplexer thread).
- "\r\n" append stdout-handle fwrite stdout-handle fflush ;
+ "\r\n" append >byte-array
+ stdout-handle fwrite
+ stdout-handle fflush ;
USING: io.streams.duplex io kernel continuations tools.test ;
-IN: temporary
+IN: io.streams.duplex.tests
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax io strings ;
-IN: io.streams.lines
-
-ARTICLE: "io.streams.lines" "Line reader streams"
-"Line reader streams wrap an underlying stream and provide a default implementation of " { $link stream-readln } "."
-{ $subsection line-reader }
-{ $subsection <line-reader> } ;
-
-ABOUT: "io.streams.lines"
-
-HELP: line-reader
-{ $class-description "An input stream which delegates to an underlying stream while providing an implementation of the " { $link stream-readln } " word in terms of the underlying stream's " { $link stream-read-until } ". Line readers are created by calling " { $link <line-reader> } "." } ;
-
-HELP: <line-reader>
-{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
-{ $description "Creates a new " { $link line-reader } "." }
-{ $notes "Stream constructors should call this word to wrap streams that do not natively support reading lines. Unix (" { $snippet "\\n" } "), Windows (" { $snippet "\\r\\n" } ") and MacOS (" { $snippet "\\r" } ") line endings are supported." } ;
+++ /dev/null
-USING: io.streams.lines io.files io.streams.string io
-tools.test kernel ;
-IN: temporary
-
-: <resource-reader> ( resource -- stream )
- resource-path <file-reader> ;
-
-[ { } ]
-[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
-unit-test
-
-: lines-test ( stream -- line1 line2 )
- [ readln readln ] with-stream ;
-
-[
- "This is a line."
- "This is another line."
-] [
- "/core/io/test/windows-eol.txt" <resource-reader> lines-test
-] unit-test
-
-[
- "This is a line."
- "This is another line."
-] [
- "/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
-] unit-test
-
-[
- "This is a line."
- "This is another line."
-] [
- "/core/io/test/unix-eol.txt" <resource-reader> lines-test
-] unit-test
-
-[
- "1234"
-] [
- "Hello world\r\n1234" <string-reader>
- dup stream-readln drop
- 4 swap stream-read
-] unit-test
-
-[
- "1234"
-] [
- "Hello world\r\n1234" <string-reader>
- dup stream-readln drop
- 4 swap stream-read-partial
-] unit-test
-
-[
- CHAR: 1
-] [
- "Hello world\r\n1234" <string-reader>
- dup stream-readln drop
- stream-read1
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.lines
-USING: arrays generic io kernel math namespaces sequences
-vectors combinators splitting ;
-
-TUPLE: line-reader cr ;
-
-: <line-reader> ( stream -- new-stream )
- line-reader construct-delegate ;
-
-: cr+ t swap set-line-reader-cr ; inline
-
-: cr- f swap set-line-reader-cr ; inline
-
-: line-ends/eof ( stream str -- str ) f like swap cr- ; inline
-
-: line-ends\r ( stream str -- str ) swap cr+ ; inline
-
-: line-ends\n ( stream str -- str )
- over line-reader-cr over empty? and
- [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
-
-: handle-readln ( stream str ch -- str )
- {
- { f [ line-ends/eof ] }
- { CHAR: \r [ line-ends\r ] }
- { CHAR: \n [ line-ends\n ] }
- } case ;
-
-M: line-reader stream-readln ( stream -- str )
- "\r\n" over delegate stream-read-until handle-readln ;
-
-: fix-read ( stream string -- string )
- over line-reader-cr [
- over cr-
- "\n" ?head [
- swap stream-read1 [ add ] when*
- ] [ nip ] if
- ] [ nip ] if ;
-
-M: line-reader stream-read
- tuck delegate stream-read fix-read ;
-
-M: line-reader stream-read-partial
- tuck delegate stream-read-partial fix-read ;
-
-: fix-read1 ( stream char -- char )
- over line-reader-cr [
- over cr-
- dup CHAR: \n = [
- drop stream-read1
- ] [ nip ] if
- ] [ nip ] if ;
-
-M: line-reader stream-read1 ( stream -- char )
- dup delegate stream-read1 fix-read1 ;
+++ /dev/null
-Read lines of text from a character-oriented stream
USING: io io.streams.string io.streams.nested kernel math
namespaces io.styles tools.test ;
-IN: temporary
+IN: io.streams.nested.tests
{ $link make-span-stream } ", "
{ $link make-block-stream } " and "
{ $link make-cell-stream } "."
-{ $subsection plain-writer }
-{ $subsection <plain-writer> } ;
+{ $subsection plain-writer } ;
ABOUT: "io.streams.plain"
HELP: plain-writer
-{ $class-description "An output stream which delegates to an underlying stream while providing an implementation of the extended stream output protocol in a trivial way. Plain writers are created by calling " { $link <plain-writer> } "." }
-{ $see-also "stream-protocol" } ;
-
-HELP: <plain-writer>
-{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } }
-{ $description "Creates a new " { $link plain-writer } "." }
-{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." }
+{ $class-description "An output stream mixin providing an implementation of the extended stream output protocol in a trivial way." }
{ $see-also "stream-protocol" } ;
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io io.streams.nested ;
IN: io.streams.plain
-USING: generic assocs kernel math namespaces sequences
-io.styles io io.streams.nested ;
-TUPLE: plain-writer ;
-
-: <plain-writer> ( stream -- new-stream )
- plain-writer construct-delegate ;
+MIXIN: plain-writer
M: plain-writer stream-nl
CHAR: \n swap stream-write1 ;
HELP: with-string-reader
{ $values { "str" string } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ;
USING: io.streams.string io kernel arrays namespaces tools.test ;
-IN: temporary
+IN: io.streams.string.tests
[ "line 1" CHAR: l ]
[
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings
-generic splitting io.streams.plain io.streams.lines growable
-continuations ;
+generic splitting growable continuations io.streams.plain
+io.encodings ;
M: growable dispose drop ;
M: growable stream-flush drop ;
: <string-writer> ( -- stream )
- 512 <sbuf> <plain-writer> ;
+ 512 <sbuf> ;
: with-string-writer ( quot -- str )
<string-writer> swap [ stdio get ] compose with-stream*
>string ; inline
-: format-column ( seq ? -- seq )
- [
- [ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-right ] curry map
- ] unless ;
-
-: map-last ( seq quot -- seq )
- swap dup length <reversed>
- [ zero? rot [ call ] keep swap ] 2map nip ; inline
-
-: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
-
-M: plain-writer stream-write-table
- [ drop format-table [ print ] each ] with-stream* ;
-
-M: plain-writer make-cell-stream 2drop <string-writer> ;
-
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
: harden-as ( seq growble-exemplar -- newseq )
underlying like ;
: growable-read-until ( growable n -- str )
- dupd tail-slice swap harden-as dup reverse-here ;
+ >fixnum dupd tail-slice swap harden-as dup reverse-here ;
: find-last-sep swap [ memq? ] curry find-last drop ;
stream-read ;
: <string-reader> ( str -- stream )
- >sbuf dup reverse-here <line-reader> ;
+ >sbuf dup reverse-here f <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline
+
+INSTANCE: growable plain-writer
+
+: format-column ( seq ? -- seq )
+ [
+ [ 0 [ length max ] reduce ] keep
+ swap [ CHAR: \s pad-right ] curry map
+ ] unless ;
+
+: map-last ( seq quot -- seq )
+ swap dup length <reversed>
+ [ zero? rot [ call ] keep swap ] 2map nip ; inline
+
+: format-table ( table -- seq )
+ flip [ format-column ] map-last
+ flip [ " " join ] map ;
+
+M: plain-writer stream-write-table
+ [ drop format-table [ print ] each ] with-stream* ;
+
+M: plain-writer make-cell-stream 2drop <string-writer> ;
+
+M: growable stream-readln ( stream -- str )
+ "\r\n" over stream-read-until handle-readln ;
-IN: temporary
+IN: io.tests
USE: math
: foo 2 2 + ;
FORGET: foo
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
IN: io.thread\r
-USING: threads io.backend namespaces init ;\r
+USING: threads io.backend namespaces init math ;\r
\r
: io-thread ( -- )\r
sleep-time io-multiplex yield ;\r
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality and comparison testing"
-"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object, or you can test if two objects are equal in some sense, usually by being instances of the same class, and having equal slot values. Both notions of equality are equality relations in the mathematical sense."
+"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
+$nl
+"Identity comparison:"
{ $subsection eq? }
+"Value comparison:"
{ $subsection = }
+"Generic words for custom value comparison methods:"
+{ $subsection equal? }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
+"Utilities for comparing objects:"
+{ $subsection after? }
+{ $subsection before? }
+{ $subsection after=? }
+{ $subsection before=? }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
! Defined in handbook.factor
ABOUT: "dataflow"
-HELP: version
-{ $values { "str" string } }
-{ $description "Outputs the version number of the current Factor instance." } ;
-
HELP: eq? ( obj1 obj2 -- ? )
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $description "Tests if two references point at the same object." } ;
{ $contract
"Tests if two objects are equal."
$nl
- "Method definitions should ensure that this is an equality relation:"
+ "User code should call " { $link = } " instead; that word first tests the case where the objects are " { $link eq? } ", and so by extension, methods defined on " { $link equal? } " assume they are never called on " { $link eq? } " objects."
+ $nl
+ "Method definitions should ensure that this is an equality relation, modulo the assumption that the two objects are not " { $link eq? } ". That is, for any three non-" { $link eq? } " objects " { $snippet "a" } ", " { $snippet "b" } " and " { $snippet "c" } ", we must have:"
{ $list
- { $snippet "a = a" }
{ { $snippet "a = b" } " implies " { $snippet "b = a" } }
{ { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } }
}
- "While user code can define methods for this generic word, it should not call it directly, since it does not handle the case where the two references point to the same object."
}
{ $examples
- "The most common reason for defining a method for this generic word to ensure that instances of a specific tuple class are only ever equal to themselves, overriding the default implementation which checks slot values for equality."
+ "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
{ $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
- "Note that with the above definition, calling " { $link equal? } " directly will give unexpected results:"
- { $unchecked-example "T{ foo } dup equal? ." "f" }
- { $unchecked-example "T{ foo } dup clone equal? ." "f" }
- "As documented above, " { $link = } " should be called instead:"
+ "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
{ $unchecked-example "T{ foo } dup = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" }
} ;
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples
- { $example "\"hello\" \"hi\" [ length ] compare ." "3" }
+ { $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" }
} ;
HELP: clone
{ $notes "This word implements boolean and, so applying it to integers will not yield useful results (all integers have a true value). Bitwise and is the " { $link bitand } " word." }
{ $examples
"Usually only the boolean value of the result is used, however you can also explicitly rely on the behavior that if both inputs are true, the second is output:"
- { $example "t f and ." "f" }
- { $example "t 7 and ." "7" }
- { $example "\"hi\" 12.0 and ." "12.0" }
+ { $example "USING: kernel prettyprint ;" "t f and ." "f" }
+ { $example "USING: kernel prettyprint ;" "t 7 and ." "7" }
+ { $example "USING: kernel prettyprint ;" "\"hi\" 12.0 and ." "12.0" }
} ;
HELP: or
{ $notes "This word implements boolean inclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise inclusive or is the " { $link bitor } " word." }
{ $examples
"Usually only the boolean value of the result is used, however you can also explicitly rely on the behavior that the result will be the first true input:"
- { $example "t f or ." "t" }
- { $example "\"hi\" 12.0 or ." "\"hi\"" }
+ { $example "USING: kernel prettyprint ;" "t f or ." "t" }
+ { $example "USING: kernel prettyprint ;" "\"hi\" 12.0 or ." "\"hi\"" }
} ;
HELP: xor
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
- { $example "3 5 [ odd? ] both? ." "t" }
- { $example "12 7 [ even? ] both? ." "f" }
+ { $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
+ { $example "USING: kernel math prettyprint ;" "12 7 [ even? ] both? ." "f" }
} ;
HELP: either?
{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
- { $example "3 6 [ odd? ] either? ." "t" }
- { $example "5 7 [ even? ] either? ." "f" }
+ { $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
+ { $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" }
} ;
-HELP: call ( callable -- )
-{ $values { "quot" callable } }
-{ $description "Calls a quotation."
-$nl
-"Under the covers, pushes the current call frame on the call stack, and set the call frame to the given quotation." }
+HELP: call
+{ $values { "callable" callable } }
+{ $description "Calls a quotation." }
{ $examples
"The following two lines are equivalent:"
{ $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" }
$nl
"This operation is efficient and does not copy the quotation." }
{ $examples
- { $example "5 [ . ] curry ." "[ 5 . ]" }
- { $example "\\ = [ see ] curry ." "[ \\ = see ]" }
- { $example "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" }
+ { $example "USING: kernel prettyprint ;" "5 [ . ] curry ." "[ 5 . ]" }
+ { $example "USING: kernel prettyprint ;" "\\ = [ see ] curry ." "[ \\ = see ]" }
+ { $example "USING: kernel math prettyprint sequences ;" "{ 1 2 3 } 2 [ - ] curry map ." "{ -1 0 1 }" }
} ;
HELP: 2curry
{ $description "Outputs a " { $link callable } " which pushes " { $snippet "obj1" } " and " { $snippet "obj2" } " and then calls " { $snippet "quot" } "." }
{ $notes "This operation is efficient and does not copy the quotation." }
{ $examples
- { $example "5 4 [ + ] 2curry ." "[ 5 4 + ]" }
+ { $example "USING: kernel math prettyprint ;" "5 4 [ + ] 2curry ." "[ 5 4 + ]" }
} ;
HELP: 3curry
}
{ $notes "This operation is efficient and does not copy the quotation." }
{ $examples
- { $example "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
+ { $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
HELP: compose
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs ;
-IN: temporary
+IN: kernel.tests
[ 0 ] [ f size ] unit-test
[ t ] [ [ \ = \ = ] all-equal? ] unit-test
USING: kernel.private ;
IN: kernel
-: version ( -- str ) "0.92" ; foldable
-
! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline
-USING: layouts generic help.markup help.syntax kernel math
-memory namespaces sequences kernel.private classes ;
+USING: generic help.markup help.syntax kernel math
+memory namespaces sequences kernel.private classes
+sequences.private ;
+IN: layouts
HELP: tag-bits
{ $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
HELP: most-negative-fixnum
{ $values { "n" "smallest negative integer representable by a fixnum" } } ;
+
+HELP: bootstrap-first-bignum
+{ $values { "n" "smallest positive integer not representable by a fixnum" } }
+{ $description "Outputs the value for the target architecture when bootstrapping." } ;
+
+HELP: bootstrap-most-positive-fixnum
+{ $values { "n" "largest positive integer representable by a fixnum" } }
+{ $description "Outputs the value for the target architecture when bootstrapping." } ;
+
+HELP: bootstrap-most-negative-fixnum
+{ $values { "n" "smallest negative integer representable by a fixnum" } }
+{ $description "Outputs the value for the target architecture when bootstrapping." } ;
+
+HELP: cell
+{ $values { "n" "a positive integer" } }
+{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
+
+HELP: cells
+{ $values { "m" integer } { "n" integer } }
+{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
+
+HELP: cell-bits
+{ $values { "n" integer } }
+{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
+
+HELP: bootstrap-cell
+{ $values { "n" "a positive integer" } }
+{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
+
+HELP: bootstrap-cells
+{ $values { "m" integer } { "n" integer } }
+{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
+
+HELP: bootstrap-cell-bits
+{ $values { "n" integer } }
+{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
+
+ARTICLE: "layouts-types" "Type numbers"
+"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
+{ $subsection type }
+"Built-in type numbers can be converted to classes, and vice versa:"
+{ $subsection type>class }
+{ $subsection type-number }
+{ $subsection num-types }
+{ $see-also "builtin-classes" } ;
+
+ARTICLE: "layouts-tags" "Tagged pointers"
+"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
+$nl
+"Getting the tag of an object:"
+{ $link tag }
+"Words for working with tagged pointers:"
+{ $subsection tag-bits }
+{ $subsection num-tags }
+{ $subsection tag-mask }
+{ $subsection tag-number }
+"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;
+
+ARTICLE: "layouts-limits" "Sizes and limits"
+"Processor cell size:"
+{ $subsection cell }
+{ $subsection cells }
+{ $subsection cell-bits }
+"Range of integers representable by " { $link fixnum } "s:"
+{ $subsection most-negative-fixnum }
+{ $subsection most-positive-fixnum }
+"Maximum array size:"
+{ $subsection max-array-capacity } ;
+
+ARTICLE: "layouts-bootstrap" "Bootstrap support"
+"Bootstrap support:"
+{ $subsection bootstrap-cell }
+{ $subsection bootstrap-cells }
+{ $subsection bootstrap-cell-bits }
+{ $subsection bootstrap-most-negative-fixnum }
+{ $subsection bootstrap-most-positive-fixnum } ;
+
+ARTICLE: "layouts" "VM memory layouts"
+"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation."
+{ $subsection "layouts-types" }
+{ $subsection "layouts-tags" }
+{ $subsection "layouts-limits" }
+{ $subsection "layouts-bootstrap" } ;
+
+ABOUT: "layouts"
--- /dev/null
+IN: system.tests\r
+USING: layouts math tools.test ;\r
+\r
+[ t ] [ cell integer? ] unit-test\r
+[ t ] [ bootstrap-cell integer? ] unit-test\r
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math words kernel assocs system classes ;
+USING: namespaces math words kernel assocs classes
+kernel.private ;
IN: layouts
SYMBOL: tag-mask
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
+: cell ( -- n ) 7 getenv ; foldable
+
+: cells ( m -- n ) cell * ; inline
+
+: cell-bits ( -- n ) 8 cells ; inline
+
+: bootstrap-cell \ cell get cell or ; inline
+
+: bootstrap-cells bootstrap-cell * ; inline
+
+: bootstrap-cell-bits 8 bootstrap-cells ; inline
+
+: (first-bignum) ( m -- n )
+ tag-bits get - 1 - 2^ ;
+
: first-bignum ( -- n )
- bootstrap-cell-bits tag-bits get - 1 - 2^ ;
+ cell-bits (first-bignum) ;
: most-positive-fixnum ( -- n )
first-bignum 1- ;
: most-negative-fixnum ( -- n )
first-bignum neg ;
+
+: bootstrap-first-bignum ( -- n )
+ bootstrap-cell-bits (first-bignum) ;
+
+: bootstrap-most-positive-fixnum ( -- n )
+ bootstrap-first-bignum 1- ;
+
+: bootstrap-most-negative-fixnum ( -- n )
+ bootstrap-first-bignum neg ;
+
+M: bignum >integer
+ dup most-negative-fixnum most-positive-fixnum between?
+ [ >fixnum ] when ;
+
+M: real >integer
+ dup most-negative-fixnum most-positive-fixnum between?
+ [ >fixnum ] [ >bignum ] if ;
! Copyright (C) 2007 Slava Pestov
! Copyright (C) 2007 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations init inspector kernel namespaces ;
+USING: alien assocs continuations init kernel namespaces ;
IN: libc
<PRIVATE
TUPLE: check-ptr ;
-M: check-ptr summary drop "Memory allocation failed" ;
-
: check-ptr ( c-ptr -- c-ptr )
[ \ check-ptr construct-boa throw ] unless* ;
TUPLE: double-free ;
-M: double-free summary drop "Free failed since memory is not allocated" ;
-
: double-free ( -- * )
\ double-free construct-empty throw ;
TUPLE: realloc-error ptr size ;
-M: realloc-error summary drop "Memory reallocation failed" ;
-
: realloc-error ( alien size -- * )
\ realloc-error construct-boa throw ;
<PRIVATE
-[ H{ } clone mallocs set-global ] "mallocs" add-init-hook
+[ H{ } clone mallocs set-global ] "libc" add-init-hook
: add-malloc ( alien -- )
dup mallocs get-global set-at ;
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
HELP: read-quot
-{ $values { "stream" "an input stream" } { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
-{ $description "Reads a Factor expression from the stream, possibly spanning more than line. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
+{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
+{ $description "Reads a Factor expression which possibly spans more than one line from " { $link stdio } " stream. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
HELP: listen
{ $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
{ $errors "If the expression input by the user throws an error, the error is printed to the " { $link stdio } " stream and the word returns normally." } ;
-HELP: print-banner
-{ $description "Print Factor version, operating system, and CPU architecture." } ;
-
HELP: listener
{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ;
USING: io io.streams.string io.streams.duplex listener
tools.test parser math namespaces continuations vocabs kernel
compiler.units ;
-IN: temporary
+IN: listener.tests
: hello "Hi" print ; parsing
: parse-interactive ( string -- quot )
<string-reader> stream-read-quot ;
-[ [ ] ] [
- "USE: temporary hello" parse-interactive
-] unit-test
+[
+ [ [ ] ] [
+ "USE: listener.tests hello" parse-interactive
+ ] unit-test
+] with-file-vocabs
[
"debugger" use+
] unit-test
[
- "USE: vocabs.loader.test.c" parse-interactive
-] must-fail
+ [
+ "USE: vocabs.loader.test.c" parse-interactive
+ ] must-fail
+] with-file-vocabs
[ ] [
[
] with-compilation-unit
] unit-test
-[ ] [
- "IN: temporary : hello\n\"world\" ;" parse-interactive
+[
+ [ ] [
+ "IN: listener.tests : hello\n\"world\" ;" parse-interactive
drop
-] unit-test
+ ] unit-test
+] with-file-vocabs
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel math memory namespaces
-parser sequences strings io.styles io.streams.lines
+USING: arrays hashtables io kernel math math.parser memory
+namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
tuples continuations debugger definitions compiler.units ;
IN: listener
3drop f
] if ;
-M: line-reader stream-read-quot
+M: object stream-read-quot
V{ } clone read-quot-loop ;
M: duplex-stream stream-read-quot
duplex-stream-in stream-read-quot ;
-: read-quot ( -- quot ) stdio get stream-read-quot ;
+: read-quot ( -- quot/f ) stdio get stream-read-quot ;
: bye ( -- ) quit-flag on ;
[ quit-flag off ]
[ listen until-quit ] if ; inline
-: print-banner ( -- )
- "Factor " write version write
- " on " write os write "/" write cpu print ;
-
: listener ( -- )
- print-banner [ until-quit ] with-interactive-vocabs ;
+ [ until-quit ] with-interactive-vocabs ;
MAIN: listener
USING: math math.bitfields tools.test kernel words ;
-IN: temporary
+IN: math.bitfields.tests
[ 0 ] [ { } bitfield ] unit-test
[ 256 ] [ 1 { 8 } bitfield ] unit-test
USING: kernel math math.constants tools.test sequences ;
-IN: temporary
+IN: math.floats.tests
[ t ] [ 0.0 float? ] unit-test
[ t ] [ 3.1415 number? ] unit-test
{ $subsection fixnum? }
{ $subsection bignum? }
{ $subsection >fixnum }
+{ $subsection >integer }
{ $subsection >bignum }
{ $see-also "prettyprint-numbers" "modular-arithmetic" "bitwise-arithmetic" "integer-functions" "syntax-integers" } ;
USING: kernel math namespaces prettyprint
math.private continuations tools.test sequences ;
-IN: temporary
+IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test
M: fixnum >fixnum ;
M: fixnum >bignum fixnum>bignum ;
+M: fixnum >integer ;
M: fixnum number= eq? ;
{ $description "Output value from " { $link interval<= } ", " { $link interval< } ", " { $link interval>= } " and " { $link interval> } " in the case where the result of the comparison is ambiguous." } ;
HELP: interval<=
-{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } }
-{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:"
+{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } }
+{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:"
{ $list
- { { $link t } " if every point in " { $snippet "int" } " is less than or equal to " { $snippet "n" } }
- { { $link f } " if every point in " { $snippet "int" } " is greater than " { $snippet "n" } }
+ { { $link t } " if every point in " { $snippet "i1" } " is less than or equal to every point in " { $snippet "i2" } }
+ { { $link f } " if every point in " { $snippet "i1" } " is greater than every point in " { $snippet "i2" } }
{ { $link incomparable } " if neither of the above conditions hold" }
}
} ;
HELP: interval<
-{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } }
-{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:"
+{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } }
+{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:"
{ $list
- { { $link t } " if every point in " { $snippet "int" } " is less than " { $snippet "n" } }
- { { $link f } " if every point in " { $snippet "int" } " is greater than or equal to " { $snippet "n" } }
+ { { $link t } " if every point in " { $snippet "i1" } " is less than every point in " { $snippet "i2" } }
+ { { $link f } " if every point in " { $snippet "i1" } " is greater than or equal to every point in " { $snippet "i2" } }
{ { $link incomparable } " if neither of the above conditions hold" }
}
} ;
HELP: interval>=
-{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } }
-{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:"
+{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } }
+{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:"
{ $list
- { { $link t } " if every point in " { $snippet "int" } " is greater than or equal to " { $snippet "n" } }
- { { $link f } " if every point in " { $snippet "int" } " is less than " { $snippet "n" } }
+ { { $link t } " if every point in " { $snippet "i1" } " is greater than or equal to every point in " { $snippet "i2" } }
+ { { $link f } " if every point in " { $snippet "i1" } " is less than every point in " { $snippet "i2" } }
{ { $link incomparable } " if neither of the above conditions hold" }
}
} ;
HELP: interval>
-{ $values { "int" interval } { "n" real } { "?" "a boolean or " { $link incomparable } } }
-{ $description "Compares " { $snippet "int" } " with " { $snippet "n" } ", and outputs one of the following:"
+{ $values { "i1" interval } { "i2" interval } { "?" "a boolean or " { $link incomparable } } }
+{ $description "Compares " { $snippet "i1" } " with " { $snippet "i2" } ", and outputs one of the following:"
{ $list
- { { $link t } " if every point in " { $snippet "int" } " is greater than " { $snippet "n" } }
- { { $link f } " if every point in " { $snippet "int" } " is less than or equal to " { $snippet "n" } }
+ { { $link t } " if every point in " { $snippet "i1" } " is greater than every point in " { $snippet "i2" } }
+ { { $link f } " if every point in " { $snippet "i1" } " is less than or equal to every point in " { $snippet "i2" } }
{ { $link incomparable } " if neither of the above conditions hold" }
}
} ;
USING: math.intervals kernel sequences words math arrays
-prettyprint tools.test random vocabs ;
-IN: temporary
+prettyprint tools.test random vocabs combinators ;
+IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
] unit-test
] when
-[ t ] [ 0 5 [a,b] 5 interval<= ] unit-test
+[ t ] [ 1 [a,a] interval-singleton? ] unit-test
-[ incomparable ] [ 0 5 [a,b] 5 interval< ] unit-test
+[ f ] [ 1 1 [a,b) interval-singleton? ] unit-test
-[ t ] [ 0 5 [a,b) 5 interval< ] unit-test
+[ f ] [ 1 3 [a,b) interval-singleton? ] unit-test
-[ f ] [ 0 5 [a,b] -1 interval< ] unit-test
+[ f ] [ 1 1 (a,b) interval-singleton? ] unit-test
-[ incomparable ] [ 0 5 [a,b] 1 interval< ] unit-test
+[ 2 ] [ 1 3 [a,b) interval-length ] unit-test
-[ t ] [ -1 1 (a,b) -1 interval> ] unit-test
+[ 0 ] [ f interval-length ] unit-test
-[ t ] [ -1 1 (a,b) -1 interval>= ] unit-test
+[ t ] [ 0 5 [a,b] 5 [a,a] interval<= ] unit-test
-[ f ] [ -1 1 (a,b) -1 interval< ] unit-test
+[ incomparable ] [ 0 5 [a,b] 5 [a,a] interval< ] unit-test
-[ f ] [ -1 1 (a,b) -1 interval<= ] unit-test
+[ t ] [ 0 5 [a,b) 5 [a,a] interval< ] unit-test
-[ t ] [ -1 1 (a,b] 1 interval<= ] unit-test
+[ f ] [ 0 5 [a,b] -1 [a,a] interval< ] unit-test
+
+[ incomparable ] [ 0 5 [a,b] 1 [a,a] interval< ] unit-test
+
+[ t ] [ -1 1 (a,b) -1 [a,a] interval> ] unit-test
+
+[ t ] [ -1 1 (a,b) -1 [a,a] interval>= ] unit-test
+
+[ f ] [ -1 1 (a,b) -1 [a,a] interval< ] unit-test
+
+[ f ] [ -1 1 (a,b) -1 [a,a] interval<= ] unit-test
+
+[ t ] [ -1 1 (a,b] 1 [a,a] interval<= ] unit-test
+
+[ t ] [ -1 1 (a,b] 1 2 [a,b] interval<= ] unit-test
+
+[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval>= ] unit-test
+
+[ incomparable ] [ -1 1 (a,b] 1 2 [a,b] interval> ] unit-test
+
+[ t ] [ -1 1 (a,b] 1 2 (a,b] interval<= ] unit-test
+
+[ f ] [ 0 10 [a,b] 0 [a,a] interval< ] unit-test
+
+[ f ] [ 0 10 [a,b] 10 [a,a] interval> ] unit-test
+
+[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval< ] unit-test
+
+[ incomparable ] [ 10 [a,a] 0 10 [a,b] interval> ] unit-test
+
+[ t ] [ 0 [a,a] 0 10 [a,b] interval<= ] unit-test
+
+[ incomparable ] [ 0 [a,a] 0 10 [a,b] interval>= ] unit-test
+
+[ t ] [ 0 10 [a,b] 0 [a,a] interval>= ] unit-test
+
+[ t ] [
+ 418
+ 418 423 [a,b)
+ 79 893 (a,b]
+ interval-max
+ interval-contains?
+] unit-test
+
+[ f ] [ 1 100 [a,b] -1 1 [a,b] interval/i ] unit-test
! Interval random tester
: random-element ( interval -- n )
- dup interval-to first swap interval-from first tuck -
- random + ;
+ dup interval-to first over interval-from first tuck - random +
+ 2dup swap interval-contains? [
+ nip
+ ] [
+ drop random-element
+ ] if ;
: random-interval ( -- interval )
- 1000 random dup 1 1000 random + + [a,b] ;
+ 1000 random dup 2 1000 random + +
+ 1 random zero? [ [ neg ] 2apply swap ] when
+ 4 random {
+ { 0 [ [a,b] ] }
+ { 1 [ [a,b) ] }
+ { 2 [ (a,b) ] }
+ { 3 [ (a,b] ] }
+ } case ;
: random-op
{
random ;
: interval-test
- random-interval random-interval random-op
+ random-interval random-interval random-op ! 3dup . . .
0 pick interval-contains? over first { / /i } member? and [
3drop t
] [
- [ >r [ random-element ] 2apply r> first execute ] 3keep
+ [ >r [ random-element ] 2apply ! 2dup . .
+ r> first execute ] 3keep
second execute interval-contains?
] if ;
-[ t ] [ 1000 [ drop interval-test ] all? ] unit-test
+[ t ] [ 40000 [ drop interval-test ] all? ] unit-test
+
+: random-comparison
+ {
+ { < interval< }
+ { <= interval<= }
+ { > interval> }
+ { >= interval>= }
+ } random ;
+
+: comparison-test
+ random-interval random-interval random-comparison
+ [ >r [ random-element ] 2apply r> first execute ] 3keep
+ second execute dup incomparable eq? [
+ 2drop t
+ ] [
+ =
+ ] if ;
+
+[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop f ] if ; inline
-: interval-shift ( i1 i2 -- i3 )
- [ [ shift ] interval-op ] interval-integer-op ;
-
-: interval-shift-safe ( i1 i2 -- i3 )
- dup interval-to first 100 > [
- 2drop f
- ] [
- interval-shift
- ] if ;
-
-: interval-max ( i1 i2 -- i3 ) [ max ] interval-op ;
-
-: interval-min ( i1 i2 -- i3 ) [ min ] interval-op ;
-
: interval-1+ ( i1 -- i2 ) 1 [a,a] interval+ ;
: interval-1- ( i1 -- i2 ) -1 [a,a] interval+ ;
: interval-contains? ( x int -- ? )
>r [a,a] r> interval-subset? ;
+: interval-singleton? ( int -- ? )
+ interval>points
+ 2dup [ second ] 2apply and
+ [ [ first ] 2apply = ]
+ [ 2drop f ] if ;
+
+: interval-length ( int -- n )
+ dup
+ [ interval>points [ first ] 2apply swap - ]
+ [ drop 0 ] if ;
+
: interval-closure ( i1 -- i2 )
- interval>points [ first ] 2apply [a,b] ;
+ dup [ interval>points [ first ] 2apply [a,b] ] when ;
+
+: interval-shift ( i1 i2 -- i3 )
+ #! Inaccurate; could be tighter
+ [ [ shift ] interval-op ] interval-integer-op interval-closure ;
+
+: interval-shift-safe ( i1 i2 -- i3 )
+ dup interval-to first 100 > [
+ 2drop f
+ ] [
+ interval-shift
+ ] if ;
+
+: interval-max ( i1 i2 -- i3 )
+ #! Inaccurate; could be tighter
+ [ max ] interval-op interval-closure ;
+
+: interval-min ( i1 i2 -- i3 )
+ #! Inaccurate; could be tighter
+ [ min ] interval-op interval-closure ;
+
+: interval-interior ( i1 -- i2 )
+ interval>points [ first ] 2apply (a,b) ;
: interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains?
: interval/i ( i1 i2 -- i3 )
[
[ [ /i ] interval-op ] interval-integer-op
- ] interval-division-op ;
+ ] interval-division-op interval-closure ;
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
SYMBOL: incomparable
-: interval-compare ( int n quot -- ? )
- >r dupd r> call interval-intersect dup [
- = t incomparable ?
- ] [
- 2drop f
- ] if ; inline
-
-: interval< ( int n -- ? )
- [ [-inf,a) ] interval-compare ; inline
-
-: interval<= ( int n -- ? )
- [ [-inf,a] ] interval-compare ; inline
-
-: interval> ( int n -- ? )
- [ (a,inf] ] interval-compare ; inline
-
-: interval>= ( int n -- ? )
- [ [a,inf] ] interval-compare ; inline
+: left-endpoint-< ( i1 i2 -- ? )
+ [ swap interval-subset? ] 2keep
+ [ nip interval-singleton? ] 2keep
+ [ interval-from ] 2apply =
+ and and ;
+
+: right-endpoint-< ( i1 i2 -- ? )
+ [ interval-subset? ] 2keep
+ [ drop interval-singleton? ] 2keep
+ [ interval-to ] 2apply =
+ and and ;
+
+: (interval<) over interval-from over interval-from endpoint< ;
+
+: interval< ( i1 i2 -- ? )
+ {
+ { [ 2dup interval-intersect not ] [ (interval<) ] }
+ { [ 2dup left-endpoint-< ] [ f ] }
+ { [ 2dup right-endpoint-< ] [ f ] }
+ { [ t ] [ incomparable ] }
+ } cond 2nip ;
+
+: left-endpoint-<= ( i1 i2 -- ? )
+ >r interval-from r> interval-to = ;
+
+: right-endpoint-<= ( i1 i2 -- ? )
+ >r interval-to r> interval-from = ;
+
+: interval<= ( i1 i2 -- ? )
+ {
+ { [ 2dup interval-intersect not ] [ (interval<) ] }
+ { [ 2dup right-endpoint-<= ] [ t ] }
+ { [ t ] [ incomparable ] }
+ } cond 2nip ;
+
+: interval> ( i1 i2 -- ? )
+ swap interval< ;
+
+: interval>= ( i1 i2 -- ? )
+ swap interval<= ;
: assume< ( i1 i2 -- i3 )
interval-to first [-inf,a) interval-intersect ;
{ $values { "x" integer } { "y" integer } { "z" integer } }
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in both inputs." }
{ $examples
- { $example "BIN: 101 BIN: 10 bitand .b" "0" }
- { $example "BIN: 110 BIN: 10 bitand .b" "10" }
+ { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitand .b" "0" }
+ { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitand .b" "10" }
}
{ $notes "This word implements bitwise and, so applying it to booleans will throw an error. Boolean and is the " { $link and } " word." } ;
{ $values { "x" integer } { "y" integer } { "z" integer } }
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in at least one of the inputs." }
{ $examples
- { $example "BIN: 101 BIN: 10 bitor .b" "111" }
- { $example "BIN: 110 BIN: 10 bitor .b" "110" }
+ { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitor .b" "111" }
+ { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitor .b" "110" }
}
{ $notes "This word implements bitwise inclusive or, so applying it to booleans will throw an error. Boolean inclusive or is the " { $link and } " word." } ;
{ $values { "x" integer } { "y" integer } { "z" integer } }
{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in exactly one of the inputs." }
{ $examples
- { $example "BIN: 101 BIN: 10 bitxor .b" "111" }
- { $example "BIN: 110 BIN: 10 bitxor .b" "100" }
+ { $example "USING: math prettyprint ;" "BIN: 101 BIN: 10 bitxor .b" "111" }
+ { $example "USING: math prettyprint ;" "BIN: 110 BIN: 10 bitxor .b" "100" }
}
{ $notes "This word implements bitwise exclusive or, so applying it to booleans will throw an error. Boolean exclusive or is the " { $link xor } " word." } ;
HELP: shift
{ $values { "x" integer } { "n" integer } { "y" integer } }
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
-{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ;
+{ $examples { $example "USING: math prettyprint ;" "BIN: 101 5 shift .b" "10100000" } { $example "USING: math prettyprint ;" "BIN: 11111 -2 shift .b" "111" } } ;
HELP: bitnot
{ $values { "x" integer } { "y" integer } }
HELP: bit?
{ $values { "x" integer } { "n" integer } { "?" "a boolean" } }
{ $description "Tests if the " { $snippet "n" } "th bit of " { $snippet "x" } " is set." }
-{ $examples { $example "BIN: 101 2 bit? ." "t" } } ;
+{ $examples { $example "USING: math prettyprint ;" "BIN: 101 2 bit? ." "t" } } ;
HELP: log2
{ $values { "x" "a positive integer" } { "n" integer } }
{ $values { "x" integer } { "y" integer } }
{ $description "Shifts " { $snippet "x" } " to the right by one bit." }
{ $examples
- { $example "14 2/ ." "7" }
- { $example "17 2/ ." "8" }
- { $example "-17 2/ ." "-9" }
+ { $example "USING: math prettyprint ;" "14 2/ ." "7" }
+ { $example "USING: math prettyprint ;" "17 2/ ." "8" }
+ { $example "USING: math prettyprint ;" "-17 2/ ." "-9" }
}
{ $notes "This word is not equivalent to " { $snippet "2 /" } " or " { $snippet "2 /i" } "; the name is historic and originates from the Forth programming language." } ;
USING: kernel math namespaces tools.test ;
-IN: temporary
+IN: math.tests
[ ] [ 5 [ ] times ] unit-test
[ ] [ 0 [ ] times ] unit-test
GENERIC: >fixnum ( x -- y ) foldable
GENERIC: >bignum ( x -- y ) foldable
+GENERIC: >integer ( x -- y ) foldable
GENERIC: >float ( x -- y ) foldable
MATH: number= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
+: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
+: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
+: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
+: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
+
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
USING: kernel math math.parser sequences tools.test ;
-IN: temporary
+IN: math.parser.tests
[ f ]
[ f string>number ]
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
-HELP: data-room ( -- cards semi generations )
-{ $values { "cards" "number of bytes reserved for card marking" } { "semi" "number of bytes reserved for tenured semi-space" } { "generations" "array of free/total bytes pairs" } }
+HELP: data-room ( -- cards generations )
+{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ;
HELP: code-room ( -- code-free code-total )
USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes ;
-IN: temporary
+IN: memory.tests
TUPLE: testing x y z ;
HELP: mirror
{ $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools."
$nl
-"Mirrors are mutable, however new keys cannot be inserted and keys cannot be deleted, only values of existing keys can be changed."
+"Mirrors are mutable, however new keys cannot be inserted, only values of existing keys can be changed. Deleting a key has the effect of setting its value to " { $link f } "."
$nl
"Mirrors are created by calling " { $link <mirror> } " or " { $link make-mirror } "." } ;
{ $description "Creates a " { $link mirror } " reflecting an object." }
{ $examples
{ $example
- "USING: assocs mirrors ;"
+ "USING: assocs mirrors prettyprint ;"
"TUPLE: circle center radius ;"
"C: <circle> circle"
"{ 100 50 } 15 <circle> <mirror> >alist ."
- "{ { circle-center { 100 50 } } { circle-radius 15 } }"
+ "{ { \"center\" { 100 50 } } { \"radius\" 15 } }"
}
} ;
"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
HELP: make-mirror
-{ $values { "obj" object } { "assoc" "an assoc" } }
+{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
USING: mirrors tools.test assocs kernel arrays ;
-IN: temporary
+IN: mirrors.tests
TUPLE: foo bar baz ;
C: <foo> foo
-[ { foo-bar foo-baz } ] [ 1 2 <foo> <mirror> keys ] unit-test
+[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
-[ 1 t ] [ \ foo-bar 1 2 <foo> <mirror> at* ] unit-test
+[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
[ f f ] [ "hi" 1 2 <foo> <mirror> at* ] unit-test
[ 3 ] [
- 3 \ foo-baz 1 2 <foo> [ <mirror> set-at ] keep foo-baz
+ 3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private tuples math vectors
-quotations ;
+quotations sorting prettyprint ;
IN: mirrors
GENERIC: object-slots ( obj -- seq )
: >mirror< ( mirror -- obj slots )
dup mirror-object swap mirror-slots ;
+: mirror@ ( slot-name mirror -- obj slot-spec )
+ >mirror< swapd slot-named ;
+
M: mirror at*
- >mirror< swapd slot-of-reader
- dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
+ mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
M: mirror set-at ( val key mirror -- )
- >mirror< swapd slot-of-reader dup [
+ mirror@ dup [
dup slot-spec-writer [
slot-spec-offset set-slot
] [
M: mirror >alist ( mirror -- alist )
>mirror<
[ [ slot-spec-offset slot ] with map ] keep
- [ slot-spec-reader ] map swap 2array flip ;
+ [ slot-spec-name ] map swap 2array flip ;
M: mirror assoc-size mirror-slots length ;
INSTANCE: enum assoc
+: sort-assoc ( assoc -- alist )
+ >alist
+ [ dup first unparse-short swap ] { } map>assoc
+ sort-keys values ;
+
GENERIC: make-mirror ( obj -- assoc )
-M: hashtable make-mirror ;
+M: hashtable make-mirror sort-assoc ;
M: integer make-mirror drop f ;
M: array make-mirror <enum> ;
M: vector make-mirror <enum> ;
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
{ $side-effects "variable" }
{ $examples
- { $example "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
+ { $example "USING: namespaces prettyprint ;" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
} ;
HELP: inc
HELP: make
{ $values { "quot" quotation } { "exemplar" "a sequence" } { "seq" "a new sequence" } }
{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
-{ $examples { $example "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ;
+{ $examples { $example "USING: namespaces prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ;
HELP: ,
{ $values { "elt" object } }
-IN: temporary
+IN: namespaces.tests
USING: kernel namespaces tools.test words ;
H{ } clone "test-namespace" set
-IN: temporary
+IN: optimizer.control.tests
USING: tools.test optimizer.control combinators kernel
sequences inference.dataflow math inference classes strings
optimizer ;
-IN: temporary
+IN: optimizer.def-use.tests
USING: inference inference.dataflow optimizer optimizer.def-use
namespaces assocs kernel sequences math tools.test words ;
-! Copyright (C) 2004, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays generic assocs inference inference.class\r
-inference.dataflow inference.backend inference.state io kernel\r
-math namespaces sequences vectors words quotations hashtables\r
-combinators classes generic.math continuations optimizer.def-use\r
-optimizer.backend generic.standard optimizer.specializers\r
-optimizer.def-use optimizer.pattern-match generic.standard\r
-optimizer.control kernel.private ;\r
-IN: optimizer.inlining\r
-\r
-: remember-inlining ( node history -- )\r
- [ swap set-node-history ] curry each-node ;\r
-\r
-: inlining-quot ( node quot -- node )\r
- over node-in-d dataflow-with\r
- dup rot infer-classes/node ;\r
-\r
-: splice-quot ( #call quot history -- node )\r
- #! Must add history *before* splicing in, otherwise\r
- #! the rest of the IR will also remember the history\r
- pick node-history append\r
- >r dupd inlining-quot dup r> remember-inlining\r
- tuck splice-node ;\r
-\r
-! A heuristic to avoid excessive inlining\r
-DEFER: (flat-length)\r
-\r
-: word-flat-length ( word -- n )\r
- {\r
- ! heuristic: { ... } declare comes up in method bodies\r
- ! and we don't care about it\r
- { [ dup \ declare eq? ] [ drop -2 ] }\r
- ! recursive\r
- { [ dup get ] [ drop 1 ] }\r
- ! not inline\r
- { [ dup inline? not ] [ drop 1 ] }\r
- ! inline\r
- { [ t ] [ dup dup set word-def (flat-length) ] }\r
- } cond ;\r
-\r
-: (flat-length) ( seq -- n )\r
- [\r
- {\r
- { [ dup quotation? ] [ (flat-length) 1+ ] }\r
- { [ dup array? ] [ (flat-length) ] }\r
- { [ dup word? ] [ word-flat-length ] }\r
- { [ t ] [ drop 1 ] }\r
- } cond\r
- ] map sum ;\r
-\r
-: flat-length ( seq -- n )\r
- [ word-def (flat-length) ] with-scope ;\r
-\r
-! Single dispatch method inlining optimization\r
-: specific-method ( class word -- class ) order min-class ;\r
-\r
-: node-class# ( node n -- class )\r
- over node-in-d <reversed> ?nth node-class ;\r
-\r
-: dispatching-class ( node word -- class )\r
- [ dispatch# node-class# ] keep specific-method ;\r
-\r
-: inline-standard-method ( node word -- node )\r
- 2dup dispatching-class dup [\r
- over +inlined+ depends-on\r
- swap method method-word 1quotation f splice-quot\r
- ] [\r
- 3drop t\r
- ] if ;\r
-\r
-! Partial dispatch of math-generic words\r
-: math-both-known? ( word left right -- ? )\r
- math-class-max swap specific-method ;\r
-\r
-: inline-math-method ( #call word -- node )\r
- over node-input-classes first2 3dup math-both-known?\r
- [ math-method f splice-quot ] [ 2drop 2drop t ] if ;\r
-\r
-: inline-method ( #call -- node )\r
- dup node-param {\r
- { [ dup standard-generic? ] [ inline-standard-method ] }\r
- { [ dup math-generic? ] [ inline-math-method ] }\r
- { [ t ] [ 2drop t ] }\r
- } cond ;\r
-\r
-! Resolve type checks at compile time where possible\r
-: comparable? ( actual testing -- ? )\r
- #! If actual is a subset of testing or if the two classes\r
- #! are disjoint, return t.\r
- 2dup class< >r classes-intersect? not r> or ;\r
-\r
-: optimize-predicate? ( #call -- ? )\r
- dup node-param "predicating" word-prop dup [\r
- >r node-class-first r> comparable?\r
- ] [\r
- 2drop f\r
- ] if ;\r
-\r
-: literal-quot ( node literals -- quot )\r
- #! Outputs a quotation which drops the node's inputs, and\r
- #! pushes some literals.\r
- >r node-in-d length \ drop <repetition>\r
- r> [ literalize ] map append >quotation ;\r
-\r
-: inline-literals ( node literals -- node )\r
- #! Make #shuffle -> #push -> #return -> successor\r
- dupd literal-quot f splice-quot ;\r
-\r
-: evaluate-predicate ( #call -- ? )\r
- dup node-param "predicating" word-prop >r\r
- node-class-first r> class< ;\r
-\r
-: optimize-predicate ( #call -- node )\r
- #! If the predicate is followed by a branch we fold it\r
- #! immediately\r
- dup evaluate-predicate swap\r
- dup node-successor #if? [\r
- dup drop-inputs >r\r
- node-successor swap 0 1 ? fold-branch\r
- r> [ set-node-successor ] keep\r
- ] [\r
- swap 1array inline-literals\r
- ] if ;\r
-\r
-: optimizer-hooks ( node -- conditions )\r
- node-param "optimizer-hooks" word-prop ;\r
-\r
-: optimizer-hook ( node -- pair/f )\r
- dup optimizer-hooks [ first call ] find 2nip ;\r
-\r
-: optimize-hook ( node -- )\r
- dup optimizer-hook second call ;\r
-\r
-: define-optimizers ( word optimizers -- )\r
- "optimizer-hooks" set-word-prop ;\r
-\r
-: flush-eval? ( #call -- ? )\r
- dup node-param "flushable" word-prop [\r
- node-out-d [ unused? ] all?\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-: flush-eval ( #call -- node )\r
- dup node-param +inlined+ depends-on\r
- dup node-out-d length f <repetition> inline-literals ;\r
-\r
-: partial-eval? ( #call -- ? )\r
- dup node-param "foldable" word-prop [\r
- dup node-in-d [ node-literal? ] with all?\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-: literal-in-d ( #call -- inputs )\r
- dup node-in-d [ node-literal ] with map ;\r
-\r
-: partial-eval ( #call -- node )\r
- dup node-param +inlined+ depends-on\r
- dup literal-in-d over node-param 1quotation\r
- [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;\r
-\r
-: define-identities ( words identities -- )\r
- [ "identities" set-word-prop ] curry each ;\r
-\r
-: find-identity ( node -- quot )\r
- [ node-param "identities" word-prop ] keep\r
- [ swap first in-d-match? ] curry find\r
- nip dup [ second ] when ;\r
-\r
-: apply-identities ( node -- node/f )\r
- dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;\r
-\r
-: optimistic-inline? ( #call -- ? )\r
- dup node-param "specializer" word-prop dup [\r
- >r node-input-classes r> specialized-length tail*\r
- [ types length 1 = ] all?\r
- ] [\r
- 2drop f\r
- ] if ;\r
-\r
-: splice-word-def ( #call word -- node )\r
- dup +inlined+ depends-on\r
- dup word-def swap 1array splice-quot ;\r
-\r
-: optimistic-inline ( #call -- node )\r
- dup node-param over node-history memq? [\r
- drop t\r
- ] [\r
- dup node-param splice-word-def\r
- ] if ;\r
-\r
-: method-body-inline? ( #call -- ? )\r
- node-param dup method-body?\r
- [ flat-length 10 <= ] [ drop f ] if ;\r
-\r
-M: #call optimize-node*\r
- {\r
- { [ dup flush-eval? ] [ flush-eval ] }\r
- { [ dup partial-eval? ] [ partial-eval ] }\r
- { [ dup find-identity ] [ apply-identities ] }\r
- { [ dup optimizer-hook ] [ optimize-hook ] }\r
- { [ dup optimize-predicate? ] [ optimize-predicate ] }\r
- { [ dup optimistic-inline? ] [ optimistic-inline ] }\r
- { [ dup method-body-inline? ] [ optimistic-inline ] }\r
- { [ t ] [ inline-method ] }\r
- } cond dup not ;\r
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic assocs inference inference.class
+inference.dataflow inference.backend inference.state io kernel
+math namespaces sequences vectors words quotations hashtables
+combinators classes generic.math continuations optimizer.def-use
+optimizer.backend generic.standard optimizer.specializers
+optimizer.def-use optimizer.pattern-match generic.standard
+optimizer.control kernel.private ;
+IN: optimizer.inlining
+
+: remember-inlining ( node history -- )
+ [ swap set-node-history ] curry each-node ;
+
+: inlining-quot ( node quot -- node )
+ over node-in-d dataflow-with
+ dup rot infer-classes/node ;
+
+: splice-quot ( #call quot history -- node )
+ #! Must add history *before* splicing in, otherwise
+ #! the rest of the IR will also remember the history
+ pick node-history append
+ >r dupd inlining-quot dup r> remember-inlining
+ tuck splice-node ;
+
+! A heuristic to avoid excessive inlining
+DEFER: (flat-length)
+
+: word-flat-length ( word -- n )
+ {
+ ! heuristic: { ... } declare comes up in method bodies
+ ! and we don't care about it
+ { [ dup \ declare eq? ] [ drop -2 ] }
+ ! recursive
+ { [ dup get ] [ drop 1 ] }
+ ! not inline
+ { [ dup inline? not ] [ drop 1 ] }
+ ! inline
+ { [ t ] [ dup dup set word-def (flat-length) ] }
+ } cond ;
+
+: (flat-length) ( seq -- n )
+ [
+ {
+ { [ dup quotation? ] [ (flat-length) 1+ ] }
+ { [ dup array? ] [ (flat-length) ] }
+ { [ dup word? ] [ word-flat-length ] }
+ { [ t ] [ drop 1 ] }
+ } cond
+ ] map sum ;
+
+: flat-length ( seq -- n )
+ [ word-def (flat-length) ] with-scope ;
+
+! Single dispatch method inlining optimization
+: specific-method ( class word -- class ) order min-class ;
+
+: node-class# ( node n -- class )
+ over node-in-d <reversed> ?nth node-class ;
+
+: dispatching-class ( node word -- class )
+ [ dispatch# node-class# ] keep specific-method ;
+
+: inline-standard-method ( node word -- node )
+ 2dup dispatching-class dup [
+ over +inlined+ depends-on
+ swap method 1quotation f splice-quot
+ ] [
+ 3drop t
+ ] if ;
+
+! Partial dispatch of math-generic words
+: math-both-known? ( word left right -- ? )
+ math-class-max swap specific-method ;
+
+: inline-math-method ( #call word -- node )
+ over node-input-classes first2 3dup math-both-known?
+ [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+
+: inline-method ( #call -- node )
+ dup node-param {
+ { [ dup standard-generic? ] [ inline-standard-method ] }
+ { [ dup math-generic? ] [ inline-math-method ] }
+ { [ t ] [ 2drop t ] }
+ } cond ;
+
+! Resolve type checks at compile time where possible
+: comparable? ( actual testing -- ? )
+ #! If actual is a subset of testing or if the two classes
+ #! are disjoint, return t.
+ 2dup class< >r classes-intersect? not r> or ;
+
+: optimize-predicate? ( #call -- ? )
+ dup node-param "predicating" word-prop dup [
+ >r node-class-first r> comparable?
+ ] [
+ 2drop f
+ ] if ;
+
+: literal-quot ( node literals -- quot )
+ #! Outputs a quotation which drops the node's inputs, and
+ #! pushes some literals.
+ >r node-in-d length \ drop <repetition>
+ r> [ literalize ] map append >quotation ;
+
+: inline-literals ( node literals -- node )
+ #! Make #shuffle -> #push -> #return -> successor
+ dupd literal-quot f splice-quot ;
+
+: evaluate-predicate ( #call -- ? )
+ dup node-param "predicating" word-prop >r
+ node-class-first r> class< ;
+
+: optimize-predicate ( #call -- node )
+ #! If the predicate is followed by a branch we fold it
+ #! immediately
+ dup evaluate-predicate swap
+ dup node-successor #if? [
+ dup drop-inputs >r
+ node-successor swap 0 1 ? fold-branch
+ r> [ set-node-successor ] keep
+ ] [
+ swap 1array inline-literals
+ ] if ;
+
+: optimizer-hooks ( node -- conditions )
+ node-param "optimizer-hooks" word-prop ;
+
+: optimizer-hook ( node -- pair/f )
+ dup optimizer-hooks [ first call ] find 2nip ;
+
+: optimize-hook ( node -- )
+ dup optimizer-hook second call ;
+
+: define-optimizers ( word optimizers -- )
+ "optimizer-hooks" set-word-prop ;
+
+: flush-eval? ( #call -- ? )
+ dup node-param "flushable" word-prop [
+ node-out-d [ unused? ] all?
+ ] [
+ drop f
+ ] if ;
+
+: flush-eval ( #call -- node )
+ dup node-param +inlined+ depends-on
+ dup node-out-d length f <repetition> inline-literals ;
+
+: partial-eval? ( #call -- ? )
+ dup node-param "foldable" word-prop [
+ dup node-in-d [ node-literal? ] with all?
+ ] [
+ drop f
+ ] if ;
+
+: literal-in-d ( #call -- inputs )
+ dup node-in-d [ node-literal ] with map ;
+
+: partial-eval ( #call -- node )
+ dup node-param +inlined+ depends-on
+ dup literal-in-d over node-param 1quotation
+ [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
+
+: define-identities ( words identities -- )
+ [ "identities" set-word-prop ] curry each ;
+
+: find-identity ( node -- quot )
+ [ node-param "identities" word-prop ] keep
+ [ swap first in-d-match? ] curry find
+ nip dup [ second ] when ;
+
+: apply-identities ( node -- node/f )
+ dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
+
+: optimistic-inline? ( #call -- ? )
+ dup node-param "specializer" word-prop dup [
+ >r node-input-classes r> specialized-length tail*
+ [ types length 1 = ] all?
+ ] [
+ 2drop f
+ ] if ;
+
+: splice-word-def ( #call word -- node )
+ dup +inlined+ depends-on
+ dup word-def swap 1array splice-quot ;
+
+: optimistic-inline ( #call -- node )
+ dup node-param over node-history memq? [
+ drop t
+ ] [
+ dup node-param splice-word-def
+ ] if ;
+
+: method-body-inline? ( #call -- ? )
+ node-param dup method-body?
+ [ flat-length 10 <= ] [ drop f ] if ;
+
+M: #call optimize-node*
+ {
+ { [ dup flush-eval? ] [ flush-eval ] }
+ { [ dup partial-eval? ] [ partial-eval ] }
+ { [ dup find-identity ] [ apply-identities ] }
+ { [ dup optimizer-hook ] [ optimize-hook ] }
+ { [ dup optimize-predicate? ] [ optimize-predicate ] }
+ { [ dup optimistic-inline? ] [ optimistic-inline ] }
+ { [ dup method-body-inline? ] [ optimistic-inline ] }
+ { [ t ] [ inline-method ] }
+ } cond dup not ;
] assoc-each
! Remove redundant comparisons
-: known-comparison? ( #call -- ? )
+: intervals-first2 ( #call -- first second )
dup dup node-in-d first node-interval
- swap dup node-in-d second node-literal real? and ;
+ swap dup node-in-d second node-interval ;
+
+: known-comparison? ( #call -- ? )
+ intervals-first2 and ;
: perform-comparison ( #call word -- result )
- >r dup dup node-in-d first node-interval
- swap dup node-in-d second node-literal r> execute ; inline
+ >r intervals-first2 r> execute ; inline
-: foldable-comparison? ( #call word -- )
+: foldable-comparison? ( #call word -- ? )
>r dup known-comparison? [
r> perform-comparison incomparable eq? not
] [
-USING: arrays compiler generic hashtables inference kernel\r
-kernel.private math optimizer prettyprint sequences sbufs\r
-strings tools.test vectors words sequences.private quotations\r
-optimizer.backend classes inference.dataflow tuples.private\r
-continuations growable optimizer.inlining namespaces hints ;\r
-IN: temporary\r
-\r
-[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [\r
- H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*\r
-] unit-test\r
-\r
-[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [\r
- H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*\r
-] unit-test\r
-\r
-! Test method inlining\r
-[ f ] [ fixnum { } min-class ] unit-test\r
-\r
-[ string ] [\r
- \ string\r
- [ integer string array reversed sbuf\r
- slice vector quotation ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ fixnum ] [\r
- \ fixnum\r
- [ fixnum integer object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ integer ] [\r
- \ fixnum\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ object ] [\r
- \ word\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ reversed ] [\r
- \ reversed\r
- [ integer reversed slice ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-GENERIC: xyz ( obj -- obj )\r
-M: array xyz xyz ;\r
-\r
-[ t ] [ \ xyz compiled? ] unit-test\r
-\r
-! Test predicate inlining\r
-: pred-test-1\r
- dup fixnum? [\r
- dup integer? [ "integer" ] [ "nope" ] if\r
- ] [\r
- "not a fixnum"\r
- ] if ;\r
-\r
-[ 1 "integer" ] [ 1 pred-test-1 ] unit-test\r
-\r
-TUPLE: pred-test ;\r
-\r
-: pred-test-2\r
- dup tuple? [\r
- dup pred-test? [ "pred-test" ] [ "nope" ] if\r
- ] [\r
- "not a tuple"\r
- ] if ;\r
-\r
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test\r
-\r
-: pred-test-3\r
- dup pred-test? [\r
- dup tuple? [ "pred-test" ] [ "nope" ] if\r
- ] [\r
- "not a tuple"\r
- ] if ;\r
-\r
-[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test\r
-\r
-: inline-test\r
- "nom" = ;\r
-\r
-[ t ] [ "nom" inline-test ] unit-test\r
-[ f ] [ "shayin" inline-test ] unit-test\r
-[ f ] [ 3 inline-test ] unit-test\r
-\r
-: fixnum-declarations >fixnum 24 shift 1234 bitxor ;\r
-\r
-[ ] [ 1000000 fixnum-declarations . ] unit-test\r
-\r
-! regression\r
-\r
-: literal-not-branch 0 not [ ] [ ] if ;\r
-\r
-[ ] [ literal-not-branch ] unit-test\r
-\r
-! regression\r
-\r
-: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline\r
-: bad-kill-2 bad-kill-1 drop ;\r
-\r
-[ 3 ] [ t bad-kill-2 ] unit-test\r
-\r
-! regression\r
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline\r
-: the-test ( -- x y ) 2 dup (the-test) ;\r
-\r
-[ 2 0 ] [ the-test ] unit-test\r
-\r
-! regression\r
-: (double-recursion) ( start end -- )\r
- < [\r
- 6 1 (double-recursion)\r
- 3 2 (double-recursion)\r
- ] when ; inline\r
-\r
-: double-recursion 0 2 (double-recursion) ;\r
-\r
-[ ] [ double-recursion ] unit-test\r
-\r
-! regression\r
-: double-label-1 ( a b c -- d )\r
- [ f double-label-1 ] [ swap nth-unsafe ] if ; inline\r
-\r
-: double-label-2 ( a -- b )\r
- dup array? [ ] [ ] if 0 t double-label-1 ;\r
-\r
-[ 0 ] [ 10 double-label-2 ] unit-test\r
-\r
-! regression\r
-GENERIC: void-generic ( obj -- * )\r
-: breakage "hi" void-generic ;\r
-[ t ] [ \ breakage compiled? ] unit-test\r
-[ breakage ] must-fail\r
-\r
-! regression\r
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline\r
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline\r
-: test-2 ( -- ) 5 test-1 ;\r
-\r
-[ f ] [ f test-2 ] unit-test\r
-\r
-: branch-fold-regression-0 ( m -- n )\r
- t [ ] [ 1+ branch-fold-regression-0 ] if ; inline\r
-\r
-: branch-fold-regression-1 ( -- m )\r
- 10 branch-fold-regression-0 ;\r
-\r
-[ 10 ] [ branch-fold-regression-1 ] unit-test\r
-\r
-! another regression\r
-: constant-branch-fold-0 "hey" ; foldable\r
-: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline\r
-[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test\r
-\r
-! another regression\r
-: foo f ;\r
-: bar foo 4 4 = and ;\r
-[ f ] [ bar ] unit-test\r
-\r
-! ensure identities are working in some form\r
-[ t ] [\r
- [ { number } declare 0 + ] dataflow optimize\r
- [ #push? ] node-exists? not\r
-] unit-test\r
-\r
-! compiling <tuple> with a non-literal class failed\r
-: <tuple>-regression <tuple> ;\r
-\r
-[ t ] [ \ <tuple>-regression compiled? ] unit-test\r
-\r
-GENERIC: foozul ( a -- b )\r
-M: reversed foozul ;\r
-M: integer foozul ;\r
-M: slice foozul ;\r
-\r
-[ reversed ] [ reversed \ foozul specific-method ] unit-test\r
-\r
-! regression\r
-: constant-fold-2 f ; foldable\r
-: constant-fold-3 4 ; foldable\r
-\r
-[ f t ] [\r
- [ constant-fold-2 constant-fold-3 4 = ] compile-call\r
-] unit-test\r
-\r
-: constant-fold-4 f ; foldable\r
-: constant-fold-5 f ; foldable\r
-\r
-[ f ] [\r
- [ constant-fold-4 constant-fold-5 or ] compile-call\r
-] unit-test\r
-\r
-[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test\r
-\r
-[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test\r
-[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ dup - ] compile-call ] unit-test\r
-\r
-[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test\r
-[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test\r
-[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test\r
-\r
-[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test\r
-\r
-[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test\r
-\r
-[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test\r
-[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test\r
-[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test\r
-\r
-[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test\r
-[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test\r
-[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test\r
-[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test\r
-\r
-[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test\r
-[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test\r
-\r
-[ f ] [ 5 [ dup < ] compile-call ] unit-test\r
-[ t ] [ 5 [ dup <= ] compile-call ] unit-test\r
-[ f ] [ 5 [ dup > ] compile-call ] unit-test\r
-[ t ] [ 5 [ dup >= ] compile-call ] unit-test\r
-\r
-[ t ] [ 5 [ dup eq? ] compile-call ] unit-test\r
-[ t ] [ 5 [ dup = ] compile-call ] unit-test\r
-[ t ] [ 5 [ dup number= ] compile-call ] unit-test\r
-[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test\r
-\r
-GENERIC: detect-number ( obj -- obj )\r
-M: number detect-number ;\r
-\r
-[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail\r
-\r
-! Regression\r
-[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test\r
-\r
-! Regression\r
-USE: sorting\r
-USE: sorting.private\r
-\r
-: old-binsearch ( elt quot seq -- elt quot i )\r
- dup length 1 <= [\r
- slice-from\r
- ] [\r
- [ midpoint swap call ] 3keep roll dup zero?\r
- [ drop dup slice-from swap midpoint@ + ]\r
- [ partition old-binsearch ] if\r
- ] if ; inline\r
-\r
-[ 10 ] [\r
- 10 20 >vector <flat-slice>\r
- [ [ - ] swap old-binsearch ] compile-call 2nip\r
-] unit-test\r
-\r
-! Regression\r
-TUPLE: silly-tuple a b ;\r
-\r
-[ 1 2 { silly-tuple-a silly-tuple-b } ] [\r
- T{ silly-tuple f 1 2 }\r
- [\r
- { silly-tuple-a silly-tuple-b } [ get-slots ] keep\r
- ] compile-call\r
-] unit-test\r
-\r
-! Regression\r
-: empty-compound ;\r
-\r
-: node-successor-f-bug ( x -- * )\r
- [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;\r
-\r
-[ t ] [ \ node-successor-f-bug compiled? ] unit-test\r
-\r
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test\r
-\r
-[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test\r
-\r
-! Make sure we have sane heuristics\r
-: should-inline? method method-word flat-length 10 <= ;\r
-\r
-[ t ] [ \ fixnum \ shift should-inline? ] unit-test\r
-[ f ] [ \ array \ equal? should-inline? ] unit-test\r
-[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test\r
-[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test\r
-[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test\r
-[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test\r
-\r
-! Regression\r
-: lift-throw-tail-regression\r
- dup integer? [ "an integer" ] [\r
- dup string? [ "a string" ] [\r
- "error" throw\r
- ] if\r
- ] if ;\r
-\r
-[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test\r
-[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test\r
-[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test\r
-\r
-: lift-loop-tail-test-1 ( a quot -- )\r
- over even? [\r
- [ >r 3 - r> call ] keep lift-loop-tail-test-1\r
- ] [\r
- over 0 < [\r
- 2drop\r
- ] [\r
- [ >r 2 - r> call ] keep lift-loop-tail-test-1\r
- ] if\r
- ] if ; inline\r
-\r
-: lift-loop-tail-test-2\r
- 10 [ ] lift-loop-tail-test-1 1 2 3 ;\r
-\r
-[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test\r
-\r
-! Make sure we don't lose\r
-GENERIC: generic-inline-test ( x -- y )\r
-M: integer generic-inline-test ;\r
-\r
-: generic-inline-test-1\r
- 1\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test\r
- generic-inline-test ;\r
-\r
-[ { t f } ] [\r
- \ generic-inline-test-1 word-def dataflow\r
- [ optimize-1 , optimize-1 , drop ] { } make\r
-] unit-test\r
-\r
-! Forgot a recursive inline check\r
-: recursive-inline-hang ( a -- a )\r
- dup array? [ recursive-inline-hang ] when ;\r
-\r
-HINTS: recursive-inline-hang array ;\r
-\r
-: recursive-inline-hang-1\r
- { } recursive-inline-hang ;\r
-\r
-[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test\r
-\r
-DEFER: recursive-inline-hang-3\r
-\r
-: recursive-inline-hang-2 ( a -- a )\r
- dup array? [ recursive-inline-hang-3 ] when ;\r
-\r
-HINTS: recursive-inline-hang-2 array ;\r
-\r
-: recursive-inline-hang-3 ( a -- a )\r
- dup array? [ recursive-inline-hang-2 ] when ;\r
-\r
-HINTS: recursive-inline-hang-3 array ;\r
-\r
-\r
+USING: arrays compiler.units generic hashtables inference kernel
+kernel.private math optimizer prettyprint sequences sbufs
+strings tools.test vectors words sequences.private quotations
+optimizer.backend classes inference.dataflow tuples.private
+continuations growable optimizer.inlining namespaces hints ;
+IN: optimizer.tests
+
+[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
+ H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
+] unit-test
+
+[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
+ H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
+] unit-test
+
+! Test method inlining
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+ \ string
+ [ integer string array reversed sbuf
+ slice vector quotation ]
+ sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+ \ fixnum
+ [ fixnum integer object ]
+ sort-classes min-class
+] unit-test
+
+[ integer ] [
+ \ fixnum
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ object ] [
+ \ word
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ reversed ] [
+ \ reversed
+ [ integer reversed slice ]
+ sort-classes min-class
+] unit-test
+
+GENERIC: xyz ( obj -- obj )
+M: array xyz xyz ;
+
+[ t ] [ \ xyz compiled? ] unit-test
+
+! Test predicate inlining
+: pred-test-1
+ dup fixnum? [
+ dup integer? [ "integer" ] [ "nope" ] if
+ ] [
+ "not a fixnum"
+ ] if ;
+
+[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
+
+TUPLE: pred-test ;
+
+: pred-test-2
+ dup tuple? [
+ dup pred-test? [ "pred-test" ] [ "nope" ] if
+ ] [
+ "not a tuple"
+ ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
+
+: pred-test-3
+ dup pred-test? [
+ dup tuple? [ "pred-test" ] [ "nope" ] if
+ ] [
+ "not a tuple"
+ ] if ;
+
+[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
+
+: inline-test
+ "nom" = ;
+
+[ t ] [ "nom" inline-test ] unit-test
+[ f ] [ "shayin" inline-test ] unit-test
+[ f ] [ 3 inline-test ] unit-test
+
+: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
+
+[ ] [ 1000000 fixnum-declarations . ] unit-test
+
+! regression
+
+: literal-not-branch 0 not [ ] [ ] if ;
+
+[ ] [ literal-not-branch ] unit-test
+
+! regression
+
+: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
+: bad-kill-2 bad-kill-1 drop ;
+
+[ 3 ] [ t bad-kill-2 ] unit-test
+
+! regression
+: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
+: the-test ( -- x y ) 2 dup (the-test) ;
+
+[ 2 0 ] [ the-test ] unit-test
+
+! regression
+: (double-recursion) ( start end -- )
+ < [
+ 6 1 (double-recursion)
+ 3 2 (double-recursion)
+ ] when ; inline
+
+: double-recursion 0 2 (double-recursion) ;
+
+[ ] [ double-recursion ] unit-test
+
+! regression
+: double-label-1 ( a b c -- d )
+ [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+
+: double-label-2 ( a -- b )
+ dup array? [ ] [ ] if 0 t double-label-1 ;
+
+[ 0 ] [ 10 double-label-2 ] unit-test
+
+! regression
+GENERIC: void-generic ( obj -- * )
+: breakage "hi" void-generic ;
+[ t ] [ \ breakage compiled? ] unit-test
+[ breakage ] must-fail
+
+! regression
+: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
+: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
+: test-2 ( -- ) 5 test-1 ;
+
+[ f ] [ f test-2 ] unit-test
+
+: branch-fold-regression-0 ( m -- n )
+ t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
+
+: branch-fold-regression-1 ( -- m )
+ 10 branch-fold-regression-0 ;
+
+[ 10 ] [ branch-fold-regression-1 ] unit-test
+
+! another regression
+: constant-branch-fold-0 "hey" ; foldable
+: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
+[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! another regression
+: foo f ;
+: bar foo 4 4 = and ;
+[ f ] [ bar ] unit-test
+
+! ensure identities are working in some form
+[ t ] [
+ [ { number } declare 0 + ] dataflow optimize
+ [ #push? ] node-exists? not
+] unit-test
+
+! compiling <tuple> with a non-literal class failed
+: <tuple>-regression <tuple> ;
+
+[ t ] [ \ <tuple>-regression compiled? ] unit-test
+
+GENERIC: foozul ( a -- b )
+M: reversed foozul ;
+M: integer foozul ;
+M: slice foozul ;
+
+[ reversed ] [ reversed \ foozul specific-method ] unit-test
+
+! regression
+: constant-fold-2 f ; foldable
+: constant-fold-3 4 ; foldable
+
+[ f t ] [
+ [ constant-fold-2 constant-fold-3 4 = ] compile-call
+] unit-test
+
+: constant-fold-4 f ; foldable
+: constant-fold-5 f ; foldable
+
+[ f ] [
+ [ constant-fold-4 constant-fold-5 or ] compile-call
+] unit-test
+
+[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
+[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
+[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
+[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
+[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
+[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
+[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
+[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
+
+[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
+[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
+[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
+
+[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
+[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
+
+[ f ] [ 5 [ dup < ] compile-call ] unit-test
+[ t ] [ 5 [ dup <= ] compile-call ] unit-test
+[ f ] [ 5 [ dup > ] compile-call ] unit-test
+[ t ] [ 5 [ dup >= ] compile-call ] unit-test
+
+[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
+[ t ] [ 5 [ dup = ] compile-call ] unit-test
+[ t ] [ 5 [ dup number= ] compile-call ] unit-test
+[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
+
+GENERIC: detect-number ( obj -- obj )
+M: number detect-number ;
+
+[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
+
+! Regression
+[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
+
+! Regression
+USE: sorting
+USE: sorting.private
+
+: old-binsearch ( elt quot seq -- elt quot i )
+ dup length 1 <= [
+ slice-from
+ ] [
+ [ midpoint swap call ] 3keep roll dup zero?
+ [ drop dup slice-from swap midpoint@ + ]
+ [ partition old-binsearch ] if
+ ] if ; inline
+
+[ 10 ] [
+ 10 20 >vector <flat-slice>
+ [ [ - ] swap old-binsearch ] compile-call 2nip
+] unit-test
+
+! Regression
+TUPLE: silly-tuple a b ;
+
+[ 1 2 { silly-tuple-a silly-tuple-b } ] [
+ T{ silly-tuple f 1 2 }
+ [
+ { silly-tuple-a silly-tuple-b } [ get-slots ] keep
+ ] compile-call
+] unit-test
+
+! Regression
+: empty-compound ;
+
+: node-successor-f-bug ( x -- * )
+ [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
+
+[ t ] [ \ node-successor-f-bug compiled? ] unit-test
+
+[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+
+[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
+
+! Make sure we have sane heuristics
+: should-inline? method flat-length 10 <= ;
+
+[ t ] [ \ fixnum \ shift should-inline? ] unit-test
+[ f ] [ \ array \ equal? should-inline? ] unit-test
+[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
+[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
+
+! Regression
+: lift-throw-tail-regression
+ dup integer? [ "an integer" ] [
+ dup string? [ "a string" ] [
+ "error" throw
+ ] if
+ ] if ;
+
+[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
+[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
+[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
+
+: lift-loop-tail-test-1 ( a quot -- )
+ over even? [
+ [ >r 3 - r> call ] keep lift-loop-tail-test-1
+ ] [
+ over 0 < [
+ 2drop
+ ] [
+ [ >r 2 - r> call ] keep lift-loop-tail-test-1
+ ] if
+ ] if ; inline
+
+: lift-loop-tail-test-2
+ 10 [ ] lift-loop-tail-test-1 1 2 3 ;
+
+[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
+
+! Make sure we don't lose
+GENERIC: generic-inline-test ( x -- y )
+M: integer generic-inline-test ;
+
+: generic-inline-test-1
+ 1
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test
+ generic-inline-test ;
+
+[ { t f } ] [
+ \ generic-inline-test-1 word-def dataflow
+ [ optimize-1 , optimize-1 , drop ] { } make
+] unit-test
+
+! Forgot a recursive inline check
+: recursive-inline-hang ( a -- a )
+ dup array? [ recursive-inline-hang ] when ;
+
+HINTS: recursive-inline-hang array ;
+
+: recursive-inline-hang-1
+ { } recursive-inline-hang ;
+
+[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
+
+DEFER: recursive-inline-hang-3
+
+: recursive-inline-hang-2 ( a -- a )
+ dup array? [ recursive-inline-hang-3 ] when ;
+
+HINTS: recursive-inline-hang-2 array ;
+
+: recursive-inline-hang-3 ( a -- a )
+ dup array? [ recursive-inline-hang-2 ] when ;
+
+HINTS: recursive-inline-hang-3 array ;
+
+
{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ;
HELP: skip
-{ $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } }
-{ $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ;
+{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
+{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
HELP: change-column
{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
HELP: escape
{ $values { "escape" "a single-character escape" } { "ch" "a character" } }
{ $description "Converts from a single-character escape code and the corresponding character." }
-{ $examples { $example "CHAR: n escape CHAR: \\n = ." "t" } } ;
+{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ;
HELP: parse-string
{ $values { "str" "a new " { $link string } } }
{ $notes "Apart from a missing " { $link POSTPONE: USE: } ", this error can also indicate an ordering issue. In Factor, words must be defined before they can be called. Mutual recursion can be implemented via " { $link POSTPONE: DEFER: } "." } ;
HELP: search
-{ $values { "str" string } { "word" word } }
-{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, throws a " { $link no-word } " error. If the search path does not contain a word with this name but other vocabularies do, the error will have restarts offering to add vocabularies to the search path." }
+{ $values { "str" string } { "word/f" "a word or " { $link f } } }
+{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." }
$parsing-note ;
HELP: scan-word
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
HELP: finish-parsing
-{ $values { "quot" "the quotation just parsed" } }
+{ $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } }
{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." }
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units ;
-IN: temporary
+sorting tuples compiler.units debugger ;
+IN: parser.tests
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "hello world" ]
[
- "IN: temporary : hello \"hello world\" ;"
- eval "USE: temporary hello" eval
+ "IN: parser.tests : hello \"hello world\" ;"
+ eval "USE: parser.tests hello" eval
] unit-test
[ ]
: effect-parsing-test ( a b -- c ) + ;
[ t ] [
- "effect-parsing-test" "temporary" lookup
+ "effect-parsing-test" "parser.tests" lookup
\ effect-parsing-test eq?
] unit-test
[ \ baz "declared-effect" word-prop effect-terminated? ]
unit-test
- [ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
+ [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
[ t ] [
- "effect-parsing-test" "temporary" lookup
+ "effect-parsing-test" "parser.tests" lookup
\ effect-parsing-test eq?
] unit-test
[ T{ effect f { "a" "b" } { "d" } f } ]
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
- [ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test
+ [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test
[ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug
- [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test
+ [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test
- [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail
+ [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
! These should throw errors
[ "HEX: zzz" eval ] must-fail
] unit-test
DEFER: foo
- "IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
+ "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval
- [ ] [ "USE: temporary foo" eval ] unit-test
+ [ ] [ "USE: parser.tests foo" eval ] unit-test
- "IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval
+ "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval
[ t ] [
- "USE: temporary \\ foo" eval
- "foo" "temporary" lookup eq?
+ "USE: parser.tests \\ foo" eval
+ "foo" "parser.tests" lookup eq?
] unit-test
! Test smudging
[ 1 ] [
- "IN: temporary : smudge-me ;" <string-reader> "foo"
+ "IN: parser.tests : smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions first assoc-size
] unit-test
- [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test
+ [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
[ ] [
- "IN: temporary : smudge-me-more ;" <string-reader> "foo"
+ "IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
parse-stream drop
] unit-test
- [ t ] [ "smudge-me-more" "temporary" lookup >boolean ] unit-test
- [ f ] [ "smudge-me" "temporary" lookup >boolean ] unit-test
+ [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
+ [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
[ 3 ] [
- "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
+ "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions first assoc-size
] unit-test
[ 1 ] [
- "IN: temporary USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
+ "IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
parse-stream drop
"bar" source-file source-file-definitions first assoc-size
] unit-test
[ 2 ] [
- "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
+ "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions first assoc-size
] unit-test
[ t ] [
- array "smudge-me" "temporary" lookup order memq?
+ array "smudge-me" "parser.tests" lookup order memq?
] unit-test
[ t ] [
- integer "smudge-me" "temporary" lookup order memq?
+ integer "smudge-me" "parser.tests" lookup order memq?
] unit-test
[ f ] [
- string "smudge-me" "temporary" lookup order memq?
+ string "smudge-me" "parser.tests" lookup order memq?
] unit-test
[ ] [
- "IN: temporary USE: math 2 2 +" <string-reader> "a"
+ "IN: parser.tests USE: math 2 2 +" <string-reader> "a"
parse-stream drop
] unit-test
] unit-test
[ ] [
- "IN: temporary USE: math 2 2 -" <string-reader> "a"
+ "IN: parser.tests USE: math 2 2 -" <string-reader> "a"
parse-stream drop
] unit-test
[ ] [
"a" source-files get delete-at
2 [
- "IN: temporary DEFER: x : y x ; : x y ;"
+ "IN: parser.tests DEFER: x : y x ; : x y ;"
<string-reader> "a" parse-stream drop
] times
] unit-test
"a" source-files get delete-at
[
- "IN: temporary : x ; : y 3 throw ; this is an error"
+ "IN: parser.tests : x ; : y 3 throw ; this is an error"
<string-reader> "a" parse-stream
] [ parse-error? ] must-fail-with
[ t ] [
- "y" "temporary" lookup >boolean
+ "y" "parser.tests" lookup >boolean
] unit-test
[ f ] [
- "IN: temporary : x ;"
+ "IN: parser.tests : x ;"
<string-reader> "a" parse-stream drop
- "y" "temporary" lookup
+ "y" "parser.tests" lookup
] unit-test
! Test new forward definition logic
] unit-test
[ ] [
- "IN: temporary : <bogus-error> ; : bogus <bogus-error> ;"
+ "IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
[ ] [
- "IN: temporary TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
+ "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
! Problems with class predicates -vs- ordinary words
[ ] [
- "IN: temporary TUPLE: killer ;"
+ "IN: parser.tests TUPLE: killer ;"
<string-reader> "removing-the-predicate" parse-stream drop
] unit-test
[ ] [
- "IN: temporary GENERIC: killer? ( a -- b )"
+ "IN: parser.tests GENERIC: killer? ( a -- b )"
<string-reader> "removing-the-predicate" parse-stream drop
] unit-test
[ t ] [
- "killer?" "temporary" lookup >boolean
+ "killer?" "parser.tests" lookup >boolean
] unit-test
[
- "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?"
+ "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with
[
- "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
+ "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
] [ [ redefine-error? ] is? ] must-fail-with
[ ] [
- "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test"
+ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
<string-reader> "redefining-a-class-2" parse-stream drop
] unit-test
[
- "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
+ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with
[ ] [
- "IN: temporary TUPLE: class-fwd-test ;"
+ "IN: parser.tests TUPLE: class-fwd-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
] unit-test
[
- "IN: temporary \\ class-fwd-test"
+ "IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with
[ ] [
- "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
+ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] unit-test
[
- "IN: temporary \\ class-fwd-test"
+ "IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
] [ [ no-word? ] is? ] must-fail-with
[
- "IN: temporary : foo ; TUPLE: foo ;"
+ "IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
] [ [ redefine-error? ] is? ] must-fail-with
[ ] [
- "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
+ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
] unit-test
[
- "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
+ "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
] must-fail
] with-file-vocabs
<< file get parsed >> file set
: ~a ;
- : ~b ~a ;
+
+ DEFER: ~b
+
+ "IN: parser.tests : ~b ~a ;" <string-reader>
+ "smudgy" parse-stream drop
+
: ~c ;
: ~d ;
- { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
+ { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
- { H{ { ~d ~d } } H{ } } new-definitions set
+ { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
[ V{ ~b } { ~a } { ~a ~c } ] [
smudged-usage
] unit-test
] with-scope
+[
+ << file get parsed >> file set
+
+ GENERIC: ~e
+
+ : ~f ~e ;
+
+ : ~g ;
+
+ { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
+
+ { H{ { ~g ~g } } H{ } } new-definitions set
+
+ [ V{ } { } { ~e ~f } ]
+ [ smudged-usage natural-sort ]
+ unit-test
+] with-scope
+
[ ] [
- "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
+ "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
] unit-test
[ t ] [
- "foo?" "temporary" lookup word eq?
+ "foo?" "parser.tests" lookup word eq?
+] unit-test
+
+[ ] [
+ "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+ <string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
+
+[ ] [
+ "IN: parser.tests M: f foo ;"
+ <string-reader> "redefining-a-class-6" parse-stream drop
+] unit-test
+
+[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
+
+[ ] [
+ "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+ <string-reader> "redefining-a-class-5" parse-stream drop
+] unit-test
+
+[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
+
+[ ] [
+ "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+ <string-reader> "redefining-a-class-7" parse-stream drop
+] unit-test
+
+[ ] [
+ "IN: parser.tests TUPLE: foo ;"
+ <string-reader> "redefining-a-class-7" parse-stream drop
+] unit-test
+
+[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
+
+[ "resource:core/parser/test/assert-depth.factor" run-file ]
+[ relative-overflow-stack { 1 2 3 } sequence= ]
+must-fail-with
namespaces prettyprint sequences strings vectors words
quotations inspector io.styles io combinators sorting
splitting math.parser effects continuations debugger
-io.files io.streams.string io.streams.lines vocabs
+io.files io.streams.string vocabs io.encodings.utf8
source-files classes hashtables compiler.errors compiler.units ;
IN: parser
: CREATE ( -- word ) scan create-in ;
-: CREATE-CLASS ( -- word )
- scan in get create
+: create-class-in ( word -- word )
+ in get create
dup save-class-location
dup predicate-word dup set-word save-location ;
+: CREATE-CLASS ( -- word )
+ scan create-class-in ;
+
: word-restarts ( possibilities -- restarts )
natural-sort [
[ "Use the word " swap summary append ] keep
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
+: (:) CREATE dup reset-generic parse-definition ;
+
GENERIC: expected>string ( obj -- str )
M: f expected>string drop "end of input" ;
"Warning: the following definitions were removed from sources," print
"but are still referenced from other definitions:" print
nl
- dup stack.
+ dup sorted-definitions.
nl
"The following definitions need to be updated:" print
nl
- over stack.
+ over sorted-definitions.
+ nl
] when 2drop ;
: filter-moved ( assoc -- newassoc )
dup values concat prune swap keys
] keep ;
+: fix-class-words ( -- )
+ #! If a class word had a compound definition which was
+ #! removed, it must go back to being a symbol.
+ new-definitions get first2 diff
+ [ nip dup reset-generic define-symbol ] assoc-each ;
+
: forget-smudged ( -- )
smudged-usage forget-all
- over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
+ over empty? [ 2dup smudged-usage-warning ] unless 2drop
+ fix-class-words ;
: finish-parsing ( lines quot -- )
file get
[
[
[ parsing-file ] keep
- [ ?resource-path <file-reader> ] keep
+ [ ?resource-path utf8 <file-reader> ] keep
parse-stream
] with-compiler-errors
] [
] recover ;
: run-file ( file -- )
- [ [ parse-file call ] keep ] assert-depth drop ;
+ [ dup parse-file call ] assert-depth drop ;
: ?run-file ( path -- )
dup resource-exists? [ run-file ] [ drop ] if ;
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
- { $example ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" }
- { $example "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" }
+ { $example "USING: definitions prettyprint ;" ": foo ; \\ foo definer . ." ";\nPOSTPONE: :" }
+ { $example "USING: definitions prettyprint ;" "SYMBOL: foo \\ foo definer . ." "f\nPOSTPONE: SYMBOL:" }
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
{ $contract "Outputs the body of a definition." }
{ $examples
- { $example "USE: math" "\\ sq definition ." "[ dup * ]" }
+ { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
-continuations generic compiler.units ;
-IN: temporary
+continuations generic compiler.units tools.walker ;
+IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
[ "1.0" ] [ 1.0 unparse ] unit-test
[ "[ \\ [ ]" ] [ [ \ [ ] unparse ] unit-test
[ t ] [
- 100 \ dup <array> [ pprint-short ] with-string-writer
+ 100 \ dup <array> unparse-short
"{" head?
] unit-test
: foo ( a -- b ) dup * ; inline
-[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ]
+[ "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" ]
[ [ \ foo see ] with-string-writer ] unit-test
: bar ( x -- y ) 2 + ;
-[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ]
+[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ]
[ [ \ bar see ] with-string-writer ] unit-test
: blah
[
[ parse-fresh drop ] with-compilation-unit
[
- "temporary" lookup see
+ "prettyprint.tests" lookup see
] with-string-writer "\n" split 1 head*
] keep =
] with-scope ;
: method-test
{
- "IN: temporary"
+ "IN: prettyprint.tests"
"GENERIC: method-layout"
""
- "USING: math temporary ;"
+ "USING: math prettyprint.tests ;"
"M: complex method-layout"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;"
""
- "USING: math temporary ;"
+ "USING: math prettyprint.tests ;"
"M: fixnum method-layout ;"
""
- "USING: math temporary ;"
+ "USING: math prettyprint.tests ;"
"M: integer method-layout ;"
""
- "USING: kernel temporary ;"
+ "USING: kernel prettyprint.tests ;"
"M: object method-layout ;"
} ;
: retain-stack-test
{
"USING: io kernel sequences words ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": retain-stack-layout ( x -- )"
" dup stream-readln stream-readln"
" >r [ define ] map r>"
: soft-break-test
{
"USING: kernel math sequences strings ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": soft-break-layout ( x y -- ? )"
" over string? ["
" over hashcode over hashcode number="
: another-retain-layout-test
{
"USING: kernel sequences ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": another-retain-layout ( seq1 seq2 quot -- newseq )"
" -rot 2dup dupd min-length [ each drop roll ] map"
" >r 3drop r> ; inline"
: another-soft-break-test
{
"USING: namespaces parser sequences ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
" [ <reversed> \"hello world foo\" add ] [ ] make ;"
: string-layout
{
"USING: io kernel parser ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": string-layout-test ( error -- )"
" \"Expected \" write dup unexpected-want expected>string write"
" \" but got \" write unexpected-got expected>string print ;"
: final-soft-break-test
{
"USING: kernel sequences ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": final-soft-break-layout ( class dim -- view )"
" >r \"alloc\" send 0 0 r>"
" first2 <NSRect>"
: narrow-test
{
"USING: arrays combinators continuations kernel sequences ;"
- "IN: temporary"
+ "IN: prettyprint.tests"
": narrow-layout ( obj -- )"
" {"
" { [ dup continuation? ] [ append ] }"
: another-narrow-test
{
- "IN: temporary"
+ "IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
" H{"
" { 1 2 }"
: class-see-test
{
- "IN: temporary"
+ "IN: prettyprint.tests"
"TUPLE: class-see-layout ;"
""
- "IN: temporary"
+ "IN: prettyprint.tests"
"GENERIC: class-see-layout ( x -- y )"
""
- "USING: temporary ;"
+ "USING: prettyprint.tests ;"
"M: class-see-layout class-see-layout ;"
} ;
! Regression
[ t ] [
- "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
+ "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval
- "generic-decl-test" "temporary" lookup
+ "generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer =
] unit-test
[ [ + ] ] [
- [ \ + (step-into) ] (remove-breakpoints)
+ [ \ + (step-into-execute) ] (remove-breakpoints)
] unit-test
-[ [ (step-into) ] ] [
- [ (step-into) ] (remove-breakpoints)
-] unit-test
-
-[ [ 3 ] ] [
- [ 3 (step-into) ] (remove-breakpoints)
+[ [ (step-into-execute) ] ] [
+ [ (step-into-execute) ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [
- [ 2 2 \ + (step-into) . ] (remove-breakpoints)
+ [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
[ [ 2 2 + . ] ] [
- [ 2 break 2 \ + (step-into) . ] (remove-breakpoints)
-] unit-test
-
-[ [ 2 . ] ] [
- [ 2 \ break (step-into) . ] (remove-breakpoints)
+ [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
{ string-limit t }
} clone [ pprint ] bind ;
+: unparse-short ( obj -- str )
+ [ pprint-short ] with-string-writer ;
+
: short. ( obj -- ) pprint-short nl ;
: .b ( n -- ) >bin print ;
{ { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
"word-style" set-word-prop
-! This code is ugly and could probably be simplified
-: remove-step-into
- building get dup empty? [
- drop \ (step-into) ,
- ] [
- pop dup wrapper? [
- wrapped dup \ break eq?
- [ drop ] [ , ] if
- ] [
- ,
- ] if
- ] if ;
+: remove-step-into ( word -- )
+ building get dup empty? [ drop ] [ nip pop wrapped ] if , ;
: (remove-breakpoints) ( quot -- newquot )
[
[
{
- { break [ ] }
- { (step-into) [ remove-step-into ] }
- [ , ]
- } case
+ { [ dup word? not ] [ , ] }
+ { [ dup "break?" word-prop ] [ drop ] }
+ { [ dup "step-into?" word-prop ] [ remove-step-into ] }
+ { [ t ] [ , ] }
+ } cond
] each
] [ ] make ;
M: method-spec synopsis*
dup definer. [ pprint-word ] each ;
+M: method-body synopsis*
+ dup dup
+ definer.
+ "method-class" word-prop pprint*
+ "method-generic" word-prop pprint* ;
+
M: mixin-instance synopsis*
dup definer.
dup mixin-instance-class pprint-word
[ synopsis* ] with-in
] with-string-writer ;
+: synopsis-alist ( definitions -- alist )
+ [ dup synopsis swap ] { } map>assoc ;
+
+: definitions. ( alist -- )
+ [ write-object nl ] assoc-each ;
+
+: sorted-definitions. ( definitions -- )
+ synopsis-alist sort-keys definitions. ;
+
GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
natural-sort [ nl see ] each ;
: see-implementors ( class -- seq )
- dup implementors [ 2array ] with map ;
+ dup implementors
+ [ method ] with map
+ natural-sort ;
: see-class ( class -- )
dup class? [
] when drop ;
: see-methods ( generic -- seq )
- [ "methods" word-prop keys natural-sort ] keep
- [ 2array ] curry map ;
+ "methods" word-prop values natural-sort ;
M: word see
dup see-class
{ $values { "obj" object } { "wrapped" object } }
{ $description "Outputs an object which evaluates to " { $snippet "obj" } " when placed in a quotation. If " { $snippet "obj" } " is not self-evaluating (for example, it is a word), then it will be wrapped." }
{ $examples
- { $example "USE: quotations" "5 literalize ." "5" }
- { $example "USE: quotations" "[ + ] [ literalize ] map ." "[ \\ + ]" }
+ { $example "USING: prettyprint quotations ;" "5 literalize ." "5" }
+ { $example "USING: math prettyprint quotations sequences ;" "[ + ] [ literalize ] map ." "[ \\ + ]" }
} ;
{ literalize curry <wrapper> POSTPONE: \ POSTPONE: W{ } related-words
USING: math kernel quotations tools.test sequences ;
-IN: temporary
+IN: quotations.tests
[ [ 3 ] ] [ 3 [ ] curry ] unit-test
[ [ \ + ] ] [ \ + [ ] curry ] unit-test
USING: kernel math namespaces sequences sbufs strings
tools.test classes ;
-IN: temporary
+IN: sbufs.tests
[ 5 ] [ "Hello" >sbuf length ] unit-test
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } }
{ $contract "Outputs a resizable mutable sequence with an initial capacity of " { $snippet "n" } " elements and zero length, which can hold the elements of " { $snippet "seq" } "." }
{ $examples
- { $example "300 V{ } new-resizable ." "V{ }" }
- { $example "300 SBUF\" \" new-resizable ." "SBUF\" \"" }
+ { $example "USING: prettyprint sequences ;" "300 V{ } new-resizable ." "V{ }" }
+ { $example "USING: prettyprint sequences ;" "300 SBUF\" \" new-resizable ." "SBUF\" \"" }
} ;
HELP: like
HELP: each
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
-{ $description "Applies the quotation to each element of the sequence in turn." } ;
+{ $description "Applies the quotation to each element of the sequence in order." } ;
HELP: reduce
{ $values { "seq" sequence } { "identity" object } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." }
{ $examples
- { $example "{ 1 5 3 } 0 [ + ] reduce ." "9" }
+ { $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
} ;
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
-{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence. Given the empty sequence, outputs a one-element sequence consisting of " { $snippet "identity" } "." }
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
+$nl
+"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
{ $examples
- { $example "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" }
+ { $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" }
} ;
HELP: map
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each element yielding a new element. The new elements are collected into a sequence of the same class as the input sequence." } ;
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
{ $examples
"Testing if a sequence is non-decreasing:"
- { $example "{ 1 1 2 } [ <= ] monotonic? ." "t" }
+ { $example "USING: math prettyprint sequences ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" }
"Testing if a sequence is decreasing:"
- { $example "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
+ { $example "USING: math prettyprint sequences ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
} ;
{ monotonic? all-eq? all-equal? } related-words
HELP: interleave
{ $values { "seq" sequence } { "between" "a quotation" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
-{ $example "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
+{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
HELP: cache-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( i -- elt )" } } { "elt" object } }
{ $description "Tests if the sequence contains the object." }
{ $examples
"This word uses identity comparison, so the following will most likely print " { $link f } ":"
- { $example "\"hello\" { \"hello\" } memq? ." "f" }
+ { $example "USING: prettyprint sequences ;" "\"hello\" { \"hello\" } memq? ." "f" }
} ;
HELP: remove
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $examples
{ $example
+ "USING: namespaces prettyprint sequences ;"
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
"\"nachos\" \"v\" get push-new"
"\"salsa\" \"v\" get push-new"
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
- { $example "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
} ;
HELP: add*
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
- { $example "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
+{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
} ;
HELP: seq-diff
HELP: flip
{ $values { "matrix" "a sequence of equal-length sequences" } { "newmatrix" "a sequence of equal-length sequences" } }
{ $description "Transposes the matrix; that is, rows become columns and columns become rows." }
-{ $examples { $example "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ;
+{ $examples { $example "USING: prettyprint sequences ;" "{ { 1 2 3 } { 4 5 6 } } flip ." "{ { 1 4 } { 2 5 } { 3 6 } }" } } ;
HELP: exchange
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
HELP: pad-left
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
{ $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." }
-{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ;
+{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ;
HELP: pad-right
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
{ $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." }
-{ $examples { $example "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ;
+{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ;
HELP: sequence=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
+ "USING: arrays prettyprint sequences ;"
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
"{ 1 4 7 }"
}
{ $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } }
{ $description "Creates a new " { $link repetition } "." }
{ $examples
- { $example "10 \"X\" <repetition> >array ." "{ \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" }" }
- { $example "10 \"X\" <repetition> >array concat ." "\"XXXXXXXXXX\"" }
+ { $example "USING: arrays prettyprint sequences ;" "10 \"X\" <repetition> >array ." "{ \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" \"X\" }" }
+ { $example "USING: prettyprint sequences ;" "10 \"X\" <repetition> concat ." "\"XXXXXXXXXX\"" }
} ;
HELP: copy
{ $values { "src" sequence } { "i" "an index in " { $snippet "dest" } } { "dst" "a mutable sequence" } }
{ $values { "seq" sequence } { "rest" sequence } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
{ $examples
- { $example "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
} ;
HELP: unclip-slice
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
- { $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
+ { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
"The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
- { $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
+ { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
} ;
USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays
generic ;
-IN: temporary
+IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
[ 3 ] [ 1 4 dup <slice> length ] unit-test
<PRIVATE
-: iterate-seq >r dup length swap r> ; inline
-
: (each) ( seq quot -- n quot' )
- iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline
+ >r dup length swap [ nth-unsafe ] curry r> compose ; inline
: (collect) ( quot into -- quot' )
- [ >r over slip r> set-nth-unsafe ] 2curry ; inline
+ [ >r keep r> set-nth-unsafe ] 2curry ; inline
: collect ( n quot into -- )
(collect) each-integer ; inline
>r dup length 1- swap r> (monotonic) all? ; inline
: interleave ( seq between quot -- )
- [ (interleave) ] 2curry iterate-seq 2each ; inline
+ [ (interleave) ] 2curry >r dup length swap r> 2each ; inline
: unfold ( pred quot tail -- seq )
V{ } clone [
: memq? ( obj seq -- ? )
[ eq? ] with contains? ;
+: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
+ swap [ member? ] curry subset ;
+
: remove ( obj seq -- newseq )
[ = not ] with subset ;
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
- dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
+ dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
- ] keep bitxor ; inline
+ ] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [
HELP: slot-reader
{ $class-description "The class of slot reader words." }
{ $examples
- { $example "USING: classes slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
+ { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
} ;
HELP: define-reader
HELP: slot-writer
{ $class-description "The class of slot writer words." }
{ $examples
- { $example "USING: classes slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
+ { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
} ;
HELP: define-writer
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;
+
+: slot-named ( string specs -- spec/f )
+ [ slot-spec-name = ] with find nip ;
USING: sorting sequences kernel math random tools.test
vectors ;
-IN: temporary
+IN: sorting.tests
[ [ ] ] [ [ ] natural-sort ] unit-test
[ t ] [
100 [
drop
- 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ <=> 0 <= ] monotonic?
+ 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
] all?
] unit-test
: sort-values ( seq -- sortedseq ) [ [ second ] compare ] sort ;
-: sort-pair ( a b -- c d ) 2dup <=> 0 > [ swap ] when ;
+: sort-pair ( a b -- c d ) 2dup after? [ swap ] when ;
: midpoint ( seq -- elt )
[ midpoint@ ] keep nth-unsafe ; inline
$low-level-note ;
HELP: record-checksum
-{ $values { "source-file" source-file } { "contents" string } }
+{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
namespaces prettyprint sequences strings vectors words
quotations inspector io.styles io combinators sorting
splitting math.parser effects continuations debugger
-io.files io.crc32 io.streams.string io.streams.lines vocabs
-hashtables graphs compiler.units ;
+io.files io.crc32 io.streams.string vocabs
+hashtables graphs compiler.units io.encodings.utf8 ;
IN: source-files
SYMBOL: source-files
: (source-modified?) ( path modified checksum -- ? )
pick file-modified rot [ 0 or ] 2apply >
- [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ;
+ [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ;
: source-modified? ( path -- ? )
dup source-files get at [
: reset-checksums ( -- )
source-files get [
swap ?resource-path dup exists?
- [ file-lines swap record-checksum ] [ 2drop ] if
+ [
+ over record-modified
+ utf8 file-lines swap record-checksum
+ ] [ 2drop ] if
] assoc-each ;
M: pathname where pathname-string 1 2array ;
M: pathname forget*
pathname-string forget-source ;
-: rollback-source-file ( source-file -- )
+: rollback-source-file ( file -- )
dup source-file-definitions new-definitions get [ union ] 2map
swap set-source-file-definitions ;
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
-: smart-usage ( word -- definitions )
- \ f or usage [
- dup method-body? [
- "method" word-prop
- { method-specializer method-generic } get-slots
- 2array
- ] when
- ] map ;
-
: outside-usages ( seq -- usages )
dup [
- over smart-usage [ pathname? not ] subset seq-diff
+ over usage
+ [ dup pathname? not swap where and ] subset seq-diff
] curry { } map>assoc ;
HELP: split
{ $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } }
{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
-{ $examples { $example "USE: splitting" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
+{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: groups
{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
- "USE: splitting"
+ "USING: arrays kernel prettyprint sequences splitting ;"
"9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
} ;
{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
- "USE: splitting"
+ "USING: arrays kernel prettyprint sequences splitting ;"
"9 >array 3 <sliced-groups>"
"dup [ reverse-here ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
{ $values { "str" string } { "seq" "a sequence of strings" } }
{ $description "Splits a string along line breaks." }
{ $examples
- { $example "USE: splitting" "\"Hello\\r\\nworld\\n\" string-lines ." "{ \"Hello\" \"world\" \"\" }" }
+ { $example "USING: prettyprint splitting ;" "\"Hello\\r\\nworld\\n\" string-lines ." "{ \"Hello\" \"world\" \"\" }" }
} ;
USING: splitting tools.test ;
-IN: temporary
+IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
- dup [ "\r\n" member? ] contains? [
+ dup "\r\n" seq-intersect empty? [
+ 1array
+ ] [
"\n" split [
1 head-slice* [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split add concat
- ] [
- 1array
] if ;
USING: continuations kernel math namespaces strings sbufs
tools.test sequences vectors arrays ;
-IN: temporary
+IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
[ "end" ] [ "Beginning and end" 14 tail ] unit-test
-[ t ] [ "abc" "abd" <=> 0 < ] unit-test
-[ t ] [ "z" "abd" <=> 0 > ] unit-test
+[ t ] [ "abc" "abd" before? ] unit-test
+[ t ] [ "z" "abd" after? ] unit-test
[ 0 10 "hello" subseq ] must-fail
ARTICLE: "syntax-pathnames" "Pathname syntax"
{ $subsection POSTPONE: P" }
-"Pathnames are documented in " { $link "file-streams" } "." ;
+"Pathnames are documented in " { $link "pathnames" } "." ;
ARTICLE: "syntax-literals" "Literals"
"Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words."
HELP: parsing
{ $syntax ": foo ... ; parsing" }
{ $description "Declares the most recently defined word as a parsing word." }
-{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example ": hello \"Hello parser!\" print ; parsing\n: world hello ;" "Hello parser!" } } ;
+{ $examples "In the below example, the " { $snippet "world" } " word is never called, however its body references a parsing word which executes immediately:" { $example "USE: io" "<< : hello \"Hello parser!\" print ; parsing >>\n: world hello ;" "Hello parser!" } } ;
HELP: inline
{ $syntax ": foo ... ; inline" }
{ $syntax "SYMBOL: word" }
{ $values { "word" "a new word to define" } }
{ $description "Defines a new symbol word in the current vocabulary. Symbols push themselves on the stack when executed, and are used to identify variables (see " { $link "namespaces" } ") as well as for storing crufties in word properties (see " { $link "word-props" } ")." }
-{ $examples { $example "SYMBOL: foo\nfoo ." "foo" } } ;
+{ $examples { $example "USE: prettyprint" "SYMBOL: foo\nfoo ." "foo" } } ;
{ define-symbol POSTPONE: SYMBOL: } related-words
{ $syntax "\"string...\"" }
{ $values { "string" "literal and escaped characters" } }
{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", and appends the resulting string to the parse tree. String literals cannot span multiple lines. Strings containing the " { $link POSTPONE: " } " character and various other special characters can be read by inserting escape sequences." }
-{ $examples { $example "\"Hello\\nworld\" print" "Hello\nworld" } } ;
+{ $examples { $example "USE: io" "\"Hello\\nworld\" print" "Hello\nworld" } } ;
HELP: SBUF"
{ $syntax "SBUF\" string... \"" }
{ $values { "string" "literal and escaped characters" } }
{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", converts the string to a string buffer, and appends it to the parse tree." }
-{ $examples { $example "SBUF\" Hello world\" >string print" "Hello world" } } ;
+{ $examples { $example "USING: io strings ;" "SBUF\" Hello world\" >string print" "Hello world" } } ;
HELP: P"
{ $syntax "P\" pathname\"" }
{ $values { "pathname" "a pathname string" } }
{ $description "Reads from the input string until the next occurrence of " { $link POSTPONE: " } ", creates a new " { $link pathname } ", and appends it to the parse tree." }
-{ $examples { $example "USE: io.files" "P\" foo.txt\" pathname-string print" "foo.txt" } } ;
+{ $examples { $example "USING: io io.files ;" "P\" foo.txt\" pathname-string print" "foo.txt" } } ;
HELP: (
{ $syntax "( inputs -- outputs )" }
{ $syntax "HEX: integer" }
{ $values { "integer" "hexadecimal digits (0-9, a-f, A-F)" } }
{ $description "Adds an integer read from a hexadecimal literal to the parse tree." }
-{ $examples { $example "HEX: ff ." "255" } } ;
+{ $examples { $example "USE: prettyprint" "HEX: ff ." "255" } } ;
HELP: OCT:
{ $syntax "OCT: integer" }
{ $values { "integer" "octal digits (0-7)" } }
{ $description "Adds an integer read from an octal literal to the parse tree." }
-{ $examples { $example "OCT: 31337 ." "13023" } } ;
+{ $examples { $example "USE: prettyprint" "OCT: 31337 ." "13023" } } ;
HELP: BIN:
{ $syntax "BIN: integer" }
{ $values { "integer" "binary digits (0 and 1)" } }
{ $description "Adds an integer read from an binary literal to the parse tree." }
-{ $examples { $example "BIN: 100 ." "4" } } ;
+{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
HELP: GENERIC:
{ $syntax "GENERIC: word" }
{ $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
{ $examples
{ $example
+ "USING: io namespaces ;"
"SYMBOL: transport"
"TUPLE: land-transport ;"
"TUPLE: air-transport ;"
] define-syntax
":" [
- CREATE dup reset-generic parse-definition define
+ (:) define
] define-syntax
"GENERIC:" [
USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private io.files strings ;
+namespaces sequences kernel.private strings ;
IN: system
ARTICLE: "os" "System interface"
{ $subsection wince? }
"Processor detection:"
{ $subsection cpu }
-"Processor cell size:"
-{ $subsection cell }
-{ $subsection cells }
-{ $subsection cell-bits }
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
{ $subsection millis }
"Exiting the Factor VM:"
{ $subsection exit }
-{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ;
+{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
ABOUT: "os"
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-{ os-env os-envs } related-words
+HELP: set-os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Replaces the current set of environment variables." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
+
+{ os-env os-envs set-os-envs } related-words
HELP: win32?
{ $values { "?" "a boolean" } }
HELP: unix?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;
-
-HELP: cell
-{ $values { "n" "a positive integer" } }
-{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
-
-HELP: cells
-{ $values { "m" integer } { "n" integer } }
-{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
-
-HELP: cell-bits
-{ $values { "n" integer } }
-{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
-
-HELP: bootstrap-cell
-{ $values { "n" "a positive integer" } }
-{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
-
-HELP: bootstrap-cells
-{ $values { "m" integer } { "n" integer } }
-{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
-
-HELP: bootstrap-cell-bits
-{ $values { "n" integer } }
-{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
-USING: math tools.test system prettyprint ;
-IN: temporary
+USING: math tools.test system prettyprint namespaces kernel ;
+IN: system.tests
-[ t ] [ cell integer? ] unit-test
-[ t ] [ bootstrap-cell integer? ] unit-test
-[ ] [ os-envs . ] unit-test
+wince? [
+ [ ] [ os-envs . ] unit-test
+] unless
+
+unix? [
+ [ ] [ os-envs "envs" set ] unit-test
+ [ ] [ { { "A" "B" } } set-os-envs ] unit-test
+ [ "B" ] [ "A" os-env ] unit-test
+ [ ] [ "envs" get set-os-envs ] unit-test
+ [ t ] [ os-envs "envs" get = ] unit-test
+] when
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
-splitting assocs ;
-
-: cell ( -- n ) 7 getenv ; foldable
-
-: cells ( m -- n ) cell * ; inline
-
-: cell-bits ( -- n ) 8 cells ; inline
+splitting assocs system.private layouts ;
: cpu ( -- cpu ) 8 getenv ; foldable
: solaris? ( -- ? )
os "solaris" = ;
-: bootstrap-cell \ cell get cell or ; inline
-
-: bootstrap-cells bootstrap-cell * ; inline
-
-: bootstrap-cell-bits 8 bootstrap-cells ; inline
-
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
+
+: set-os-envs ( assoc -- )
+ [ "=" swap 3append ] { } assoc>map (set-os-envs) ;
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings
-assocs heaps boxes ;
+assocs heaps boxes namespaces ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
ARTICLE: "threads-yield" "Yielding and suspending threads"
"Yielding to other threads:"
{ $subsection yield }
+"Sleeping for a period of time:"
{ $subsection sleep }
+"Interrupting sleep:"
+{ $subsection interrupt }
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
{ $subsection suspend }
{ $subsection resume }
{ { $link thread-name } " - the name passed to " { $link spawn } "." }
{ { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
{ { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
- { { $link thread-registered? } " - a boolean indicating whether the thread is eligible to run or not. Spawning a thread with " { $link (spawn) } " sets this flag and " { $link stop } " clears it." }
}
} ;
{ $description "Pushes the currently-running thread." } ;
HELP: <thread>
-{ $values { "quot" quotation } { "name" string } { "error-handler" quotation } }
-{ $description "Low-level thread constructor. The thread runs the quotation when spawned; the name is simply used to identify the thread for debugging purposes. The error handler is called if the thread's quotation throws an unhandled error; it should either print the error or notify another thread." }
+{ $values { "quot" quotation } { "name" string } { "thread" thread } }
+{ $description "Low-level thread constructor. The thread runs the quotation when spawned."
+$nl
+"The name is used to identify the thread for debugging purposes; see " { $link "tools.threads" } "." }
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
HELP: run-queue
{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
HELP: sleep-time
-{ $values { "ms" "a non-negative integer or " { $link f } } }
+{ $values { "ms/f" "a non-negative integer or " { $link f } } }
{ $description "Outputs the time until the next sleeping thread is scheduled to wake up, which could be zero if there are threads in the run queue, or threads which need to wake up right now. If there are no runnable or sleeping threads, outputs " { $link f } "." } ;
HELP: stop
HELP: yield
{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;
+HELP: sleep-until
+{ $values { "time/f" "a non-negative integer or " { $link f } } }
+{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
+$nl
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+
HELP: sleep
{ $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds. It will not get woken up before this time period elapses, but since the multitasker is co-operative, the precise wakeup time is dependent on when other threads yield." } ;
+{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
+$nl
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+
+HELP: interrupt
+{ $values { "thread" thread } }
+{ $description "Interrupts a sleeping thread." } ;
HELP: suspend
-{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "obj" object } }
-{ $description "Suspends the current thread and passes it to the quotation. After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "." } ;
+{ $values { "quot" "a quotation with stack effect " { $snippet "( thread -- )" } } { "state" string } { "obj" object } }
+{ $description "Suspends the current thread and passes it to the quotation."
+$nl
+"After the quotation returns, control yields to the next runnable thread and the current thread does not execute again until it is resumed, and so the quotation must arrange for another thread to later resume the suspended thread with a call to " { $link resume } " or " { $link resume-with } "."
+$nl
+"The status string is for debugging purposes; see " { $link "tools.threads" } "." } ;
HELP: spawn
-{ $values { "quot" quotation } { "name" string } }
+{ $values { "quot" quotation } { "name" string } { "thread" thread } }
{ $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue."
$nl
-"The new thread begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." }
+"The new thread begins with an empty data stack, an empty retain stack, and an empty catch stack. The name stack is inherited from the parent thread but may be cleared with " { $link init-namespaces } "." }
+{ $notes
+ "The recommended way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "."
+}
{ $examples
{ $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" }
} ;
HELP: spawn-server
-{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } }
+{ $values { "quot" "a quotation with stack effect " { $snippet "( -- ? )" } } { "name" string } { "thread" thread } }
{ $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." }
{ $examples
"A thread that runs forever:"
USING: namespaces io tools.test threads kernel ;
-IN: temporary
+IN: threads.tests
3 "x" set
namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop
IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators debugger prettyprint io init
-boxes ;
+dlists assocs system combinators init boxes ;
SYMBOL: initial-thread
TUPLE: thread
-name quot error-handler
-id registered?
+name quot exit-handler
+id
continuation state
-mailbox variables ;
+mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
: thread ( id -- thread ) threads at ;
-<PRIVATE
+: thread-registered? ( thread -- ? )
+ thread-id threads key? ;
: check-unregistered
dup thread-registered?
- [ "Registering a thread twice" throw ] when ;
+ [ "Thread already stopped" throw ] when ;
: check-registered
dup thread-registered?
- [ "Unregistering a thread twice" throw ] unless ;
+ [ "Thread is not running" throw ] unless ;
+
+<PRIVATE
: register-thread ( thread -- )
- check-unregistered
- t over set-thread-registered?
- dup thread-id threads set-at ;
+ check-unregistered dup thread-id threads set-at ;
: unregister-thread ( thread -- )
- check-registered
- f over set-thread-registered?
- thread-id threads delete-at ;
+ check-registered thread-id threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
PRIVATE>
-: <thread> ( quot name error-handler -- thread )
- \ thread counter <box> {
+: <thread> ( quot name -- thread )
+ \ thread counter <box> [ ] {
set-thread-quot
set-thread-name
- set-thread-error-handler
set-thread-id
set-thread-continuation
+ set-thread-exit-handler
} \ thread construct ;
: run-queue 42 getenv ;
: sleep-queue 43 getenv ;
: resume ( thread -- )
+ f over set-thread-state
check-registered run-queue push-front ;
+: resume-now ( thread -- )
+ f over set-thread-state
+ check-registered run-queue push-back ;
+
: resume-with ( obj thread -- )
+ f over set-thread-state
check-registered 2array run-queue push-front ;
+: sleep-time ( -- ms/f )
+ {
+ { [ run-queue dlist-empty? not ] [ 0 ] }
+ { [ sleep-queue heap-empty? ] [ f ] }
+ { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+ } cond ;
+
<PRIVATE
: schedule-sleep ( thread ms -- )
- >r check-registered r> sleep-queue heap-push ;
+ >r check-registered dup r> sleep-queue heap-push*
+ swap set-thread-sleep-entry ;
-: wake-up? ( heap -- ? )
+: expire-sleep? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
-: wake-up ( -- )
+: expire-sleep ( thread -- )
+ f over set-thread-sleep-entry resume ;
+
+: expire-sleep-loop ( -- )
sleep-queue
- [ dup wake-up? ] [ dup heap-pop drop resume ] [ ] while
+ [ dup expire-sleep? ]
+ [ dup heap-pop drop expire-sleep ]
+ [ ] while
drop ;
-: next ( -- )
- walker-hook [
- continue
+: next ( -- * )
+ expire-sleep-loop
+ run-queue dup dlist-empty? [
+ ! We should never be in a state where the only threads
+ ! are sleeping; the I/O wait thread is always runnable.
+ ! However, if it dies, we handle this case
+ ! semi-gracefully.
+ !
+ ! And if sleep-time outputs f, there are no sleeping
+ ! threads either... so WTF.
+ drop sleep-time [ die 0 ] unless* (sleep) next
] [
- wake-up
- run-queue pop-back
+ pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
f over set-thread-state
thread-continuation box>
continue-with
- ] if* ;
+ ] if ;
PRIVATE>
-: sleep-time ( -- ms )
- {
- { [ run-queue dlist-empty? not ] [ 0 ] }
- { [ sleep-queue heap-empty? ] [ f ] }
- { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
- } cond ;
-
: stop ( -- )
- self unregister-thread next ;
+ self dup thread-exit-handler call
+ unregister-thread next ;
: suspend ( quot state -- obj )
[
self swap call next
] callcc1 2nip ; inline
-: yield ( -- ) [ resume ] "yield" suspend drop ;
+: yield ( -- ) [ resume ] f suspend drop ;
+
+GENERIC: sleep-until ( time/f -- )
-: sleep ( ms -- )
- >fixnum millis +
- [ schedule-sleep ] curry
- "sleep" suspend drop ;
+M: integer sleep-until
+ [ schedule-sleep ] curry "sleep" suspend drop ;
+
+M: f sleep-until
+ drop [ drop ] "interrupt" suspend drop ;
+
+GENERIC: sleep ( ms -- )
+
+M: real sleep
+ millis + >integer sleep-until ;
+
+: interrupt ( thread -- )
+ dup thread-state [
+ dup thread-sleep-entry [ sleep-queue heap-delete ] when*
+ f over set-thread-sleep-entry
+ dup resume
+ ] when drop ;
: (spawn) ( thread -- )
[
- resume [
+ resume-now [
dup set-self
dup register-thread
- init-namespaces
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
] "spawn" suspend 2drop ;
: spawn ( quot name -- thread )
- [
- global [
- "Error in thread " write
- dup thread-id pprint
- " (" write
- dup thread-name pprint ")" print
- "spawned to call " write
- thread-quot short.
- nl
- print-error flush
- ] bind
- ] <thread>
- [ (spawn) ] keep ;
+ <thread> [ (spawn) ] keep ;
: spawn-server ( quot name -- thread )
>r [ [ ] [ ] while ] curry r> spawn ;
[ >r set-namestack set-datastack r> call ] 3curry
"Thread" spawn drop ;
+GENERIC: error-in-thread ( error thread -- )
+
<PRIVATE
: init-threads ( -- )
<dlist> 42 setenv
<min-heap> 43 setenv
initial-thread global
- [ drop f "Initial" [ die ] <thread> ] cache
+ [ drop f "Initial" <thread> ] cache
<box> over set-thread-continuation
- f over set-thread-registered?
+ f over set-thread-state
dup register-thread
set-self ;
-[ self dup thread-error-handler call stop ]
+[ self error-in-thread stop ]
thread-error-hook set-global
PRIVATE>
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $examples
{ $example
+ "USING: kernel prettyprint ;"
"TUPLE: employee number name department ;"
"employee construct-empty ."
"T{ employee f f f f }"
namespaces quotations sequences.private classes continuations
generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ;
-IN: temporary
+IN: tuples.tests
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
100 200 <point> "p" set
! Use eval to sequence parsing explicitly
-"IN: temporary TUPLE: point x y z ;" eval
+"IN: tuples.tests TUPLE: point x y z ;" eval
[ 100 ] [ "p" get point-x ] unit-test
[ 200 ] [ "p" get point-y ] unit-test
-[ f ] [ "p" get "point-z" "temporary" lookup execute ] unit-test
+[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
-300 "p" get "set-point-z" "temporary" lookup execute
+300 "p" get "set-point-z" "tuples.tests" lookup execute
-"IN: temporary TUPLE: point z y ;" eval
+"IN: tuples.tests TUPLE: point z y ;" eval
[ "p" get point-x ] must-fail
[ 200 ] [ "p" get point-y ] unit-test
-[ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test
+[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
TUPLE: predicate-test ;
TUPLE: yo-momma ;
-"IN: temporary C: <yo-momma> yo-momma" eval
+"IN: tuples.tests C: <yo-momma> yo-momma" eval
[ f ] [ \ <yo-momma> generic? ] unit-test
SYMBOL: not-a-tuple-class
[
- "IN: temporary C: <not-a-tuple-class> not-a-tuple-class"
+ "IN: tuples.tests C: <not-a-tuple-class> not-a-tuple-class"
eval
] must-fail
[ t ] [
- "not-a-tuple-class" "temporary" lookup symbol?
+ "not-a-tuple-class" "tuples.tests" lookup symbol?
] unit-test
! Missing check
{ set-erg's-reshape-problem-a }
\ erg's-reshape-problem construct ;
-"IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval
+"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
[
- "IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
+ "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with
+
+! Hardcore unit tests
+USE: threads
+
+\ thread "slot-names" word-prop "slot-names" set
+
+[ ] [
+ [
+ \ thread { "xxx" } "slot-names" get append
+ define-tuple-class
+ ] with-compilation-unit
+
+ [ 1337 sleep ] "Test" spawn drop
+
+ [
+ \ thread "slot-names" get
+ define-tuple-class
+ ] with-compilation-unit
+] unit-test
+
+USE: vocabs
+
+\ vocab "slot-names" word-prop "slot-names" set
+
+[ ] [
+ [
+ \ vocab { "xxx" } "slot-names" get append
+ define-tuple-class
+ ] with-compilation-unit
+
+ all-words drop
+
+ [
+ \ vocab "slot-names" get
+ define-tuple-class
+ ] with-compilation-unit
+] unit-test
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
-classes classes.private slots slots.private ;
+classes classes.private slots slots.private compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
append (>tuple) ;
: reshape-tuples ( class newslots -- )
- >r dup [ swap class eq? ] curry instances dup
- rot "slot-names" word-prop r> permutation
- [ reshape-tuple ] curry map become ;
+ >r dup "slot-names" word-prop r> permutation
+ [
+ >r [ swap class eq? ] curry instances dup r>
+ [ reshape-tuple ] curry map
+ become
+ ] 2curry after-compilation ;
: old-slots ( class newslots -- seq )
swap "slots" word-prop 1 tail-slice
over "slot-names" word-prop over = [
2dup forget-slots
2dup reshape-tuples
+ over changed-word
over redefined
] unless
] when 2drop ;
USING: arrays kernel kernel.private math namespaces
sequences sequences.private strings tools.test vectors
continuations random growable classes ;
-IN: temporary
+IN: vectors.tests
[ ] [ 10 [ [ -1000000 <vector> ] ignore-errors ] times ] unit-test
<PRIVATE
-: array>vector ( byte-array capacity -- byte-vector )
+: array>vector ( array length -- vector )
vector construct-boa ; inline
PRIVATE>
{ $var-description "If set to a true value, documentation will be automatically loaded when vocabularies are loaded. This variable is usually on, except when Factor has been bootstrapped without the help system." } ;
HELP: load-source
-{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
-{ $description "Loads a vocabulary's source code from the specified vocabulary root." } ;
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "Loads a vocabulary's source code." } ;
HELP: load-docs
-{ $values { "root" "a pathname string" } { "name" "a vocabulary name" } }
-{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation from the specified vocabulary root." } ;
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "If " { $link load-help? } " is on, loads a vocabulary's documentation." } ;
HELP: reload
{ $values { "name" "a vocabulary name" } }
! Unit tests for vocabs.loader vocabulary
-IN: temporary
+IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs tuples definitions
MAIN: hello
-IN: temporary
+IN: vocabs.loader.tests
[ { 3 3 3 } ] [
"vocabs.loader.test.2" run
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences io.files kernel assocs words vocabs
definitions parser continuations inspector debugger io io.styles
-io.streams.lines hashtables sorting prettyprint source-files
+hashtables sorting prettyprint source-files
arrays combinators strings system math.parser compiler.errors
-splitting ;
+splitting init ;
IN: vocabs.loader
SYMBOL: vocab-roots
: source-wasn't-loaded f swap set-vocab-source-loaded? ;
-: load-source ( vocab-link -- )
+: load-source ( vocab -- )
[ source-wasn't-loaded ] keep
[ vocab-source-path bootstrap-file ] keep
source-was-loaded ;
: docs-weren't-loaded f swap set-vocab-docs-loaded? ;
-: load-docs ( vocab-link -- )
+: load-docs ( vocab -- )
load-help? get [
[ docs-weren't-loaded ] keep
[ vocab-docs-path ?run-file ] keep
[ load-error. nl ] each ;
SYMBOL: blacklist
+SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
+ V{ } clone failures set
[
[ require ]
- [ >r vocab-name r> 2array blacklist get push ]
+ [ swap vocab-name failures get set-at ]
recover
] each
- blacklist get
+ failures get
] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- )
: refresh ( prefix -- ) to-refresh do-refresh ;
-: refresh-all ( -- ) "" refresh ;
+SYMBOL: sources-changed?
+
+[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
+
+: refresh-all ( -- )
+ "" refresh f sources-changed? set-global ;
GENERIC: (load-vocab) ( name -- vocab )
-!
+
+: add-to-blacklist ( error vocab -- )
+ vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
+
M: vocab (load-vocab)
- dup vocab-root [
- dup vocab-source-loaded? [ dup load-source ] unless
- dup vocab-docs-loaded? [ dup load-docs ] unless
- ] when ;
+ [
+ dup vocab-root [
+ dup vocab-source-loaded? [ dup load-source ] unless
+ dup vocab-docs-loaded? [ dup load-docs ] unless
+ ] when
+ ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
-TUPLE: blacklisted-vocab name ;
-
-: blacklisted-vocab ( name -- * )
- \ blacklisted-vocab construct-boa throw ;
-
-M: blacklisted-vocab error.
- "This vocabulary depends on the " write
- blacklisted-vocab-name write
- " vocabulary which failed to load" print ;
-
[
- dup vocab-name blacklist get key? [
- vocab-name blacklisted-vocab
+ dup vocab-name blacklist get at* [
+ rethrow
] [
- [
- dup vocab [ ] [ ] ?if (load-vocab)
- ] with-compiler-errors
+ drop
+ [ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
+
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )
! Unit tests for vocabs vocabulary
USING: vocabs tools.test ;
-IN: temporary
+IN: vocabs.tests
[ f ] [ "kernel" vocab-main ] unit-test
M: f set-vocab-docs-loaded? 2drop ;
+M: f vocab-help ;
+
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
-USING: definitions help.markup help.syntax kernel
-kernel.private parser words.private vocabs classes quotations
+USING: definitions help.markup help.syntax kernel parser
+kernel.private words.private vocabs classes quotations
strings effects compiler.units ;
IN: words
ARTICLE: "declarations" "Declarations"
"Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word."
$nl
-"The first declaration specifies the time when a word runs. It affects both interpreted and compiled definitions."
+"The first declaration specifies the time when a word runs. It affects both the non-optimizing and optimizing compilers:"
{ $subsection POSTPONE: parsing }
-"The remaining declarations only affect compiled definitions. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
+"The remaining declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." }
{ $subsection POSTPONE: inline }
{ $subsection POSTPONE: foldable }
{ $values { "word" word } }
{ $description "Executes a word." }
{ $examples
- { $example ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
+ { $example "USING: kernel io words ;" ": twice dup execute execute ;\n: hello \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
} ;
HELP: word-props ( word -- props )
HELP: constructor-word
{ $values { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
-{ $examples { $example "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
+{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
HELP: forget-word
{ $values { "word" word } }
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
-vocabs continuations tuples compiler.units ;
-IN: temporary
+vocabs continuations tuples compiler.units io.streams.string ;
+IN: words.tests
[ 4 ] [
[
- "poo" "temporary" create [ 2 2 + ] define
+ "poo" "words.tests" create [ 2 2 + ] define
] with-compilation-unit
- "poo" "temporary" lookup execute
+ "poo" "words.tests" lookup execute
] unit-test
[ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test
! See if redefining a generic as a colon def clears some
! word props.
GENERIC: testing
-"IN: temporary : testing ;" eval
+"IN: words.tests : testing ;" eval
[ f ] [ \ testing generic? ] unit-test
DEFER: x
[ x ] [ undefined? ] must-fail-with
-[ ] [ "no-loc" "temporary" create drop ] unit-test
-[ f ] [ "no-loc" "temporary" lookup where ] unit-test
+[ ] [ "no-loc" "words.tests" create drop ] unit-test
+[ f ] [ "no-loc" "words.tests" lookup where ] unit-test
-[ ] [ "IN: temporary : no-loc-2 ;" eval ] unit-test
-[ f ] [ "no-loc-2" "temporary" lookup where ] unit-test
+[ ] [ "IN: words.tests : no-loc-2 ;" eval ] unit-test
+[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
-[ ] [ "IN: temporary : test-last ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
[ "test-last" ] [ word word-name ] unit-test
! regression
[ { + } ] [ \ quot-uses-b uses ] unit-test
-[ "IN: temporary : undef-test ; << undef-test >>" eval ]
+"undef-test" "words.tests" lookup [
+ [ forget ] with-compilation-unit
+] when*
+
+[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
[ [ undefined? ] is? ] must-fail-with
[ ] [
- "IN: temporary GENERIC: symbol-generic" eval
+ "IN: words.tests GENERIC: symbol-generic" eval
] unit-test
[ ] [
- "IN: temporary SYMBOL: symbol-generic" eval
+ "IN: words.tests SYMBOL: symbol-generic" eval
] unit-test
-[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
-[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
+[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
+[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
[ ] [
- "IN: temporary GENERIC: symbol-generic" eval
+ "IN: words.tests GENERIC: symbol-generic" <string-reader>
+ "symbol-generic-test" parse-stream drop
] unit-test
[ ] [
- "IN: temporary TUPLE: symbol-generic ;" eval
+ "IN: words.tests TUPLE: symbol-generic ;" <string-reader>
+ "symbol-generic-test" parse-stream drop
] unit-test
-[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
-[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
+[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
+[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! Regressions
-[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test
-[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
-[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
-[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
-
-[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test
-[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
-[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
-[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test
+[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
+[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
+
+[ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test
+[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test
+[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method" word-prop ] [ t ] }
+ { [ dup "method-def" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
dup compiled-unxref
compiled-crossref get delete-at ;
+SYMBOL: +inlined+
+SYMBOL: +called+
+
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
+: compiled-usages ( words -- seq )
+ [ [ dup ] H{ } map>assoc dup ] keep [
+ compiled-usage [ nip +inlined+ eq? ] assoc-subset update
+ ] with each keys ;
+
M: word redefined* ( word -- )
{ "inferred-effect" "no-effect" } reset-props ;
+++ /dev/null
-#!/bin/sh
-
-echo $1
-mkdir -p "`dirname \"$2\"`"
-cp "$1" "$2"
--- /dev/null
+IN: alarms\r
+USING: help.markup help.syntax calendar quotations ;\r
+\r
+HELP: alarm\r
+{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;\r
+\r
+HELP: add-alarm\r
+{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }\r
+{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;\r
+\r
+HELP: later\r
+{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }\r
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ;\r
+\r
+HELP: cancel-alarm\r
+{ $values { "alarm" alarm } }\r
+{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;\r
+\r
+ARTICLE: "alarms" "Alarms"\r
+"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."\r
+{ $subsection alarm }\r
+{ $subsection add-alarm }\r
+{ $subsection later }\r
+{ $subsection cancel-alarm }\r
+"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;\r
+\r
+ABOUT: "alarms"\r
--- /dev/null
+IN: alarms.tests\r
+USING: alarms alarms.private kernel calendar sequences\r
+tools.test threads concurrency.count-downs ;\r
+\r
+[ ] [\r
+ 1 <count-down>\r
+ { f } clone 2dup\r
+ [ first cancel-alarm count-down ] 2curry 1 seconds later\r
+ swap set-first\r
+ await\r
+] unit-test\r
+\r
+[ ] [\r
+ [\r
+ [ resume ] curry instant later drop\r
+ ] "test" suspend drop\r
+] unit-test\r
+\r
+\ alarm-thread-loop must-infer\r
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators concurrency.messaging
-threads generic init kernel math namespaces sequences ;
+USING: arrays calendar combinators generic init kernel math
+namespaces sequences heaps boxes threads debugger quotations
+assocs ;
IN: alarms
-TUPLE: alarm time quot ;
-
-C: <alarm> alarm
+TUPLE: alarm quot time interval entry ;
<PRIVATE
-! for now a V{ }, eventually a min-heap to store alarms
SYMBOL: alarms
-SYMBOL: alarm-receiver
-SYMBOL: alarm-looper
-
-: add-alarm ( alarm -- )
- alarms get-global push ;
-
-: remove-alarm ( alarm -- )
- alarms get-global delete ;
-
-: handle-alarm ( alarm -- )
- dup delegate {
- { "register" [ add-alarm ] }
- { "unregister" [ remove-alarm ] }
- } case ;
-
-: expired-alarms ( -- seq )
- now alarms get-global
- [ alarm-time <=> 0 > ] with subset ;
+SYMBOL: alarm-thread
-: unexpired-alarms ( -- seq )
- now alarms get-global
- [ alarm-time <=> 0 <= ] with subset ;
+: notify-alarm-thread ( -- )
+ alarm-thread get-global interrupt ;
-: call-alarm ( alarm -- )
- alarm-quot "Alarm invocation" spawn drop ;
+: check-alarm
+ dup duration? over not or [ "Not a duration" throw ] unless
+ over timestamp? [ "Not a timestamp" throw ] unless
+ pick callable? [ "Not a quotation" throw ] unless ; inline
-: do-alarms ( -- )
- expired-alarms [ call-alarm ] each
- unexpired-alarms alarms set-global ;
+: <alarm> ( quot time frequency -- alarm )
+ check-alarm <box> alarm construct-boa ;
-: alarm-receive-loop ( -- )
- receive dup alarm? [ handle-alarm ] [ drop ] if
- alarm-receive-loop ;
+: register-alarm ( alarm -- )
+ dup dup alarm-time alarms get-global heap-push*
+ swap alarm-entry >box
+ notify-alarm-thread ;
-: start-alarm-receiver ( -- )
- [
- alarm-receive-loop
- ] "Alarm receiver" spawn alarm-receiver set-global ;
+: alarm-expired? ( alarm now -- ? )
+ >r alarm-time r> before=? ;
-: alarm-loop ( -- )
- alarms get-global empty? [
- do-alarms
- ] unless 100 sleep alarm-loop ;
+: reschedule-alarm ( alarm -- )
+ dup alarm-time over alarm-interval time+
+ over set-alarm-time
+ register-alarm ;
-: start-alarm-looper ( -- )
+: call-alarm ( alarm -- )
+ dup alarm-entry box> drop
+ dup alarm-quot "Alarm execution" spawn drop
+ dup alarm-interval [ reschedule-alarm ] [ drop ] if ;
+
+: (trigger-alarms) ( alarms now -- )
+ over heap-empty? [
+ 2drop
+ ] [
+ over heap-peek drop over alarm-expired? [
+ over heap-pop drop call-alarm (trigger-alarms)
+ ] [
+ 2drop
+ ] if
+ ] if ;
+
+: trigger-alarms ( alarms -- )
+ now (trigger-alarms) ;
+
+: next-alarm ( alarms -- timestamp/f )
+ dup heap-empty?
+ [ drop f ] [ heap-peek drop alarm-time ] if ;
+
+: alarm-thread-loop ( -- )
+ alarms get-global
+ dup next-alarm sleep-until
+ trigger-alarms ;
+
+: cancel-alarms ( alarms -- )
[
- alarm-loop
- ] "Alarm looper" spawn alarm-looper set-global ;
+ heap-pop-all [ nip alarm-entry box> drop ] assoc-each
+ ] when* ;
-: send-alarm ( str alarm -- )
- over set-delegate
- alarm-receiver get-global send ;
+: init-alarms ( -- )
+ alarms global [ cancel-alarms <min-heap> ] change-at
+ [ alarm-thread-loop t ] "Alarms" spawn-server
+ alarm-thread set-global ;
-: start-alarm-daemon ( -- )
- alarms get-global [ V{ } clone alarms set-global ] unless
- start-alarm-looper
- start-alarm-receiver ;
+[ init-alarms ] "alarms" add-init-hook
-[ start-alarm-daemon ] "alarms" add-init-hook
PRIVATE>
-: register-alarm ( alarm -- )
- "register" send-alarm ;
+: add-alarm ( quot time frequency -- alarm )
+ <alarm> [ register-alarm ] keep ;
-: unregister-alarm ( alarm -- )
- "unregister" send-alarm ;
+: later ( quot dt -- alarm )
+ from-now f add-alarm ;
-: change-alarm ( alarm-old alarm-new -- )
- "register" send-alarm
- "unregister" send-alarm ;
+: every ( quot dt -- alarm )
+ [ from-now ] keep add-alarm ;
-! Example:
-! 5 seconds from-now [ "hi" print flush ] <alarm> register-alarm
+: cancel-alarm ( alarm -- )
+ alarm-entry [ alarms get-global heap-delete ] if-box? ;
-IN: temporary
+IN: ascii.tests
USING: ascii tools.test sequences kernel math ;
[ t ] [ CHAR: a letter? ] unit-test
+++ /dev/null
-USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
-IN: temporary
-
-[
-T{
- assoc-heap
- f
- H{ { 2 1 } }
- T{ min-heap T{ heap f V{ { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push ] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-}
-] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push 0 1 pick heap-push ] unit-test
-
-[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ]
-[
- H{ } clone <assoc-min-heap>
- 1 2 pick heap-push 0 1 pick heap-push
- dup heap-pop 2drop dup heap-pop 2drop
-] unit-test
-
-
-[ 0 1 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
-} heap-pop
-] unit-test
-
-[ 1 2 ] [
-T{
- assoc-heap
- f
- H{ { 1 0 } { 2 1 } }
- T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
-} heap-pop
-] unit-test
-
-[
-T{
- assoc-heap
- f
- H{ { 1 2 } { 3 4 } }
- T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
-}
-] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test
+++ /dev/null
-USING: assocs heaps kernel sequences ;
-IN: assoc-heaps
-
-TUPLE: assoc-heap assoc heap ;
-
-INSTANCE: assoc-heap assoc
-INSTANCE: assoc-heap priority-queue
-
-C: <assoc-heap> assoc-heap
-
-: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
-: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
-
-M: assoc-heap at* ( key assoc-heap -- value ? )
- assoc-heap-assoc at* ;
-
-M: assoc-heap assoc-size ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-TUPLE: assoc-heap-key-exists ;
-
-: check-key-exists ( key assoc-heap -- )
- assoc-heap-assoc key?
- [ \ assoc-heap-key-exists construct-empty throw ] when ;
-
-M: assoc-heap set-at ( value key assoc-heap -- )
- [ check-key-exists ] 2keep
- [ assoc-heap-assoc set-at ] 3keep
- assoc-heap-heap swapd heap-push ;
-
-M: assoc-heap heap-empty? ( assoc-heap -- ? )
- assoc-heap-assoc assoc-empty? ;
-
-M: assoc-heap heap-length ( assoc-heap -- n )
- assoc-heap-assoc assoc-size ;
-
-M: assoc-heap heap-peek ( assoc-heap -- value key )
- assoc-heap-heap heap-peek ;
-
-M: assoc-heap heap-push ( value key assoc-heap -- )
- set-at ;
-
-M: assoc-heap heap-pop ( assoc-heap -- value key )
- dup assoc-heap-heap heap-pop swap
- rot dupd assoc-heap-assoc delete-at ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Priority search queues
: at-default ( key assoc -- value/key )
dupd at [ nip ] when* ;
+: replace-at ( assoc value key -- assoc )
+ >r >r dup r> 1vector r> rot set-at ;
+
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
-: peek-at* ( key assoc -- obj ? )
- at* dup [ >r peek r> ] when ;
+: peek-at* ( assoc key -- obj ? )
+ swap at* dup [ >r peek r> ] when ;
-: peek-at ( key assoc -- obj )
+: peek-at ( assoc key -- obj )
peek-at* drop ;
: >multi-assoc ( assoc -- new-assoc )
] with-row
[
[
- swap [ ($vocab-link) ] with-cell
+ swap [ dup ($vocab-link) ] with-cell
first2 pprint-cell pprint-cell
] with-row
] assoc-each
--- /dev/null
+USING: io.crc32 io.encodings.ascii io.files kernel math ;
+IN: benchmark.crc32
+
+: crc32-primes-list ( -- )
+ 10 [
+ "extra/math/primes/list/list.factor" resource-path
+ ascii file-contents crc32 drop
+ ] times ;
+
+MAIN: crc32-primes-list
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences
-sequences.private benchmark.reverse-complement hints
+sequences.private benchmark.reverse-complement hints io.encodings.ascii
byte-arrays float-arrays ;
IN: benchmark.fasta
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
-:: select-random | seed chars floats |
+:: select-random ( seed chars floats -- elt )
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
-:: split-lines | n quot |
+:: split-lines ( n quot -- )
n line-length /mod
[ [ line-length quot call ] times ] dip
dup zero? [ drop ] quot if ; inline
write-description
[ make-random-fasta ] 2curry split-lines ; inline
-:: make-repeat-fasta | k len alu |
+:: make-repeat-fasta ( k len alu -- )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +
n [ ]
seed [ initial-seed ] |
- out [
+ out ascii [
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
initial-seed
--- /dev/null
+IN: benchmark.fib6\r
+USING: math kernel alien ;\r
+\r
+: fib\r
+ "int" { "int" } "cdecl" [\r
+ dup 1 <= [ drop 1 ] [\r
+ 1- dup fib swap 1- fib +\r
+ ] if\r
+ ] alien-callback\r
+ "int" { "int" } "cdecl" alien-indirect ;\r
+\r
+: fib-main 25 fib drop ;\r
+\r
+MAIN: fib-main\r
-USING: kernel io io.files splitting strings
+USING: kernel io io.files splitting strings io.encodings.ascii
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting unicode.case ;
: knucleotide ( -- )
"extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
- [ read-input ] with-file-reader
+ ascii [ read-input ] with-file-reader
process-input ;
MAIN: knucleotide
IN: benchmark.mandel
-USING: arrays io kernel math namespaces sequences strings sbufs
-math.functions math.parser io.files colors.hsv ;
+USING: arrays io kernel math namespaces sequences
+byte-arrays byte-vectors math.functions math.parser io.files
+colors.hsv io.encodings.binary ;
: max-color 360 ; inline
: zoom-fact 0.8 ; inline
: ppm-header ( w h -- )
"P6\n" % swap # " " % # "\n255\n" % ;
-: sbuf-size width height * 3 * 100 + ;
+: buf-size width height * 3 * 100 + ;
-: mandel ( -- string )
+: mandel ( -- data )
[
- sbuf-size <sbuf> building set
+ buf-size <byte-vector> building set
width height ppm-header
nb-iter max-color min <color-map> cols set
render
- building get >string
+ building get >byte-array
] with-scope ;
: mandel-main ( -- )
- "mandel.ppm" resource-path
- [ mandel write ] with-file-writer ;
+ mandel "mandel.ppm" temp-file binary set-file-contents ;
MAIN: mandel-main
--- /dev/null
+USING: crypto.md5 io.files kernel ;
+IN: benchmark.md5
+
+: md5-primes-list ( -- )
+ "extra/math/primes/list/list.factor" resource-path file>md5 drop ;
+
+MAIN: md5-primes-list
--- /dev/null
+USING: io.files io.encodings.ascii random math.parser io math ;
+IN: benchmark.random
+
+: random-numbers-path "random-numbers.txt" temp-file ;
+
+: write-random-numbers ( n -- )
+ random-numbers-path ascii [
+ [ 200 random 100 - number>string print ] times
+ ] with-file-writer ;
+
+: random-main ( -- )
+ 1000000 write-random-numbers ;
+
+MAIN: random-main
USING: float-arrays compiler generic io io.files kernel math
math.functions math.vectors math.parser namespaces sequences
-sequences.private words ;
+sequences.private words io.encodings.binary ;
IN: benchmark.raytracer
! parameters
levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
size size pgm-header
[ [ oversampling sq / pgm-pixel ] each ] each
- ] "" make ;
+ ] B{ } make ;
: raytracer-main
- "raytracer.pnm" resource-path
- [ run write ] with-file-writer ;
+ run "raytracer.pnm" temp-file binary set-file-contents ;
MAIN: raytracer-main
--- /dev/null
+IN: benchmark.reverse-complement.tests\r
+USING: tools.test benchmark.reverse-complement crypto.md5\r
+io.files kernel ;\r
+\r
+[ "c071aa7e007a9770b2fb4304f55a17e5" ] [\r
+ "extra/benchmark/reverse-complement/reverse-complement-test-in.txt"\r
+ "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
+ [ resource-path ] 2apply\r
+ reverse-complement\r
+\r
+ "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
+ resource-path file>md5str\r
+] unit-test\r
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
-hints unicode.case continuations ;
+hints unicode.case continuations io.encodings.latin1 ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
- <file-writer> [
- swap <file-reader> [
+ latin1 <file-writer> [
+ swap latin1 <file-reader> [
swap <duplex-stream> [
500000 <vector> (reverse-complement)
] with-stream
] with-disposal ;
: reverse-complement-in
- "extra/benchmark/reverse-complement/reverse-complement-in.txt"
- resource-path ;
+ "reverse-complement-in.txt" temp-file ;
: reverse-complement-out
- "extra/benchmark/reverse-complement/reverse-complement-out.txt"
- resource-path ;
+ "reverse-complement-out.txt" temp-file ;
: reverse-complement-main ( -- )
reverse-complement-in
receive 2dup swap send done eq? [ tunnel ] unless ;
: create-ring ( processes -- target )
- self swap [ [ tunnel ] "Tunnel" spawn nip ] times ;
+ self swap [
+ dup [ tunnel ] curry "Tunnel" spawn nip
+ ] times ;
: send-messages ( messages target -- )
dupd [ send ] curry each [ receive drop ] times ;
-USING: io.sockets io.server io kernel math threads\r
-debugger tools.time prettyprint concurrency.combinators ;\r
-IN: benchmark.sockets\r
-\r
-: simple-server ( -- )\r
- 7777 local-server "benchmark.sockets" [\r
- read1 CHAR: x = [\r
- stop-server\r
- ] [\r
- 20 [ read1 write1 flush ] times\r
- ] if\r
- ] with-server ;\r
-\r
-: simple-client ( -- )\r
- "localhost" 7777 <inet> <client> [\r
- CHAR: b write1 flush\r
- 20 [ CHAR: a dup write1 flush read1 assert= ] times\r
- ] with-stream ;\r
-\r
-: stop-server ( -- )\r
- "localhost" 7777 <inet> <client> [\r
- CHAR: x write1\r
- ] with-stream ;\r
-\r
-: clients ( n -- )\r
- dup pprint " clients: " write [\r
- [ simple-server ] in-thread\r
- yield yield\r
- [ drop simple-client ] parallel-each\r
- stop-server\r
- yield yield\r
- ] time ;\r
-\r
-: socket-benchmarks\r
- 10 clients\r
- 20 clients\r
- 40 clients\r
- 80 clients\r
- 160 clients\r
- 320 clients\r
- 640 clients ;\r
-\r
-MAIN: socket-benchmarks\r
+USING: io.sockets io kernel math threads io.encodings.ascii
+debugger tools.time prettyprint concurrency.count-downs
+namespaces arrays continuations ;
+IN: benchmark.sockets
+
+SYMBOL: counter
+
+: number-of-requests 1 ;
+
+: server-addr "127.0.0.1" 7777 <inet4> ;
+
+: server-loop ( server -- )
+ dup accept [
+ [
+ read1 CHAR: x = [
+ "server" get dispose
+ ] [
+ number-of-requests
+ [ read1 write1 flush ] times
+ counter get count-down
+ ] if
+ ] with-stream
+ ] curry "Client handler" spawn drop server-loop ;
+
+: simple-server ( -- )
+ [
+ server-addr ascii <server> dup "server" set [
+ server-loop
+ ] with-disposal
+ ] ignore-errors ;
+
+: simple-client ( -- )
+ server-addr ascii <client> [
+ CHAR: b write1 flush
+ number-of-requests
+ [ CHAR: a dup write1 flush read1 assert= ] times
+ counter get count-down
+ ] with-stream ;
+
+: stop-server ( -- )
+ server-addr ascii <client> [
+ CHAR: x write1
+ ] with-stream ;
+
+: clients ( n -- )
+ dup pprint " clients: " write [
+ dup 2 * <count-down> counter set
+ [ simple-server ] "Simple server" spawn drop
+ yield yield
+ [ [ simple-client ] "Simple client" spawn drop ] times
+ counter get await
+ stop-server
+ yield yield
+ ] time ;
+
+: socket-benchmarks ;
+
+MAIN: socket-benchmarks
-USING: kernel sequences sorting random ;
+USING: kernel sequences sorting benchmark.random math.parser
+io.files io.encodings.ascii ;
IN: benchmark.sort
: sort-benchmark
- 100000 [ drop 100000 random ] map natural-sort drop ;
+ random-numbers-path
+ ascii file-lines [ string>number ] map
+ natural-sort drop ;
MAIN: sort-benchmark
-USING: io io.files math math.parser kernel prettyprint ;
+USING: io io.files math math.parser kernel prettyprint
+benchmark.random io.encodings.ascii ;
IN: benchmark.sum-file
: sum-file-loop ( n -- n' )
readln [ string>number + sum-file-loop ] when* ;
: sum-file ( file -- )
- [ 0 sum-file-loop ] with-file-reader . ;
+ ascii [ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
- home "sum-file-in.txt" path+ sum-file ;
+ random-numbers-path sum-file ;
MAIN: sum-file-main
USING: tools.test bitfields kernel ;
+IN: bitfields.tests
SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ;
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.upload
USING: http.client crypto.md5 splitting assocs kernel io.files
-bootstrap.image sequences io namespaces io.launcher math ;
+bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
-: destination "slava@factorcode.org:www/images/latest/" ;
+SYMBOL: upload-images-destination
+
+: destination ( -- dest )
+ upload-images-destination get
+ "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
+ or ;
+
+: checksums "checksums.txt" temp-file ;
: boot-image-names images [ boot-image-name ] map ;
: compute-checksums ( -- )
- "checksums.txt" [
+ checksums ascii [
boot-image-names [ dup write bl file>md5str print ] each
] with-file-writer ;
: upload-images ( -- )
[
- "scp" , boot-image-names % "checksums.txt" , destination ,
+ "scp" ,
+ boot-image-names %
+ "temp/checksums.txt" , destination ,
] { } make try-process ;
: new-images ( -- )
- make-images compute-checksums upload-images ;
+ "" resource-path
+ [ make-images compute-checksums upload-images ]
+ with-directory ;
MAIN: new-images
"ui.cocoa" vocab [
"ui.cocoa.tools" require
] when
+
+ "ui.tools.walker" require
] when
USING: kernel namespaces sequences splitting system combinators continuations
parser io io.files io.launcher io.sockets prettyprint threads
bootstrap.image benchmark vars bake smtp builder.util accessors
- builder.benchmark ;
+ io.encodings.utf8
+ calendar
+ builder.common
+ builder.benchmark
+ builder.release ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOL: builds-dir
-
-: builds ( -- path )
- builds-dir get
- home "/builds" append
- or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: prepare-build-machine ( -- )
builds make-directory
builds cd
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-VAR: stamp
-
: enter-build-dir ( -- )
datestamp >stamp
builds cd
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
- { "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
+ { "git" "show" } utf8 <process-stream>
+ [ readln ] with-stream " " split second ;
-: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
+: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
-: make-clean ( -- desc ) { "make" "clean" } ;
+: do-make-clean ( -- ) { "make" "clean" } try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
-
: make-vm ( -- desc )
- <process*>
- { "make" target } to-strings >>arguments
- "../compile-log" >>stdout
- +stdout+ >>stderr
- >desc ;
+ <process>
+ { "make" } >>command
+ "../compile-log" >>stdout
+ +stdout+ >>stderr ;
+
+: do-make-vm ( -- )
+ make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
- "../../factor/" my-boot-image-name append
- "../" my-boot-image-name append
- copy-file
-
- "../../factor/" my-boot-image-name append
- my-boot-image-name
- copy-file ;
+ builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
+ builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: factor-binary ( -- name )
- os
- { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] }
- { "winnt" [ "./factor-nt.exe" ] }
- [ drop "./factor" ] }
- case ;
-
: bootstrap-cmd ( -- cmd )
- { factor-binary { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
+ { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: bootstrap ( -- desc )
- <process*>
- bootstrap-cmd >>arguments
+ <process>
+ bootstrap-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
- 20 minutes>ms >>timeout
- >desc ;
+ 20 minutes >>timeout ;
+
+: do-bootstrap ( -- )
+ bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
: builder-test-cmd ( -- cmd )
- { factor-binary "-run=builder.test" } to-strings ;
+ { "./factor" "-run=builder.test" } to-strings ;
: builder-test ( -- desc )
- <process*>
- builder-test-cmd >>arguments
+ <process>
+ builder-test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
- 45 minutes>ms >>timeout
- >desc ;
+ 45 minutes >>timeout ;
+
+: do-builder-test ( -- )
+ builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
enter-build-dir
- "report" [
-
- "Build machine: " write host-name print
- "CPU: " write cpu print
- "OS: " write os print
- "Build directory: " write cwd print nl
-
- git-clone [ "git clone failed" print ] run-or-bail
-
- "factor" cd
-
- record-git-id
-
- make-clean run-process drop
+ "report" utf8
+ [
+ "Build machine: " write host-name print
+ "CPU: " write cpu print
+ "OS: " write os print
+ "Build directory: " write cwd print
- make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
+ git-clone [ "git clone failed" print ] run-or-bail
- copy-image
+ "factor"
+ [
+ record-git-id
+ do-make-clean
+ do-make-vm
+ copy-image
+ do-bootstrap
+ do-builder-test
+ ]
+ with-directory
- bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
+ "test-log" delete-file
- builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail
+ "git id: " write "git-id" eval-file print nl
- "../test-log" delete-file
+ "Boot time: " write "boot-time" eval-file milli-seconds>time print
+ "Load time: " write "load-time" eval-file milli-seconds>time print
+ "Test time: " write "test-time" eval-file milli-seconds>time print nl
- "Boot time: " write "../boot-time" eval-file milli-seconds>time print
- "Load time: " write "../load-time" eval-file milli-seconds>time print
- "Test time: " write "../test-time" eval-file milli-seconds>time print nl
+ "Did not pass load-everything: " print "load-everything-vocabs" cat
+ "Did not pass test-all: " print "test-all-vocabs" cat
+ "help-lint results:" print "help-lint" cat
- "Did not pass load-everything: " print "../load-everything-vocabs" cat
- "Did not pass test-all: " print "../test-all-vocabs" cat
+ "Benchmarks: " print "benchmarks" eval-file benchmarks.
- "Benchmarks: " print
- "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
+ nl
- nl
-
- show-benchmark-deltas
+ show-benchmark-deltas
- "../benchmarks" "../../benchmarks" copy-file
+ "benchmarks" ".." copy-file-into
- ] with-file-writer
+ maybe-release
+ ]
+ with-file-writer
build-status on ;
builder-from get >>from
builder-recipients get >>to
subject >>subject
- "../report" file>string >>body
- send ;
+ "./report" file>string >>body
+ send-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ "bzip2" my-boot-image-name } to-strings run-process drop ;
: build ( -- )
- [ (build) ] [ drop ] recover
+ [ (build) ] failsafe
+ builds cd stamp> cd
[ send-builder-email ] [ drop "not sending mail" . ] recover
- ".." cd { "rm" "-rf" "factor" } run-process drop
- [ compress-image ] [ drop ] recover ;
+ { "rm" "-rf" "factor" } run-process drop
+ [ compress-image ] failsafe ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ build ]
when
]
- [ drop ]
- recover
- 5 minutes>ms sleep
+ failsafe
+ 5 minutes sleep
build-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+
+USING: kernel namespaces io.files sequences vars ;
+
+IN: builder.common
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builds-dir
+
+: builds ( -- path )
+ builds-dir get
+ home "/builds" append
+ or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: stamp
+
--- /dev/null
+
+USING: kernel system namespaces sequences splitting combinators
+ io.files io.launcher
+ bake combinators.cleave builder.common builder.util ;
+
+IN: builder.release
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: releases ( -- path )
+ builds "releases" path+
+ dup exists? not
+ [ dup make-directory ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: common-files ( -- seq )
+ {
+ "boot.x86.32.image"
+ "boot.x86.64.image"
+ "boot.macosx-ppc.image"
+ "vm"
+ "temp"
+ "logs"
+ ".git"
+ ".gitignore"
+ "Makefile"
+ "cp_dir"
+ "unmaintained"
+ "misc/target"
+ "misc/wordsize"
+ "misc/wordsize.c"
+ "misc/macos-release.sh"
+ "misc/source-release.sh"
+ "misc/windows-release.sh"
+ "misc/version.sh"
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cpu- ( -- cpu ) cpu "." split "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: extension ( -- extension )
+ os
+ {
+ { "linux" [ ".tar.gz" ] }
+ { "winnt" [ ".zip" ] }
+ { "macosx" [ ".dmg" ] }
+ }
+ case ;
+
+: archive-name ( -- string ) base-name extension append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
+
+: macosx-archive-cmd ( -- cmd )
+ { "hdiutil" "create"
+ "-srcfolder" "factor"
+ "-fs" "HFS+"
+ "-volname" "factor"
+ archive-name } ;
+
+: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: archive-cmd ( -- cmd )
+ {
+ { [ windows? ] [ windows-archive-cmd ] }
+ { [ macosx? ] [ macosx-archive-cmd ] }
+ { [ unix? ] [ unix-archive-cmd ] }
+ }
+ cond ;
+
+: make-archive ( -- ) archive-cmd to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remove-common-files ( -- )
+ { "rm" "-rf" common-files } to-strings try-process ;
+
+: remove-factor-app ( -- )
+ macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
+
+: release ( -- )
+ "factor"
+ [
+ remove-factor-app
+ remove-common-files
+ ]
+ with-directory
+ make-archive
+ archive-name releases move-file-into ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: release? ( -- ? )
+ {
+ "./load-everything-vocabs"
+ "./test-all-vocabs"
+ }
+ [ eval-file empty? ]
+ all? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: maybe-release ( -- ) release? [ release ] when ;
\ No newline at end of file
prettyprint
tools.browser
tools.test
+ io.encodings.utf8
+ combinators.cleave
+ help.lint
bootstrap.stage2 benchmark builder.util ;
IN: builder.test
: do-load ( -- )
- try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
+ try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
+
+! : do-tests ( -- )
+! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
: do-tests ( -- )
- run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ;
+ run-all-tests
+ "../test-all-vocabs" utf8
+ [
+ [ keys . ]
+ [ test-failures. ]
+ bi
+ ]
+ with-file-writer ;
+
+: do-help-lint ( -- )
+ "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
-: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ;
+: do-benchmarks ( -- )
+ run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
: do-all ( -- )
- bootstrap-time get "../boot-time" [ . ] with-file-writer
- [ do-load ] runtime "../load-time" [ . ] with-file-writer
- [ do-tests ] runtime "../test-time" [ . ] with-file-writer
+ bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
+ [ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer
+ [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
+ do-help-lint
do-benchmarks ;
MAIN: do-all
\ No newline at end of file
io io.files io.launcher io.sockets
math math.parser
combinators sequences splitting quotations arrays strings tools.time
- parser-combinators new-slots accessors assocs.lib
- combinators.cleave bake calendar ;
+ sequences.deep new-slots accessors assocs.lib
+ io.encodings.utf8
+ combinators.cleave bake calendar calendar.format ;
IN: builder.util
: minutes>ms ( min -- ms ) 60 * 1000 * ;
-: file>string ( file -- string ) [ stdio get contents ] with-file-reader ;
+: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: process* arguments stdin stdout stderr timeout ;
+! TUPLE: process* arguments stdin stdout stderr timeout ;
-: <process*> process* construct-empty ;
+
! : <process*> process* construct-empty ;
-: >desc ( process* -- desc )
- H{ } clone
- over arguments>> [ +arguments+ swap put-at ] when*
- over stdin>> [ +stdin+ swap put-at ] when*
- over stdout>> [ +stdout+ swap put-at ] when*
- over stderr>> [ +stderr+ swap put-at ] when*
- over timeout>> [ +timeout+ swap put-at ] when*
- nip ;
+! : >desc ( process* -- desc )
+! H{ } clone
+! over arguments>> [ +arguments+ swap put-at ] when*
+! over stdin>> [ +stdin+ swap put-at ] when*
+! over stdout>> [ +stdout+ swap put-at ] when*
+! over stderr>> [ +stderr+ swap put-at ] when*
+! over timeout>> [ +timeout+ swap put-at ] when*
+! nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: milli-seconds>time ( n -- string )
1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
-: eval-file ( file -- obj ) file-contents eval ;
+: eval-file ( file -- obj ) utf8 file-contents eval ;
-: cat ( file -- ) file-contents print ;
+: cat ( file -- ) utf8 file-contents print ;
: run-or-bail ( desc quot -- )
[ [ try-process ] curry ]
if ;
: cat-n ( file n -- )
- [ file-lines ] [ ] bi*
+ [ utf8 file-lines ] [ ] bi*
maybe-tail*
- [ print ] each ;
\ No newline at end of file
+ [ print ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: prettyprint
+
+: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: failsafe ( quot -- ) [ drop ] recover ;
USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
-opengl.gl opengl.glu shuffle http.client vectors timers
+opengl.gl opengl.glu shuffle http.client vectors
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
combinators tools.time system combinators.lib combinators.cleave
float-arrays continuations opengl.demo-support multiline
USING: alien alien.c-types arrays sequences math math.vectors math.matrices
- math.parser io io.files kernel opengl opengl.gl opengl.glu
+ math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii
opengl.capabilities shuffle http.client vectors splitting tools.time system
combinators combinators.cleave float-arrays continuations namespaces
sequences.lib ;
: read-model ( stream -- model )
"Reading model" print flush [
- [ parse-model ] with-file-reader
+ ascii [ parse-model ] with-file-reader
[ normals ] 2keep 3array
] time ;
-: model-path "bun_zipper.ply" ;
+: model-path "bun_zipper.ply" temp-file ;
: model-url "http://factorcode.org/bun_zipper.ply" ;
: maybe-download ( -- path )
- model-path resource-path dup exists? [
+ model-path dup exists? [
"Downloading bunny from " write
model-url dup print flush
over download-to
<< "cairo" {
{ [ win32? ] [ "cairo.dll" ] }
- { [ macosx? ] [ "libcairo.dylib" ] }
+ ! { [ macosx? ] [ "libcairo.dylib" ] }
+ { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
{ [ unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
-! cairo_status_t
+LIBRARY: cairo
+
+TYPEDEF: int cairo_status_t
C-ENUM:
CAIRO_STATUS_SUCCESS
CAIRO_STATUS_NO_MEMORY
CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
;
-! cairo_content_t
+TYPEDEF: int cairo_content_t
: CAIRO_CONTENT_COLOR HEX: 1000 ;
: CAIRO_CONTENT_ALPHA HEX: 2000 ;
: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
-! cairo_operator_t
+TYPEDEF: int cairo_operator_t
C-ENUM:
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
CAIRO_OPERATOR_SATURATE
;
-! cairo_line_cap_t
+TYPEDEF: int cairo_line_cap_t
C-ENUM:
CAIRO_LINE_CAP_BUTT
CAIRO_LINE_CAP_ROUND
CAIRO_LINE_CAP_SQUARE
;
-! cair_line_join_t
+TYPEDEF: int cair_line_join_t
C-ENUM:
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL
;
-! cairo_fill_rule_t
+TYPEDEF: int cairo_fill_rule_t
C-ENUM:
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD
;
-! cairo_font_slant_t
+TYPEDEF: int cairo_font_slant_t
C-ENUM:
CAIRO_FONT_SLANT_NORMAL
CAIRO_FONT_SLANT_ITALIC
CAIRO_FONT_SLANT_OBLIQUE
;
-! cairo_font_weight_t
+TYPEDEF: int cairo_font_weight_t
C-ENUM:
CAIRO_FONT_WEIGHT_NORMAL
CAIRO_FONT_WEIGHT_BOLD
{ "double" "x0" }
{ "double" "y0" } ;
-! cairo_format_t
+TYPEDEF: int cairo_format_t
C-ENUM:
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A1
;
-! cairo_antialias_t
+TYPEDEF: int cairo_antialias_t
C-ENUM:
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_SUBPIXEL
;
-! cairo_subpixel_order_t
+TYPEDEF: int cairo_subpixel_order_t
C-ENUM:
CAIRO_SUBPIXEL_ORDER_DEFAULT
CAIRO_SUBPIXEL_ORDER_RGB
CAIRO_SUBPIXEL_ORDER_VBGR
;
-! cairo_hint_style_t
+TYPEDEF: int cairo_hint_style_t
C-ENUM:
CAIRO_HINT_STYLE_DEFAULT
CAIRO_HINT_STYLE_NONE
CAIRO_HINT_STYLE_FULL
;
-! cairo_hint_metrics_t
+TYPEDEF: int cairo_hint_metrics_t
C-ENUM:
CAIRO_HINT_METRICS_DEFAULT
CAIRO_HINT_METRICS_OFF
: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- )
"void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
-
+FUNCTION: uchar* cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
+FUNCTION: cairo_format_t cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
+FUNCTION: int cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
+FUNCTION: int cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
+FUNCTION: int cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
! Cairo pdf
: cairo_pdf_surface_set_size ( surface width height -- )
"void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ;
+
+! Cairo png
+
+TYPEDEF: void* cairo_write_func_t
+TYPEDEF: void* cairo_read_func_t
+
+FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png ( char* filename ) ;
+
+FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
+
+FUNCTION: cairo_status_t cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+
+FUNCTION: cairo_status_t cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
-Slava Pestov
+Doug Coleman
USING: arrays calendar kernel math sequences tools.test
-continuations system io.streams.string ;
-
-[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
-[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with
+continuations system ;
+IN: calendar.tests
+
+[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
+[ t ] [ now valid-timestamp? ] unit-test
[ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 leap-year? ] unit-test
[ f ] [ 2001 leap-year? ] unit-test
[ f ] [ 2006 leap-year? ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt
- 2006 10 10 0 0 1 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt
- 2006 10 10 0 1 40 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt
- 2006 10 9 23 58 20 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt
- 2006 10 11 0 0 0 0 make-timestamp = ] unit-test
-
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt
- 2006 10 10 0 10 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt
- 2006 10 10 0 10 30 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt
- 2006 10 10 0 0 45 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt
- 2006 10 9 23 59 15 0 make-timestamp = ] unit-test
-
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt
- 2006 10 15 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt
- 2006 10 9 23 50 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt
- 2006 10 9 22 20 0 0 make-timestamp = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt
- 2006 1 1 1 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt
- 2006 1 2 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt
- 2005 12 31 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt
- 2006 1 1 12 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt
- 2006 1 4 0 0 0 0 make-timestamp = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt
- 2006 1 2 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt
- 2005 12 31 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt
- 2007 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt
- 2005 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt
- 2004 12 31 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt
- 2005 1 1 0 0 0 0 make-timestamp = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt
- 2006 12 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt
- 2007 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt
- 2008 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt
- 2007 2 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt
- 2006 2 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt
- 2006 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt
- 2005 12 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt
- 2005 11 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt
- 2004 12 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt
- 2004 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt
- 2005 3 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt
- 2003 3 1 0 0 0 0 make-timestamp = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt
- 2006 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt
- 2007 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt
- 2005 1 1 0 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt
- 1906 1 1 0 0 0 0 make-timestamp = ] unit-test
-! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt
- ! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test
-
-[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test
-
-[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test
-
-[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test
-[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test
-[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
-[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
-[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test
-[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test
-
-[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt
- 2009 1 1 0 0 10 0 make-timestamp = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt
- 1998 12 31 23 59 50 0 make-timestamp = ] unit-test
-
-[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone
- 2004 1 1 11 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone
- 2004 1 1 16 0 0 0 make-timestamp = ] unit-test
-[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone
- 2004 1 1 13 30 0 0 make-timestamp = ] unit-test
-
-[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp
- 2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test
-
-[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp
- 2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test
-
-[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp
- 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
-
-[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp
- 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
-
-[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test
-[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test
-[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
-[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
-
-[ 0 ] [
- "Z" [ read-rfc3339-gmt-offset ] with-string-reader
-] unit-test
-
-[ 1 ] [
- "+01" [ read-rfc3339-gmt-offset ] with-string-reader
-] unit-test
-
-[ -1 ] [
- "-01" [ read-rfc3339-gmt-offset ] with-string-reader
-] unit-test
-
-[ -1-1/2 ] [
- "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
-] unit-test
-
-[ 1+1/2 ] [
- "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
-] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
+ 2006 10 10 0 0 1 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
+ 2006 10 10 0 1 40 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
+ 2006 10 9 23 58 20 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
+ 2006 10 11 0 0 0 0 <timestamp> = ] unit-test
+
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
+ 2006 10 10 0 10 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
+ 2006 10 10 0 10 30 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
+ 2006 10 10 0 0 45 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
+ 2006 10 9 23 59 15 0 <timestamp> = ] unit-test
+
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
+ 2006 10 15 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
+ 2006 10 9 23 50 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
+ 2006 10 9 22 20 0 0 <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
+ 2006 1 1 1 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
+ 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
+ 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
+ 2006 1 1 12 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
+ 2006 1 4 0 0 0 0 <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
+ 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
+ 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
+ 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
+ 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
+ 2004 12 31 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
+ 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
+ 2006 12 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
+ 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
+ 2008 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
+ 2007 2 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
+ 2006 2 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
+ 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
+ 2005 12 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
+ 2005 11 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
+ 2004 12 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
+ 2004 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
+ 2005 3 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
+ 2003 3 1 0 0 0 0 <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
+ 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
+ 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
+ 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
+ 1906 1 1 0 0 0 0 <timestamp> = ] unit-test
+! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
+! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
+
+[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
+
+[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
+
+[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+
+[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
+ 2009 1 1 0 0 10 0 <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
+ 1998 12 31 23 59 50 0 <timestamp> = ] unit-test
+
+[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
+ 2004 1 1 11 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
+ 2004 1 1 16 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
+ 2004 1 1 13 30 0 0 <timestamp> = ] unit-test
+
+[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
+ 2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
+
+[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
+ 2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
+
+[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
+ 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+
+[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
+ 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+
+[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
+[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
+[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
+[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
+
+: checktime+ now dup clone [ rot time+ drop ] keep = ;
+
+[ t ] [ 5 seconds checktime+ ] unit-test
+
+[ t ] [ 5 minutes checktime+ ] unit-test
+
+[ t ] [ 5 hours checktime+ ] unit-test
+
+[ t ] [ 5 days checktime+ ] unit-test
+
+[ t ] [ 5 weeks checktime+ ] unit-test
+
+[ t ] [ 5 months checktime+ ] unit-test
+
+[ t ] [ 5 years checktime+ ] unit-test
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io io.streams.string kernel math
-math.vectors math.functions math.parser namespaces sequences
-strings tuples system debugger combinators vocabs.loader
-calendar.backend structs alien.c-types math.vectors
-math.ranges shuffle ;
+USING: arrays kernel math math.functions namespaces sequences
+strings tuples system vocabs.loader calendar.backend threads
+new-slots accessors combinators ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
C: <timestamp> timestamp
-TUPLE: dt year month day hour minute second ;
+: <date> ( year month day -- timestamp )
+ 0 0 0 gmt-offset <timestamp> ;
-C: <dt> dt
+TUPLE: duration year month day hour minute second ;
+
+C: <duration> duration
: month-names
{
: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
-: average-month ( -- x )
- #! length of average month in days
- 30.41666666666667 ;
+: average-month 30+5/12 ; inline
+: months-per-year 12 ; inline
+: days-per-year 3652425/10000 ; inline
+: hours-per-year 876582/100 ; inline
+: minutes-per-year 5259492/10 ; inline
+: seconds-per-year 31556952 ; inline
+
+<PRIVATE
SYMBOL: a
SYMBOL: b
SYMBOL: y
SYMBOL: m
+PRIVATE>
+
: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
e get 153 m get * 2 + 5 /i - 1+
] with-scope ;
-: set-date ( year month day timestamp -- )
- [ set-timestamp-day ] keep
- [ set-timestamp-month ] keep
- set-timestamp-year ;
-
-: set-time ( hour minute second timestamp -- )
- [ set-timestamp-second ] keep
- [ set-timestamp-minute ] keep
- set-timestamp-hour ;
-
: >date< ( timestamp -- year month day )
- [ timestamp-year ] keep
- [ timestamp-month ] keep
- timestamp-day ;
+ { year>> month>> day>> } get-slots ;
: >time< ( timestamp -- hour minute second )
- [ timestamp-hour ] keep
- [ timestamp-minute ] keep
- timestamp-second ;
-
-: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
-: years ( n -- dt ) zero-dt [ set-dt-year ] keep ;
-: months ( n -- dt ) zero-dt [ set-dt-month ] keep ;
-: days ( n -- dt ) zero-dt [ set-dt-day ] keep ;
+ { hour>> minute>> second>> } get-slots ;
+
+: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
+: years ( n -- dt ) instant swap >>year ;
+: months ( n -- dt ) instant swap >>month ;
+: days ( n -- dt ) instant swap >>day ;
: weeks ( n -- dt ) 7 * days ;
-: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
-: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ;
-: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ;
-: milliseconds ( n -- dt ) 1000 /f seconds ;
+: hours ( n -- dt ) instant swap >>hour ;
+: minutes ( n -- dt ) instant swap >>minute ;
+: seconds ( n -- dt ) instant swap >>second ;
+: milliseconds ( n -- dt ) 1000 / seconds ;
+
+GENERIC: leap-year? ( obj -- ? )
-: julian-day-number>timestamp ( n -- timestamp )
- julian-day-number>date 0 0 0 0 <timestamp> ;
+M: integer leap-year? ( year -- ? )
+ dup 100 mod zero? 400 4 ? mod zero? ;
+
+M: timestamp leap-year? ( timestamp -- ? )
+ year>> leap-year? ;
+
+<PRIVATE
GENERIC: +year ( timestamp x -- timestamp )
GENERIC: +month ( timestamp x -- timestamp )
: /rem ( f n -- q r )
#! q is positive or negative, r is positive from 0 <= r < n
- [ /f floor >integer ] 2keep rem ;
+ [ / floor >integer ] 2keep rem ;
: float>whole-part ( float -- int float )
[ floor >integer ] keep over - ;
-GENERIC: leap-year? ( obj -- ? )
-M: integer leap-year? ( year -- ? )
- dup 100 mod zero? 400 4 ? mod zero? ;
-
-M: timestamp leap-year? ( timestamp -- ? )
- timestamp-year leap-year? ;
-
: adjust-leap-year ( timestamp -- timestamp )
- dup >date< 29 = swap 2 = and swap leap-year? not and [
- dup >r timestamp-year 3 1 r> [ set-date ] keep
- ] when ;
+ dup day>> 29 = over month>> 2 = pick leap-year? not and and
+ [ 3 >>month 1 >>day ] when ;
+
+: unless-zero >r dup zero? [ drop ] r> if ; inline
M: integer +year ( timestamp n -- timestamp )
- over timestamp-year + swap [ set-timestamp-year ] keep
- adjust-leap-year ;
+ [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
+
M: real +year ( timestamp n -- timestamp )
- float>whole-part rot swap 365.2425 * +day swap +year ;
+ [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
+
+: months/years ( n -- months years )
+ 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
M: integer +month ( timestamp n -- timestamp )
- over timestamp-month + 12 /rem
- dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
- +year ;
+ [ over month>> + months/years >r >>month r> +year ] unless-zero ;
+
M: real +month ( timestamp n -- timestamp )
- float>whole-part rot swap average-month * +day swap +month ;
+ [ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
M: integer +day ( timestamp n -- timestamp )
- swap [
- >date< julian-day-number + julian-day-number>timestamp
- ] keep swap >r >time< r> [ set-time ] keep ;
+ [
+ over >date< julian-day-number + julian-day-number>date
+ >r >r >>year r> >>month r> >>day
+ ] unless-zero ;
+
M: real +day ( timestamp n -- timestamp )
- float>whole-part rot swap 24 * +hour swap +day ;
+ [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ;
+
+: hours/days ( n -- hours days )
+ 24 /rem swap ;
M: integer +hour ( timestamp n -- timestamp )
- over timestamp-hour + 24 /rem pick set-timestamp-hour
- +day ;
+ [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
+
M: real +hour ( timestamp n -- timestamp )
- float>whole-part rot swap 60 * +minute swap +hour ;
+ float>whole-part swapd 60 * +minute swap +hour ;
+
+: minutes/hours ( n -- minutes hours )
+ 60 /rem swap ;
M: integer +minute ( timestamp n -- timestamp )
- over timestamp-minute + 60 /rem pick
- set-timestamp-minute +hour ;
+ [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
+
M: real +minute ( timestamp n -- timestamp )
- float>whole-part rot swap 60 * +second swap +minute ;
+ [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
+
+: seconds/minutes ( n -- seconds minutes )
+ 60 /rem swap >integer ;
M: number +second ( timestamp n -- timestamp )
- over timestamp-second + 60 /rem >r >integer r>
- pick set-timestamp-second +minute ;
+ [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
+
+: (time+)
+ [ second>> +second ] keep
+ [ minute>> +minute ] keep
+ [ hour>> +hour ] keep
+ [ day>> +day ] keep
+ [ month>> +month ] keep
+ [ year>> +year ] keep ; inline
-: +dt ( timestamp dt -- timestamp )
- dupd
- [ dt-second +second ] keep
- [ dt-minute +minute ] keep
- [ dt-hour +hour ] keep
- [ dt-day +day ] keep
- [ dt-month +month ] keep
- dt-year +year
- swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
+: +slots [ 2apply + ] curry 2keep ; inline
-: make-timestamp ( year month day hour minute second gmt-offset -- timestamp )
- <timestamp> [ 0 seconds +dt ] keep
- [ = [ "invalid timestamp" throw ] unless ] keep ;
+PRIVATE>
-: make-date ( year month day -- timestamp )
- 0 0 0 gmt-offset make-timestamp ;
+GENERIC# time+ 1 ( time dt -- time )
-: array>dt ( vec -- dt ) { dt f } swap append >tuple ;
-: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
+M: timestamp time+
+ >r clone r> (time+) drop ;
+
+M: duration time+
+ dup timestamp? [
+ swap time+
+ ] [
+ [ year>> ] +slots
+ [ month>> ] +slots
+ [ day>> ] +slots
+ [ hour>> ] +slots
+ [ minute>> ] +slots
+ [ second>> ] +slots
+ 2drop <duration>
+ ] if ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar
#! data
- tuple-slots
- { 1 12 365.2425 8765.82 525949.2 31556952.0 }
- v/ sum ;
-
-: dt>months ( dt -- x ) dt>years 12 * ;
-: dt>days ( dt -- x ) dt>years 365.2425 * ;
-: dt>hours ( dt -- x ) dt>years 8765.82 * ;
-: dt>minutes ( dt -- x ) dt>years 525949.2 * ;
-: dt>seconds ( dt -- x ) dt>years 31556952 * ;
-: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ;
+ 0 swap
+ [ year>> + ] keep
+ [ month>> months-per-year / + ] keep
+ [ day>> days-per-year / + ] keep
+ [ hour>> hours-per-year / + ] keep
+ [ minute>> minutes-per-year / + ] keep
+ second>> seconds-per-year / + ;
+
+M: duration <=> [ dt>years ] compare ;
+
+: dt>months ( dt -- x ) dt>years months-per-year * ;
+: dt>days ( dt -- x ) dt>years days-per-year * ;
+: dt>hours ( dt -- x ) dt>years hours-per-year * ;
+: dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
+: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
+: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
: convert-timezone ( timestamp n -- timestamp )
- [ over timestamp-gmt-offset - hours +dt ] keep
- over set-timestamp-gmt-offset ;
+ over gmt-offset>> over = [ drop ] [
+ [ over gmt-offset>> - hours time+ ] keep >>gmt-offset
+ ] if ;
: >local-time ( timestamp -- timestamp )
gmt-offset convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
-: timestamp- ( timestamp timestamp -- seconds )
- #! Exact calendar-time difference
+: (time-) ( timestamp timestamp -- n )
[ >gmt ] 2apply
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
-: unix-1970 ( -- timestamp )
- 1970 1 1 0 0 0 0 <timestamp> ;
+GENERIC: time- ( time1 time2 -- time )
+
+M: timestamp time-
+ #! Exact calendar-time difference
+ (time-) seconds ;
+
+: before ( dt -- -dt )
+ [ year>> neg ] keep
+ [ month>> neg ] keep
+ [ day>> neg ] keep
+ [ hour>> neg ] keep
+ [ minute>> neg ] keep
+ second>> neg
+ <duration> ;
+
+M: duration time-
+ before time+ ;
-: unix-time>timestamp ( n -- timestamp )
- >r unix-1970 r> seconds +dt ;
+: <zero> 0 0 0 0 0 0 0 <timestamp> ;
-: timestamp>unix-time ( timestamp -- n )
- unix-1970 timestamp- >integer ;
+: valid-timestamp? ( timestamp -- ? )
+ clone 0 >>gmt-offset
+ dup <zero> time- <zero> time+ = ;
-: timestamp>timeval ( timestamp -- timeval )
- timestamp>unix-time 1000 * make-timeval ;
+: unix-1970 ( -- timestamp )
+ 1970 1 1 0 0 0 0 <timestamp> ; foldable
-: timeval>timestamp ( timeval -- timestamp )
- [ timeval-sec ] keep
- timeval-usec 1000000 / + unix-time>timestamp ;
+: millis>timestamp ( n -- timestamp )
+ >r unix-1970 r> milliseconds time+ ;
+: timestamp>millis ( timestamp -- n )
+ unix-1970 (time-) 1000 * >integer ;
: gmt ( -- timestamp )
#! GMT time, right now
- unix-1970 millis 1000 /f seconds +dt ;
+ unix-1970 millis milliseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
-: before ( dt -- -dt ) tuple-slots vneg array>dt ;
-: from-now ( dt -- timestamp ) now swap +dt ;
-: ago ( dt -- timestamp ) before from-now ;
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
+: from-now ( dt -- timestamp ) now swap time+ ;
+: ago ( dt -- timestamp ) now swap time- ;
+
+: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
GENERIC: days-in-year ( obj -- n )
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
-M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ;
+M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
GENERIC: days-in-month ( obj -- n )
] if ;
M: timestamp days-in-month ( timestamp -- n )
- { timestamp-year timestamp-month } get-slots 2array days-in-month ;
+ >date< drop 2array days-in-month ;
GENERIC: day-of-week ( obj -- n )
3dup day-counts rot head-slice sum +
swap leap-year? [
-roll
- pick 3 1 make-date >r make-date r>
- <=> 0 >= [ 1+ ] when
+ pick 3 1 <date> >r <date> r>
+ after=? [ 1+ ] when
] [
- 3nip
+ >r 3drop r>
] if ;
M: timestamp day-of-year ( timestamp -- n )
- { timestamp-year timestamp-month timestamp-day } get-slots
- 3array day-of-year ;
-
-GENERIC: day. ( obj -- )
-
-M: integer day. ( n -- )
- number>string dup length 2 < [ bl ] when write ;
-
-M: timestamp day. ( timestamp -- )
- timestamp-day day. ;
-
-GENERIC: month. ( obj -- )
-
-M: array month. ( pair -- )
- first2
- [ month-names nth write bl number>string print ] 2keep
- [ 1 zeller-congruence ] 2keep
- 2array days-in-month day-abbreviations2 " " join print
- over " " <repetition> concat write
- [
- [ 1+ day. ] keep
- 1+ + 7 mod zero? [ nl ] [ bl ] if
- ] with each nl ;
-
-M: timestamp month. ( timestamp -- )
- { timestamp-year timestamp-month } get-slots 2array month. ;
-
-GENERIC: year. ( obj -- )
-
-M: integer year. ( n -- )
- 12 [ 1+ 2array month. nl ] with each ;
-
-M: timestamp year. ( timestamp -- )
- timestamp-year year. ;
-
-: pad-00 number>string 2 CHAR: 0 pad-left ;
-
-: write-00 pad-00 write ;
-
-: (timestamp>string) ( timestamp -- )
- dup day-of-week day-abbreviations3 nth write ", " write
- dup timestamp-day number>string write bl
- dup timestamp-month month-abbreviations nth write bl
- dup timestamp-year number>string write bl
- dup timestamp-hour write-00 ":" write
- dup timestamp-minute write-00 ":" write
- timestamp-second >fixnum write-00 ;
-
-: timestamp>string ( timestamp -- str )
- [ (timestamp>string) ] with-string-writer ;
-
-: (write-gmt-offset) ( ratio -- )
- 1 /mod swap write-00 60 * write-00 ;
-
-: write-gmt-offset ( gmt-offset -- )
- {
- { [ dup zero? ] [ drop "GMT" write ] }
- { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
- { [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
- } cond ;
-
-: timestamp>rfc822-string ( timestamp -- str )
- #! RFC822 timestamp format
- #! Example: Tue, 15 Nov 1994 08:12:31 +0200
- [
- dup (timestamp>string)
- " " write
- timestamp-gmt-offset write-gmt-offset
- ] with-string-writer ;
-
-: timestamp>http-string ( timestamp -- str )
- #! http timestamp format
- #! Example: Tue, 15 Nov 1994 08:12:31 GMT
- >gmt timestamp>rfc822-string ;
-
-: write-rfc3339-gmt-offset ( n -- )
- dup zero? [ drop "Z" write ] [
- dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
- 60 * 60 /mod swap write-00 CHAR: : write1 write-00
- ] if ;
-
-: (timestamp>rfc3339) ( timestamp -- )
- dup timestamp-year number>string write CHAR: - write1
- dup timestamp-month write-00 CHAR: - write1
- dup timestamp-day write-00 CHAR: T write1
- dup timestamp-hour write-00 CHAR: : write1
- dup timestamp-minute write-00 CHAR: : write1
- dup timestamp-second >fixnum write-00
- timestamp-gmt-offset write-rfc3339-gmt-offset ;
-
-: timestamp>rfc3339 ( timestamp -- str )
- [ (timestamp>rfc3339) ] with-string-writer ;
-
-: expect ( str -- )
- read1 swap member? [ "Parse error" throw ] unless ;
-
-: read-00 2 read string>number ;
-
-: read-0000 4 read string>number ;
-
-: read-rfc3339-gmt-offset ( -- n )
- read1 dup CHAR: Z = [ drop 0 ] [
- { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
- read-00
- read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
- 60 / + *
- ] if ;
-
-: (rfc3339>timestamp) ( -- timestamp )
- read-0000 ! year
- "-" expect
- read-00 ! month
- "-" expect
- read-00 ! day
- "Tt" expect
- read-00 ! hour
- ":" expect
- read-00 ! minute
- ":" expect
- read-00 ! second
- read-rfc3339-gmt-offset ! timezone
- <timestamp> ;
-
-: rfc3339>timestamp ( str -- timestamp )
- [ (rfc3339>timestamp) ] with-string-reader ;
-
-: file-time-string ( timestamp -- string )
- [
- [ timestamp-month month-abbreviations nth write ] keep bl
- [ timestamp-day number>string 2 32 pad-left write ] keep bl
- dup now [ timestamp-year ] 2apply = [
- [ timestamp-hour write-00 ] keep ":" write
- timestamp-minute write-00
- ] [
- timestamp-year number>string 5 32 pad-left write
- ] if
- ] with-string-writer ;
+ >date< 3array day-of-year ;
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp )
- day-offset days +dt ;
+ day-offset days time+ ;
: sunday ( timestamp -- timestamp ) 0 day-this-week ;
: monday ( timestamp -- timestamp ) 1 day-this-week ;
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
: beginning-of-day ( timestamp -- new-timestamp )
- clone dup >r 0 0 0 r>
- { set-timestamp-hour set-timestamp-minute set-timestamp-second }
- set-slots ; inline
+ clone
+ 0 >>hour
+ 0 >>minute
+ 0 >>second ; inline
: beginning-of-month ( timestamp -- new-timestamp )
- beginning-of-day 1 over set-timestamp-day ;
+ beginning-of-day 1 >>day ;
: beginning-of-week ( timestamp -- new-timestamp )
beginning-of-day sunday ;
: beginning-of-year ( timestamp -- new-timestamp )
- beginning-of-month 1 over set-timestamp-month ;
+ beginning-of-month 1 >>month ;
+
+: time-since-midnight ( timestamp -- duration )
+ dup beginning-of-day time- ;
+
+M: timestamp sleep-until timestamp>millis sleep-until ;
-: seconds-since-midnight ( timestamp -- x )
- dup beginning-of-day timestamp- ;
+M: duration sleep from-now sleep-until ;
{
{ [ unix? ] [ "calendar.unix" ] }
--- /dev/null
+IN: calendar.format.tests\r
+USING: calendar.format tools.test io.streams.string ;\r
+\r
+[ 0 ] [\r
+ "Z" [ read-rfc3339-gmt-offset ] with-string-reader\r
+] unit-test\r
+\r
+[ 1 ] [\r
+ "+01" [ read-rfc3339-gmt-offset ] with-string-reader\r
+] unit-test\r
+\r
+[ -1 ] [\r
+ "-01" [ read-rfc3339-gmt-offset ] with-string-reader\r
+] unit-test\r
+\r
+[ -1-1/2 ] [\r
+ "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader\r
+] unit-test\r
+\r
+[ 1+1/2 ] [\r
+ "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader\r
+] unit-test\r
--- /dev/null
+IN: calendar.format\r
+USING: math math.parser kernel sequences io calendar\r
+accessors arrays io.streams.string combinators accessors ;\r
+\r
+GENERIC: day. ( obj -- )\r
+\r
+M: integer day. ( n -- )\r
+ number>string dup length 2 < [ bl ] when write ;\r
+\r
+M: timestamp day. ( timestamp -- )\r
+ day>> day. ;\r
+\r
+GENERIC: month. ( obj -- )\r
+\r
+M: array month. ( pair -- )\r
+ first2\r
+ [ month-names nth write bl number>string print ] 2keep\r
+ [ 1 zeller-congruence ] 2keep\r
+ 2array days-in-month day-abbreviations2 " " join print\r
+ over " " <repetition> concat write\r
+ [\r
+ [ 1+ day. ] keep\r
+ 1+ + 7 mod zero? [ nl ] [ bl ] if\r
+ ] with each nl ;\r
+\r
+M: timestamp month. ( timestamp -- )\r
+ { year>> month>> } get-slots 2array month. ;\r
+\r
+GENERIC: year. ( obj -- )\r
+\r
+M: integer year. ( n -- )\r
+ 12 [ 1+ 2array month. nl ] with each ;\r
+\r
+M: timestamp year. ( timestamp -- )\r
+ year>> year. ;\r
+\r
+: pad-00 number>string 2 CHAR: 0 pad-left ;\r
+\r
+: pad-0000 number>string 4 CHAR: 0 pad-left ;\r
+\r
+: write-00 pad-00 write ;\r
+\r
+: write-0000 pad-0000 write ;\r
+\r
+: (timestamp>string) ( timestamp -- )\r
+ dup day-of-week day-abbreviations3 nth write ", " write\r
+ dup day>> number>string write bl\r
+ dup month>> month-abbreviations nth write bl\r
+ dup year>> number>string write bl\r
+ dup hour>> write-00 ":" write\r
+ dup minute>> write-00 ":" write\r
+ second>> >integer write-00 ;\r
+\r
+: timestamp>string ( timestamp -- str )\r
+ [ (timestamp>string) ] with-string-writer ;\r
+\r
+: (write-gmt-offset) ( ratio -- )\r
+ 1 /mod swap write-00 60 * write-00 ;\r
+\r
+: write-gmt-offset ( gmt-offset -- )\r
+ {\r
+ { [ dup zero? ] [ drop "GMT" write ] }\r
+ { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }\r
+ { [ dup 0 > ] [ "+" write (write-gmt-offset) ] }\r
+ } cond ;\r
+\r
+: timestamp>rfc822-string ( timestamp -- str )\r
+ #! RFC822 timestamp format\r
+ #! Example: Tue, 15 Nov 1994 08:12:31 +0200\r
+ [\r
+ dup (timestamp>string)\r
+ " " write\r
+ gmt-offset>> write-gmt-offset\r
+ ] with-string-writer ;\r
+\r
+: timestamp>http-string ( timestamp -- str )\r
+ #! http timestamp format\r
+ #! Example: Tue, 15 Nov 1994 08:12:31 GMT\r
+ >gmt timestamp>rfc822-string ;\r
+\r
+: write-rfc3339-gmt-offset ( n -- )\r
+ dup zero? [ drop "Z" write ] [\r
+ dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if\r
+ 60 * 60 /mod swap write-00 CHAR: : write1 write-00\r
+ ] if ;\r
+\r
+: (timestamp>rfc3339) ( timestamp -- )\r
+ dup year>> number>string write CHAR: - write1\r
+ dup month>> write-00 CHAR: - write1\r
+ dup day>> write-00 CHAR: T write1\r
+ dup hour>> write-00 CHAR: : write1\r
+ dup minute>> write-00 CHAR: : write1\r
+ dup second>> >fixnum write-00\r
+ gmt-offset>> write-rfc3339-gmt-offset ;\r
+\r
+: timestamp>rfc3339 ( timestamp -- str )\r
+ [ (timestamp>rfc3339) ] with-string-writer ;\r
+\r
+: expect ( str -- )\r
+ read1 swap member? [ "Parse error" throw ] unless ;\r
+\r
+: read-00 2 read string>number ;\r
+\r
+: read-0000 4 read string>number ;\r
+\r
+: read-rfc3339-gmt-offset ( -- n )\r
+ read1 dup CHAR: Z = [ drop 0 ] [\r
+ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case\r
+ read-00\r
+ read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case\r
+ 60 / + *\r
+ ] if ;\r
+\r
+: read-ymd ( -- y m d )\r
+ read-0000 "-" expect read-00 "-" expect read-00 ;\r
+\r
+: read-hms ( -- h m s )\r
+ read-00 ":" expect read-00 ":" expect read-00 ;\r
+\r
+: (rfc3339>timestamp) ( -- timestamp )\r
+ read-ymd\r
+ "Tt" expect\r
+ read-hms\r
+ read-rfc3339-gmt-offset ! timezone\r
+ <timestamp> ;\r
+\r
+: rfc3339>timestamp ( str -- timestamp )\r
+ [ (rfc3339>timestamp) ] with-string-reader ;\r
+\r
+: (ymdhms>timestamp) ( -- timestamp )\r
+ read-ymd " " expect read-hms 0 <timestamp> ;\r
+\r
+: ymdhms>timestamp ( str -- timestamp )\r
+ [ (ymdhms>timestamp) ] with-string-reader ;\r
+\r
+: (hms>timestamp) ( -- timestamp )\r
+ f f f read-hms f <timestamp> ;\r
+\r
+: hms>timestamp ( str -- timestamp )\r
+ [ (hms>timestamp) ] with-string-reader ;\r
+\r
+: (ymd>timestamp) ( -- timestamp )\r
+ read-ymd f f f f <timestamp> ;\r
+\r
+: ymd>timestamp ( str -- timestamp )\r
+ [ (ymd>timestamp) ] with-string-reader ;\r
+\r
+: (timestamp>ymd) ( timestamp -- )\r
+ dup timestamp-year write-0000\r
+ "-" write\r
+ dup timestamp-month write-00\r
+ "-" write\r
+ timestamp-day write-00 ;\r
+\r
+: timestamp>ymd ( timestamp -- str )\r
+ [ (timestamp>ymd) ] with-string-writer ;\r
+\r
+: (timestamp>hms)\r
+ dup timestamp-hour write-00\r
+ ":" write\r
+ dup timestamp-minute write-00\r
+ ":" write\r
+ timestamp-second >integer write-00 ;\r
+\r
+: timestamp>hms ( timestamp -- str )\r
+ [ (timestamp>hms) ] with-string-writer ;\r
+\r
+: timestamp>ymdhms ( timestamp -- str )\r
+ >gmt\r
+ [\r
+ dup (timestamp>ymd)\r
+ " " write\r
+ (timestamp>hms)\r
+ ] with-string-writer ;\r
+\r
+: file-time-string ( timestamp -- string )\r
+ [\r
+ [ month>> month-abbreviations nth write ] keep bl\r
+ [ day>> number>string 2 32 pad-left write ] keep bl\r
+ dup now [ year>> ] 2apply = [\r
+ [ hour>> write-00 ] keep ":" write\r
+ minute>> write-00\r
+ ] [\r
+ year>> number>string 5 32 pad-left write\r
+ ] if\r
+ ] with-string-writer ;\r
--- /dev/null
+Formatting dates and times
--- /dev/null
+Timestamp model updated every second
-Timestamp model updated every second
+Operations on timestamps and durations
+++ /dev/null
-USING: alien alien.c-types calendar calendar.unix
-kernel math tools.test ;
-
-[ t ] [ 239293000 [
- unix-time>timestamp timestamp>timeval
- timeval>timestamp timestamp>timeval *ulong
-] keep = ] unit-test
-
-
-[ t ] [ 23929000.3 [
- unix-time>timestamp timestamp>timeval
- timeval>timestamp timestamp>timeval *ulong
-] keep >bignum = ] unit-test
+
USING: alien alien.c-types arrays calendar.backend
-kernel structs math unix namespaces ;
+ kernel structs math unix.time namespaces ;
+
IN: calendar.unix
TUPLE: unix-calendar ;
!
USING: kernel tools.test math channels channels.private
sequences threads sorting ;
-IN: temporary
+IN: channels.tests
{ V{ 10 } } [
V{ } clone <channel>
! See http://factorcode.org/license.txt for BSD license.
!
! Channels - based on ideas from newsqueak
-USING: kernel sequences sequences.lib threads continuations random math ;
+USING: kernel sequences sequences.lib threads continuations
+random math ;
IN: channels
TUPLE: channel receivers senders ;
<PRIVATE
: wait ( channel -- )
- [ channel-senders push stop ] curry callcc0 ;
+ [ channel-senders push ] curry
+ "channel send" suspend drop ;
: (to) ( value receivers -- )
delete-random resume-with yield ;
: notify ( continuation channel -- channel )
[ channel-receivers push ] keep ;
-: (from) ( senders -- * )
- delete-random continue ;
+: (from) ( senders -- )
+ delete-random resume ;
PRIVATE>
M: channel from ( channel -- value )
[
notify channel-senders
- dup empty? [ stop ] [ (from) ] if
- ] curry callcc1 ;
+ dup empty? [ drop ] [ (from) ] if
+ ] curry "channel receive" suspend ;
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ;
-:: (sieve) | prime c | ( prime c -- )
+:: (sieve) ( prime c -- )
[let | p [ c from ]
newc [ <channel> ] |
p prime to
!
USING: kernel tools.test math assocs channels channels.remote
channels.remote.private ;
-IN: temporary
+IN: channels.remote.tests
{ t } [
remote-channels assoc?
SYMBOL: no-channel
: channel-process ( -- )
- receive [
+ [
{
{ { to ?id ?value }
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
{ { from ?id }
[ ?id get-channel [ from ] [ no-channel ] if* ] }
} match-cond
- ] keep reply-synchronous ;
+ ] handle-synchronous ;
PRIVATE>
+++ /dev/null
-USING: io.backend ;
-
-HOOK: sniff-channel io-backend ( -- channel )
+++ /dev/null
-! Copyright (C) 2007 Chris Double. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Wrap a sniffer in a channel
-USING: kernel channels channels.sniffer.backend
-threads io io.sniffer.backend io.sniffer.bsd
-io.unix.backend ;
-IN: channels.sniffer.bsd
-
-M: unix-io sniff-channel ( -- channel )
- "/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [
- [
- (sniff-channel)
- ] 3curry spawn drop
- ] keep ;
-
+++ /dev/null
-! Copyright (C) 2007 Chris Double. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Wrap a sniffer in a channel
-USING: kernel channels io io.backend io.sniffer
-io.sniffer.backend system vocabs.loader ;
-
-: (sniff-channel) ( stream channel -- )
- 4096 pick stream-read-partial over to (sniff-channel) ;
-
-bsd? [ "channels.sniffer.bsd" require ] when
-IN: temporary
+IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes tools.test memory ;
+compiler kernel namespaces cocoa.classes tools.test memory
+compiler.units ;
CLASS: {
{ +superclass+ "NSObject" }
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
xml.writer xml.utilities kernel namespaces ;
+IN: cocoa.plists
GENERIC: >plist ( obj -- tag )
>plist 1array "plist" build-tag*
dup { { "version" "1.0" } } update ;
-: print-plist ( obj -- )
- build-plist build-xml print-xml ;
+: plist>string ( obj -- string )
+ build-plist build-xml xml>string ;
--- /dev/null
+
+USING: kernel quotations help.syntax help.markup ;
+
+IN: combinators.cleave
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "cleave-combinators" "Cleave Combinators"
+
+{ $subsection bi }
+{ $subsection tri }
+
+{ $notes
+ "From the Merriam-Webster Dictionary: "
+ $nl
+ { $strong "cleave" }
+ { $list
+ { $emphasis "To divide by or as if by a cutting blow" }
+ { $emphasis "To separate into distinct parts and especially into "
+ "groups having divergent views" } }
+ $nl
+ "The Joy programming language has a " { $emphasis "cleave" } " combinator." }
+
+;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: bi
+
+ { $values { "x" object }
+ { "p" quotation }
+ { "q" quotation }
+
+ { "p(x)" "p applied to x" }
+ { "q(x)" "q applied to x" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: tri
+
+ { $values { "x" object }
+ { "p" quotation }
+ { "q" quotation }
+ { "r" quotation }
+
+ { "p(x)" "p applied to x" }
+ { "q(x)" "q applied to x" }
+ { "r(x)" "r applied to x" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "spread-combinators" "Spread Combinators"
+
+{ $subsection bi* }
+{ $subsection tri* } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: bi*
+
+ { $values { "x" object }
+ { "y" object }
+ { "p" quotation }
+ { "q" quotation }
+
+ { "p(x)" "p applied to x" }
+ { "q(y)" "q applied to y" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: tri*
+
+ { $values { "x" object }
+ { "y" object }
+ { "z" object }
+ { "p" quotation }
+ { "q" quotation }
+ { "r" quotation }
+
+ { "p(x)" "p applied to x" }
+ { "q(y)" "q applied to y" }
+ { "r(z)" "r applied to z" } } ;
-USING: kernel ;
+USING: kernel sequences macros ;
IN: combinators.cleave
! The cleaver family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: bi ( obj quot quot -- val val ) >r keep r> call ; inline
-
-: tri ( obj quot quot quot -- val val val )
- >r pick >r bi r> r> call ; inline
+: bi ( x p q -- p(x) q(x) ) >r keep r> call ; inline
+: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline
: tetra ( obj quot quot quot quot -- val val val val )
>r >r pick >r bi r> r> r> bi ; inline
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! General cleave
+
+MACRO: cleave ( seq -- )
+ dup
+ [ drop [ dup ] ] map concat
+ swap
+ dup
+ [ drop [ >r ] ] map concat
+ swap
+ [ [ r> ] append ] map concat
+ 3append
+ [ drop ]
+ append ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
+: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
-: tri* ( obj obj obj quot quot quot -- val val val )
+: tri* ( x y z p q r -- p(x) q(y) r(z) )
>r rot >r bi* r> r> call ; inline
: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
>r roll >r tri* r> r> call ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! General spread
+
+MACRO: spread ( seq -- )
+ dup
+ [ drop [ >r ] ] map concat
+ swap
+ [ [ r> ] swap append ] map concat
+ append ;
{ $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
{ $unchecked-example
"! Generate a random 20-bit prime number congruent to 3 (mod 4)"
- "USE: math.miller-rabin"
+ "USING: combinators.lib math math.miller-rabin prettyprint ;"
"[ 20 random-prime ] [ 4 mod 3 = ] generate ."
"526367"
} ;
"stack. The quotation can consume and produce any number of items."
}
{ $examples
- { $example "USE: combinators.lib" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
- { $example "USE: combinators.lib" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
+ { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
+ { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
}
{ $see-also dip dipd } ;
"removed from the stack, the quotation called, and the items restored."
}
{ $examples
- { $example "USE: combinators.lib" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
+ { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also slip nkeep } ;
"saved, the quotation called, and the items restored."
}
{ $examples
- { $example "USE: combinators.lib" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
+ { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
}
{ $see-also keep nslip } ;
USING: combinators.lib kernel math random sequences tools.test continuations
arrays vectors ;
-IN: temporary
+IN: combinators.lib.tests
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
-arrays.lib shuffle macros bake combinators.cleave ;
+arrays.lib shuffle macros bake combinators.cleave
+continuations ;
IN: combinators.lib
%
r> [ drop \ r> , ] each
] [ ] make ;
+
+: retry ( quot n -- )
+ [ drop ] rot compose attempt-all ; inline
-IN: temporary\r
+IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
-concurrency.messaging threads sequences ;\r
+concurrency.mailboxes threads sequences ;\r
\r
[ [ drop ] parallel-each ] must-infer\r
[ [ ] parallel-map ] must-infer\r
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test\r
\r
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
-[ linked-error "Even" = ] must-fail-with\r
+[ delegate "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists threads kernel arrays sequences ;\r
+USING: dlists dlists.private threads kernel arrays sequences\r
+alarms ;\r
IN: concurrency.conditions\r
\r
: notify-1 ( dlist -- )\r
- dup dlist-empty? [ drop ] [ pop-back second resume ] if ;\r
+ dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;\r
\r
: notify-all ( dlist -- )\r
- [ second resume ] dlist-slurp yield ;\r
+ [ resume-now ] dlist-slurp ;\r
+\r
+: queue-timeout ( queue timeout -- alarm )\r
+ #! Add an alarm which removes the current thread from the\r
+ #! queue, and resumes it, passing it a value of t.\r
+ >r self over push-front* [\r
+ tuck delete-node\r
+ dlist-node-obj t swap resume-with\r
+ ] 2curry r> later ;\r
\r
: wait ( queue timeout status -- )\r
- >r [ 2array swap push-front ] r> suspend 3drop ; inline\r
+ over [\r
+ >r queue-timeout [ drop ] r> suspend\r
+ [ "Timeout" throw ] [ cancel-alarm ] if\r
+ ] [\r
+ >r drop [ push-front ] curry r> suspend drop\r
+ ] if ;\r
USING: concurrency.count-downs threads kernel tools.test ;\r
-IN: temporary`\r
+IN: concurrency.count-downs.tests`\r
\r
[ ] [ 0 <count-down> await ] unit-test\r
\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: dlists kernel math concurrency.promises\r
-concurrency.messaging ;\r
+concurrency.mailboxes ;\r
IN: concurrency.count-downs\r
\r
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html\r
IN: concurrency.distributed
HELP: local-node
-{ $values { "addrspec" "an address specifier" }
-}
-{ $description "Return the node the current thread is running on." } ;
+{ $var-description "A variable containing the node the current thread is running on." } ;
HELP: start-node
{ $values { "port" "a port number between 0 and 65535" } }
--- /dev/null
+IN: concurrency.distributed.tests\r
+USING: tools.test concurrency.distributed kernel io.files\r
+arrays io.sockets system combinators threads math sequences\r
+concurrency.messaging ;\r
+\r
+: test-node\r
+ {\r
+ { [ unix? ] [ "distributed-concurrency-test" temp-file <local> ] }\r
+ { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }\r
+ } cond ;\r
+\r
+[ ] [ test-node dup 1array swap (start-node) ] unit-test\r
+\r
+[ ] [ yield ] unit-test\r
+\r
+[ ] [\r
+ [\r
+ receive first2 >r 3 + r> send\r
+ "thread-a" unregister-process\r
+ ] "Thread A" spawn\r
+ "thread-a" swap register-process\r
+] unit-test\r
+\r
+[ 8 ] [\r
+ 5 self 2array\r
+ "thread-a" test-node <remote-process> send\r
+\r
+ receive\r
+] unit-test\r
+\r
+[ ] [ test-node stop-node ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging
threads io io.server qualified arrays
-namespaces kernel ;
+namespaces kernel io.encodings.binary combinators.cleave
+new-slots accessors ;
QUALIFIED: io.sockets
IN: concurrency.distributed
-SYMBOL: local-node ( -- addrspec )
+SYMBOL: local-node
: handle-node-client ( -- )
- deserialize first2 get-process send ;
+ deserialize
+ [ first2 get-process send ]
+ [ stop-server ] if* ;
: (start-node) ( addrspecs addrspec -- )
+ local-node set-global
[
- local-node set-global
"concurrency.distributed"
+ binary
[ handle-node-client ] with-server
- ] 2curry f spawn drop ;
+ ] curry "Distributed concurrency server" spawn drop ;
: start-node ( port -- )
- dup internet-server io.sockets:host-name
- rot io.sockets:<inet> (start-node) ;
+ [ internet-server ]
+ [ io.sockets:host-name swap io.sockets:<inet> ] bi
+ (start-node) ;
TUPLE: remote-process id node ;
C: <remote-process> remote-process
+: send-remote-message ( message node -- )
+ binary io.sockets:<client>
+ [ serialize ] with-stream ;
+
M: remote-process send ( message thread -- )
- { remote-process-id remote-process-node } get-slots
- io.sockets:<client> [ 2array serialize ] with-stream ;
+ [ id>> 2array ] [ node>> ] bi
+ send-remote-message ;
M: thread (serialize) ( obj -- )
- thread-id local-node get-global
- <remote-process>
+ thread-id local-node get-global <remote-process>
(serialize) ;
+
+: stop-node ( node -- )
+ f swap send-remote-message ;
-IN: temporary\r
+IN: concurrency.exchangers.tests\r
USING: sequences tools.test concurrency.exchangers\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
\r
-:: exchanger-test | |\r
+:: exchanger-test ( -- )\r
[let |\r
ex [ <exchanger> ]\r
c [ 2 <count-down> ]\r
>r exchanger-thread box> resume-with r>\r
] [\r
[ exchanger-object >box ] keep\r
- [ exchanger-thread >box ] curry "Exchange wait" suspend\r
+ [ exchanger-thread >box ] curry "exchange" suspend\r
] if ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: concurrency.flags
+
+HELP: flag
+{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ;
+
+HELP: <flag>
+{ $values { "flag" flag } }
+{ $description "Creates a new flag." } ;
+
+HELP: raise-flag
+{ $values { "flag" flag } }
+{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
+
+HELP: wait-for-flag
+{ $values { "flag" flag } }
+{ $description "Waits for a flag to be raised. If the flag has already been raised, returns immediately." } ;
+
+HELP: lower-flag
+{ $values { "flag" flag } }
+{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
+
+ARTICLE: "concurrency.flags" "Flags"
+"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
+$nl
+"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if it has not been raised yet will wait for another thread to raise the flag."
+$nl
+"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
+{ $subsection flag }
+{ $subsection flag? }
+"Waiting for a flag to be raised:"
+{ $subsection raise-flag }
+{ $subsection wait-for-flag }
+{ $subsection lower-flag } ;
+
+ABOUT: "concurrency.flags"
--- /dev/null
+IN: concurrency.flags.tests\r
+USING: tools.test concurrency.flags kernel threads locals ;\r
+\r
+:: flag-test-1 ( -- )\r
+ [let | f [ <flag> ] |\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f flag-value?\r
+ ] ;\r
+\r
+[ f ] [ flag-test-1 ] unit-test\r
+\r
+:: flag-test-2 ( -- )\r
+ [let | f [ <flag> ] |\r
+ [ 1000 sleep f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f flag-value?\r
+ ] ;\r
+\r
+[ f ] [ flag-test-2 ] unit-test\r
+\r
+:: flag-test-3 ( -- )\r
+ [let | f [ <flag> ] |\r
+ f raise-flag\r
+ f flag-value?\r
+ ] ;\r
+\r
+[ t ] [ flag-test-3 ] unit-test\r
+\r
+:: flag-test-4 ( -- )\r
+ [let | f [ <flag> ] |\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f flag-value?\r
+ ] ;\r
+\r
+[ t ] [ flag-test-4 ] unit-test\r
+\r
+:: flag-test-5 ( -- )\r
+ [let | f [ <flag> ] |\r
+ [ 1000 sleep f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f flag-value?\r
+ ] ;\r
+\r
+[ t ] [ flag-test-5 ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes kernel threads ;
+IN: concurrency.flags
+
+TUPLE: flag value? thread ;
+
+: <flag> ( -- flag ) f <box> flag construct-boa ;
+
+: raise-flag ( flag -- )
+ dup flag-value? [
+ t over set-flag-value?
+ dup flag-thread [ resume ] if-box?
+ ] unless drop ;
+
+: wait-for-flag ( flag -- )
+ dup flag-value? [ drop ] [
+ [ flag-thread >box ] curry "flag" suspend drop
+ ] if ;
+
+: lower-flag ( flag -- )
+ dup wait-for-flag f swap set-flag-value? ;
-IN: temporary\r
+IN: concurrency.futures.tests\r
USING: concurrency.futures kernel tools.test threads ;\r
\r
[ 50 ] [\r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: concurrency.promises concurrency.messaging kernel arrays\r
+USING: concurrency.promises concurrency.mailboxes kernel arrays\r
continuations ;\r
IN: concurrency.futures\r
\r
] keep ; inline\r
\r
: ?future-timeout ( future timeout -- value )\r
- ?promise-timeout ;\r
+ ?promise-timeout ?linked ;\r
\r
: ?future ( future -- value )\r
- ?promise ;\r
+ ?promise ?linked ;\r
-USING: help.markup help.syntax sequences kernel quotations ;\r
+USING: help.markup help.syntax sequences kernel quotations\r
+calendar ;\r
IN: concurrency.locks\r
\r
HELP: lock\r
{ $values { "lock" lock } }\r
{ $description "Creates a reentrant lock." } ;\r
\r
-HELP: with-lock\r
-{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } }\r
+HELP: with-lock-timeout\r
+{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }\r
{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }\r
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;\r
\r
+HELP: with-lock\r
+{ $values { "lock" lock } { "quot" quotation } }\r
+{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ;\r
+\r
ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks"\r
"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads."\r
$nl\r
{ $subsection lock }\r
{ $subsection <lock> }\r
{ $subsection <reentrant-lock> }\r
-{ $subsection with-lock } ;\r
+{ $subsection with-lock }\r
+{ $subsection with-lock-timeout } ;\r
\r
HELP: rw-lock\r
{ $class-description "The class of reader/writer locks." } ;\r
\r
-HELP: with-read-lock\r
-{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } }\r
+HELP: with-read-lock-timeout\r
+{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }\r
{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }\r
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;\r
\r
-HELP: with-write-lock\r
-{ $values { "lock" lock } { "timeout" "a timeout in milliseconds or " { $link f } } { "quot" quotation } }\r
+HELP: with-read-lock\r
+{ $values { "lock" lock } { "quot" quotation } }\r
+{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;\r
+\r
+HELP: with-write-lock-timeout\r
+{ $values { "lock" lock } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }\r
{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }\r
{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;\r
\r
+HELP: with-write-lock\r
+{ $values { "lock" lock } { "quot" quotation } }\r
+{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ;\r
+\r
ARTICLE: "concurrency.locks.rw" "Read-write locks"\r
"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure."\r
$nl\r
$nl\r
"Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."\r
$nl\r
-"Read/write locks are reentrant. A thread holding a read lock may acquire a write lock recursively, and a thread holding a write lock may acquire a write lock or a read lock recursively, however a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."\r
+"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."\r
{ $subsection rw-lock }\r
{ $subsection <rw-lock> }\r
{ $subsection with-read-lock }\r
-{ $subsection with-write-lock } ;\r
+{ $subsection with-write-lock }\r
+"Versions of the above that take a timeout duration:"\r
+{ $subsection with-read-lock-timeout }\r
+{ $subsection with-write-lock-timeout } ;\r
\r
ARTICLE: "concurrency.locks" "Locks"\r
"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:"\r
-IN: temporary\r
+IN: concurrency.locks.tests\r
USING: tools.test concurrency.locks concurrency.count-downs\r
-locals kernel threads sequences ;\r
+concurrency.messaging concurrency.mailboxes locals kernel\r
+threads sequences calendar ;\r
\r
-:: lock-test-0 | |\r
+:: lock-test-0 ( -- )\r
[let | v [ V{ } clone ]\r
c [ 2 <count-down> ] |\r
\r
v\r
] ;\r
\r
-:: lock-test-1 | |\r
+:: lock-test-1 ( -- )\r
[let | v [ V{ } clone ]\r
l [ <lock> ]\r
c [ 2 <count-down> ] |\r
\r
[\r
- l f [\r
+ l [\r
yield\r
1 v push\r
yield\r
] "Lock test 1" spawn drop\r
\r
[\r
- l f [\r
+ l [\r
yield\r
3 v push\r
yield\r
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test\r
\r
[ 3 ] [\r
- <reentrant-lock> dup f [\r
- f [\r
+ <reentrant-lock> dup [\r
+ [\r
3\r
] with-lock\r
] with-lock\r
\r
[ ] [ <rw-lock> drop ] unit-test\r
\r
-[ ] [ <rw-lock> f [ ] with-read-lock ] unit-test\r
+[ ] [ <rw-lock> [ ] with-read-lock ] unit-test\r
\r
-[ ] [ <rw-lock> dup f [ f [ ] with-read-lock ] with-read-lock ] unit-test\r
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test\r
\r
-[ ] [ <rw-lock> f [ ] with-write-lock ] unit-test\r
+[ ] [ <rw-lock> [ ] with-write-lock ] unit-test\r
\r
-[ ] [ <rw-lock> dup f [ f [ ] with-write-lock ] with-write-lock ] unit-test\r
+[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test\r
\r
-[ ] [ <rw-lock> dup f [ f [ ] with-read-lock ] with-write-lock ] unit-test\r
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test\r
\r
-:: rw-lock-test-1 | |\r
+:: rw-lock-test-1 ( -- )\r
[let | l [ <rw-lock> ]\r
c [ 1 <count-down> ]\r
c' [ 1 <count-down> ]\r
v [ V{ } clone ] |\r
\r
[\r
- l f [\r
+ l [\r
1 v push\r
c count-down\r
yield\r
\r
[\r
c await\r
- l f [\r
+ l [\r
4 v push\r
1000 sleep\r
5 v push\r
\r
[\r
c await\r
- l f [\r
+ l [\r
2 v push\r
c' count-down\r
] with-read-lock\r
\r
[\r
c' await\r
- l f [\r
+ l [\r
6 v push\r
] with-write-lock\r
c'' count-down\r
\r
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test\r
\r
-:: rw-lock-test-2 | |\r
+:: rw-lock-test-2 ( -- )\r
[let | l [ <rw-lock> ]\r
c [ 1 <count-down> ]\r
c' [ 2 <count-down> ]\r
v [ V{ } clone ] |\r
\r
[\r
- l f [\r
+ l [\r
1 v push\r
c count-down\r
1000 sleep\r
\r
[\r
c await\r
- l f [\r
+ l [\r
3 v push\r
] with-read-lock\r
c' count-down\r
] ;\r
\r
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test\r
+\r
+! Test lock timeouts\r
+:: lock-timeout-test ( -- )\r
+ [let | l [ <lock> ] |\r
+ [\r
+ l [ 1 seconds sleep ] with-lock\r
+ ] "Lock holder" spawn drop\r
+\r
+ [\r
+ l 1/10 seconds [ ] with-lock-timeout\r
+ ] "Lock timeout-er" spawn-linked drop\r
+\r
+ receive\r
+ ] ;\r
+\r
+[ lock-timeout-test ] [\r
+ linked-error-thread thread-name "Lock timeout-er" =\r
+] must-fail-with\r
+\r
+:: read/write-test ( -- )\r
+ [let | l [ <lock> ] |\r
+ [\r
+ l [ 1 seconds sleep ] with-lock\r
+ ] "Lock holder" spawn drop\r
+\r
+ [\r
+ l 1/10 seconds [ ] with-lock-timeout\r
+ ] "Lock timeout-er" spawn-linked drop\r
+\r
+ receive\r
+ ] ;\r
+\r
+[\r
+ <rw-lock> dup [\r
+ 1 seconds [ ] with-write-lock-timeout\r
+ ] with-read-lock\r
+] must-fail\r
+\r
+[\r
+ <rw-lock> dup [\r
+ dup [\r
+ 1 seconds [ ] with-write-lock-timeout\r
+ ] with-read-lock\r
+ ] with-write-lock\r
+] must-fail\r
+\r
+[ ] [\r
+ <rw-lock> dup [\r
+ dup [\r
+ 1 seconds [ ] with-read-lock-timeout\r
+ ] with-read-lock\r
+ ] with-write-lock\r
+] unit-test\r
lock-threads notify-1 ;\r
\r
: do-lock ( lock timeout quot acquire release -- )\r
- >r swap compose pick >r 2curry r> r> curry [ ] cleanup ;\r
- inline\r
+ >r >r pick rot r> call ! use up timeout acquire\r
+ swap r> curry [ ] cleanup ; inline\r
\r
: (with-lock) ( lock timeout quot -- )\r
[ acquire-lock ] [ release-lock ] do-lock ; inline\r
\r
PRIVATE>\r
\r
-: with-lock ( lock timeout quot -- )\r
+: with-lock-timeout ( lock timeout quot -- )\r
pick lock-reentrant? [\r
pick lock-owner self eq? [\r
2nip call\r
(with-lock)\r
] if ; inline\r
\r
+: with-lock ( lock quot -- )\r
+ f swap with-lock-timeout ; inline\r
+\r
! Many-reader/single-writer locks\r
TUPLE: rw-lock readers writers reader# writer ;\r
\r
\r
<PRIVATE\r
\r
+: add-reader ( lock -- )\r
+ dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;\r
+\r
: acquire-read-lock ( lock timeout -- )\r
over rw-lock-writer\r
[ 2dup >r rw-lock-readers r> "read lock" wait ] when drop\r
- dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;\r
+ add-reader ;\r
\r
: notify-writer ( lock -- )\r
rw-lock-writers notify-1 ;\r
\r
+: remove-reader ( lock -- )\r
+ dup rw-lock-reader# 1- swap set-rw-lock-reader# ;\r
+\r
: release-read-lock ( lock -- )\r
- dup rw-lock-reader# 1- dup pick set-rw-lock-reader#\r
- zero? [ notify-writer ] [ drop ] if ;\r
+ dup remove-reader\r
+ dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;\r
\r
: acquire-write-lock ( lock timeout -- )\r
over rw-lock-writer pick rw-lock-reader# 0 > or\r
dup rw-lock-readers dlist-empty?\r
[ notify-writer ] [ rw-lock-readers notify-all ] if ;\r
\r
-: do-reentrant-rw-lock ( lock timeout quot quot' -- )\r
- >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline\r
+: reentrant-read-lock-ok? ( lock -- ? )\r
+ #! If we already have a write lock, then we can grab a read\r
+ #! lock too.\r
+ rw-lock-writer self eq? ;\r
+\r
+: reentrant-write-lock-ok? ( lock -- ? )\r
+ #! The only case where we have a writer and > 1 reader is\r
+ #! write -> read re-entrancy, and in this case we prohibit\r
+ #! a further write -> read -> write re-entrancy.\r
+ dup rw-lock-writer self eq?\r
+ swap rw-lock-reader# zero? and ;\r
\r
PRIVATE>\r
\r
-: with-read-lock ( lock timeout quot -- )\r
- [\r
+: with-read-lock-timeout ( lock timeout quot -- )\r
+ pick reentrant-read-lock-ok? [\r
+ [ drop add-reader ] [ remove-reader ] do-lock\r
+ ] [\r
[ acquire-read-lock ] [ release-read-lock ] do-lock\r
- ] do-reentrant-rw-lock ; inline\r
+ ] if ; inline\r
+\r
+: with-read-lock ( lock quot -- )\r
+ f swap with-read-lock-timeout ; inline\r
\r
-: with-write-lock ( lock timeout quot -- )\r
- [\r
+: with-write-lock-timeout ( lock timeout quot -- )\r
+ pick reentrant-write-lock-ok? [ 2nip call ] [\r
[ acquire-write-lock ] [ release-write-lock ] do-lock\r
- ] do-reentrant-rw-lock ; inline\r
+ ] if ; inline\r
+\r
+: with-write-lock ( lock quot -- )\r
+ f swap with-write-lock-timeout ; inline\r
--- /dev/null
+USING: help.markup help.syntax kernel arrays ;\r
+IN: concurrency.mailboxes\r
+\r
+HELP: <mailbox>\r
+{ $values { "mailbox" mailbox } }\r
+{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;\r
+\r
+HELP: mailbox-empty?\r
+{ $values { "mailbox" mailbox } \r
+ { "bool" "a boolean" }\r
+}\r
+{ $description "Return true if the mailbox is empty." } ;\r
+\r
+HELP: mailbox-put\r
+{ $values { "obj" object } \r
+ { "mailbox" mailbox } \r
+}\r
+{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;\r
+\r
+HELP: block-unless-pred\r
+{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } \r
+ { "mailbox" mailbox }\r
+ { "timeout" "a timeout in milliseconds, or " { $link f } }\r
+}\r
+{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;\r
+\r
+HELP: block-if-empty\r
+{ $values { "mailbox" mailbox } \r
+ { "timeout" "a timeout in milliseconds, or " { $link f } }\r
+}\r
+{ $description "Block the thread if the mailbox is empty." } ;\r
+\r
+HELP: mailbox-get\r
+{ $values { "mailbox" mailbox } \r
+ { "obj" object }\r
+}\r
+{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;\r
+\r
+HELP: mailbox-get-all\r
+{ $values { "mailbox" mailbox } \r
+ { "array" array }\r
+}\r
+{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;\r
+\r
+HELP: while-mailbox-empty\r
+{ $values { "mailbox" mailbox } \r
+ { "quot" "a quotation with stack effect " { $snippet "( -- )" } }\r
+}\r
+{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;\r
+\r
+HELP: mailbox-get?\r
+{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }\r
+ { "mailbox" mailbox } \r
+ { "obj" object }\r
+}\r
+{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;\r
+\r
+\r
+ARTICLE: "concurrency.mailboxes" "Mailboxes"\r
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."\r
+{ $subsection mailbox }\r
+{ $subsection <mailbox> }\r
+"Removing the first element:"\r
+{ $subsection mailbox-get }\r
+{ $subsection mailbox-get-timeout }\r
+"Removing the first element matching a predicate:"\r
+{ $subsection mailbox-get? }\r
+{ $subsection mailbox-get-timeout? }\r
+"Emptying out a mailbox:"\r
+{ $subsection mailbox-get-all }\r
+"Adding an element:"\r
+{ $subsection mailbox-put }\r
+"Testing if a mailbox is empty:"\r
+{ $subsection mailbox-empty? }\r
+{ $subsection while-mailbox-empty } ;\r
--- /dev/null
+IN: concurrency.mailboxes.tests\r
+USING: concurrency.mailboxes vectors sequences threads\r
+tools.test math kernel strings ;\r
+\r
+[ V{ 1 2 3 } ] [\r
+ 0 <vector>\r
+ <mailbox>\r
+ [ mailbox-get swap push ] in-thread\r
+ [ mailbox-get swap push ] in-thread\r
+ [ mailbox-get swap push ] in-thread\r
+ 1 over mailbox-put\r
+ 2 over mailbox-put\r
+ 3 swap mailbox-put\r
+] unit-test\r
+\r
+[ V{ 1 2 3 } ] [\r
+ 0 <vector>\r
+ <mailbox>\r
+ [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
+ 1 over mailbox-put\r
+ 2 over mailbox-put\r
+ 3 swap mailbox-put\r
+] unit-test\r
+\r
+[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [\r
+ 0 <vector>\r
+ <mailbox>\r
+ [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ string? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ string? ] swap mailbox-get? swap push ] in-thread\r
+ 1 over mailbox-put\r
+ "junk" over mailbox-put\r
+ [ 456 ] over mailbox-put\r
+ 3 over mailbox-put\r
+ "junk2" over mailbox-put\r
+ mailbox-get\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+IN: concurrency.mailboxes\r
+USING: dlists threads sequences continuations\r
+namespaces random math quotations words kernel arrays assocs\r
+init system concurrency.conditions ;\r
+\r
+TUPLE: mailbox threads data ;\r
+\r
+: <mailbox> ( -- mailbox )\r
+ <dlist> <dlist> mailbox construct-boa ;\r
+\r
+: mailbox-empty? ( mailbox -- bool )\r
+ mailbox-data dlist-empty? ;\r
+\r
+: mailbox-put ( obj mailbox -- )\r
+ [ mailbox-data push-front ] keep\r
+ mailbox-threads notify-all yield ;\r
+\r
+: block-unless-pred ( pred mailbox timeout -- )\r
+ 2over mailbox-data dlist-contains? [\r
+ 3drop\r
+ ] [\r
+ 2dup >r mailbox-threads r> "mailbox" wait\r
+ block-unless-pred\r
+ ] if ; inline\r
+\r
+: block-if-empty ( mailbox timeout -- mailbox )\r
+ over mailbox-empty? [\r
+ 2dup >r mailbox-threads r> "mailbox" wait\r
+ block-if-empty\r
+ ] [\r
+ drop\r
+ ] if ;\r
+\r
+: mailbox-peek ( mailbox -- obj )\r
+ mailbox-data peek-back ;\r
+\r
+: mailbox-get-timeout ( mailbox timeout -- obj )\r
+ block-if-empty mailbox-data pop-back ;\r
+\r
+: mailbox-get ( mailbox -- obj )\r
+ f mailbox-get-timeout ;\r
+\r
+: mailbox-get-all-timeout ( mailbox timeout -- array )\r
+ block-if-empty\r
+ [ dup mailbox-empty? ]\r
+ [ dup mailbox-data pop-back ]\r
+ [ ] unfold nip ;\r
+\r
+: mailbox-get-all ( mailbox -- array )\r
+ f mailbox-get-all-timeout ;\r
+\r
+: while-mailbox-empty ( mailbox quot -- )\r
+ over mailbox-empty? [\r
+ dup >r swap slip r> while-mailbox-empty\r
+ ] [\r
+ 2drop\r
+ ] if ; inline\r
+\r
+: mailbox-get-timeout? ( pred mailbox timeout -- obj )\r
+ [ block-unless-pred ] 3keep drop\r
+ mailbox-data delete-node-if ; inline\r
+\r
+: mailbox-get? ( pred mailbox -- obj )\r
+ f mailbox-get-timeout? ; inline\r
+\r
+TUPLE: linked-error thread ;\r
+\r
+: <linked-error> ( error thread -- linked )\r
+ { set-delegate set-linked-error-thread }\r
+ linked-error construct ;\r
+\r
+: ?linked dup linked-error? [ rethrow ] when ;\r
+\r
+TUPLE: linked-thread supervisor ;\r
+\r
+M: linked-thread error-in-thread\r
+ [ <linked-error> ] keep\r
+ linked-thread-supervisor mailbox-put ;\r
+\r
+: <linked-thread> ( quot name mailbox -- thread' )\r
+ >r <thread> linked-thread construct-delegate r>\r
+ over set-linked-thread-supervisor ;\r
+\r
+: spawn-linked-to ( quot name mailbox -- thread )\r
+ <linked-thread> [ (spawn) ] keep ;\r
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup concurrency.messaging.private
-threads kernel arrays quotations ;
+threads kernel arrays quotations threads strings ;
IN: concurrency.messaging
-HELP: <mailbox>
-{ $values { "mailbox" mailbox }
-}
-{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." }
-{ $see-also mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: mailbox-empty?
-{ $values { "mailbox" mailbox }
- { "bool" "a boolean" }
-}
-{ $description "Return true if the mailbox is empty." }
-{ $see-also <mailbox> mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: mailbox-put
-{ $values { "obj" object }
- { "mailbox" mailbox }
-}
-{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." }
-{ $see-also <mailbox> mailbox-empty? mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: block-unless-pred
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
- { "mailbox" mailbox }
- { "timeout" "a timeout in milliseconds, or " { $link f } }
-}
-{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." }
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: block-if-empty
-{ $values { "mailbox" mailbox }
- { "timeout" "a timeout in milliseconds, or " { $link f } }
-}
-{ $description "Block the thread if the mailbox is empty." }
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
-
-HELP: mailbox-get
-{ $values { "mailbox" mailbox }
- { "obj" object }
-}
-{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." }
-{ $see-also <mailbox> mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
-
-HELP: mailbox-get-all
-{ $values { "mailbox" mailbox }
- { "array" array }
-}
-{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." }
-{ $see-also <mailbox> mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
-
-HELP: while-mailbox-empty
-{ $values { "mailbox" mailbox }
- { "quot" "a quotation with stack effect " { $snippet "( -- )" } }
-}
-{ $description "Repeatedly call the quotation while there are no items in the mailbox." }
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ;
-
-HELP: mailbox-get?
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
- { "mailbox" mailbox }
- { "obj" object }
-}
-{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
-{ $see-also <mailbox> mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ;
-
HELP: send
{ $values { "message" object }
- { "thread" "a thread object" }
+ { "thread" thread }
}
{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
{ $see-also receive receive-if } ;
HELP: spawn-linked
{ $values { "quot" quotation }
- { "thread" "a thread object" }
+ { "name" string }
+ { "thread" thread }
}
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
-ARTICLE: { "concurrency" "mailboxes" } "Mailboxes"
-"Each thread has an associated message queue. Other threads can place items on this queue by sending the thread a message. A thread can check its queue for messages, blocking if none are pending, and thread them as they are queued."
+ARTICLE: { "concurrency" "messaging" } "Mailboxes"
+"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
$nl
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
$nl
{ $subsection send }
"A thread can get a message from its queue:"
{ $subsection receive }
-{ $subsection receive }
+{ $subsection receive-timeout }
{ $subsection receive-if }
-"Mailboxes can be created and used directly:"
-{ $subsection mailbox }
-{ $subsection <mailbox> }
-{ $subsection mailbox-get }
-{ $subsection mailbox-put }
-{ $subsection mailbox-empty? } ;
+{ $subsection receive-if-timeout } ;
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
{ $code "[ 1 0 / \"This will not print\" print ] spawn" }
"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
{ $subsection spawn-linked }
-"A more flexible version of the above deposits the error in an arbitary mailbox:"
-{ $subsection spawn-linked-to }
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "["
" [ 1 0 / \"This will not print\" print ] spawn-linked drop"
"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
$nl
"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
-{ $subsection { "concurrency" "mailboxes" } }
+{ $subsection { "concurrency" "messaging" } }
{ $subsection { "concurrency" "synchronous-sends" } }
{ $subsection { "concurrency" "exceptions" } } ;
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
-match quotations concurrency.messaging ;
-IN: temporary
-
-[ ] [ mailbox mailbox-data dlist-delete-all ] unit-test
-
-[ V{ 1 2 3 } ] [
- 0 <vector>
- <mailbox>
- [ mailbox-get swap push ] in-thread
- [ mailbox-get swap push ] in-thread
- [ mailbox-get swap push ] in-thread
- 1 over mailbox-put
- 2 over mailbox-put
- 3 swap mailbox-put
-] unit-test
-
-[ V{ 1 2 3 } ] [
- 0 <vector>
- <mailbox>
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- 1 over mailbox-put
- 2 over mailbox-put
- 3 swap mailbox-put
-] unit-test
-
-[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [
- 0 <vector>
- <mailbox>
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ integer? ] swap mailbox-get? swap push ] in-thread
- [ [ string? ] swap mailbox-get? swap push ] in-thread
- [ [ string? ] swap mailbox-get? swap push ] in-thread
- 1 over mailbox-put
- "junk" over mailbox-put
- [ 456 ] over mailbox-put
- 3 over mailbox-put
- "junk2" over mailbox-put
- mailbox-get
-] unit-test
+match quotations concurrency.messaging concurrency.mailboxes ;
+IN: concurrency.messaging.tests
+[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
[ "received" ] [
[
"crash" throw
] "Linked test" spawn-linked drop
receive
-] [ linked-error "crash" = ] must-fail-with
+] [ delegate "crash" = ] must-fail-with
MATCH-VARS: ?from ?to ?value ;
SYMBOL: increment
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
!\r
-! Concurrency library for Factor based on Erlang/Termite style\r
+! Concurrency library for Factor, based on Erlang/Termite style\r
! concurrency.\r
+USING: kernel threads concurrency.mailboxes continuations\r
+namespaces assocs random ;\r
IN: concurrency.messaging\r
-USING: dlists threads sequences continuations\r
-namespaces random math quotations words kernel arrays assocs\r
-init system concurrency.conditions ;\r
\r
-TUPLE: mailbox threads data ;\r
-\r
-: <mailbox> ( -- mailbox )\r
- <dlist> <dlist> \ mailbox construct-boa ;\r
-\r
-: mailbox-empty? ( mailbox -- bool )\r
- mailbox-data dlist-empty? ;\r
-\r
-: mailbox-put ( obj mailbox -- )\r
- [ mailbox-data push-front ] keep\r
- mailbox-threads notify-all ;\r
-\r
-<PRIVATE\r
-\r
-: block-unless-pred ( pred mailbox timeout -- )\r
- 2over mailbox-data dlist-contains? [\r
- 3drop\r
- ] [\r
- 2dup >r mailbox-threads r> "mailbox" wait\r
- block-unless-pred\r
- ] if ; inline\r
-\r
-: block-if-empty ( mailbox timeout -- mailbox )\r
- over mailbox-empty? [\r
- 2dup >r mailbox-threads r> "mailbox" wait\r
- block-if-empty\r
- ] [\r
- drop\r
- ] if ;\r
-\r
-PRIVATE>\r
-\r
-: mailbox-peek ( mailbox -- obj )\r
- mailbox-data peek-back ;\r
-\r
-: mailbox-get-timeout ( mailbox timeout -- obj )\r
- block-if-empty mailbox-data pop-back ;\r
-\r
-: mailbox-get ( mailbox -- obj )\r
- f mailbox-get-timeout ;\r
-\r
-: mailbox-get-all-timeout ( mailbox timeout -- array )\r
- block-if-empty\r
- [ dup mailbox-empty? ]\r
- [ dup mailbox-data pop-back ]\r
- [ ] unfold nip ;\r
-\r
-: mailbox-get-all ( mailbox -- array )\r
- f mailbox-get-all-timeout ;\r
-\r
-: while-mailbox-empty ( mailbox quot -- )\r
- over mailbox-empty? [\r
- dup >r swap slip r> while-mailbox-empty\r
- ] [\r
- 2drop\r
- ] if ; inline\r
-\r
-: mailbox-timeout-get? ( pred mailbox timeout -- obj )\r
- [ block-unless-pred ] 3keep drop\r
- mailbox-data delete-node-if ; inline\r
-\r
-: mailbox-get? ( pred mailbox -- obj )\r
- f mailbox-timeout-get? ; inline\r
-\r
-TUPLE: linked error thread ;\r
-\r
-C: <linked> linked\r
-\r
-GENERIC: send ( message process -- )\r
+GENERIC: send ( message thread -- )\r
\r
: mailbox-of ( thread -- mailbox )\r
dup thread-mailbox [ ] [\r
] ?if ;\r
\r
M: thread send ( message thread -- )\r
- mailbox-of mailbox-put ;\r
-\r
-: ?linked dup linked? [ rethrow ] when ;\r
+ check-registered mailbox-of mailbox-put ;\r
\r
-: mailbox self mailbox-of ;\r
+: my-mailbox self mailbox-of ;\r
\r
: receive ( -- message )\r
- mailbox mailbox-get ?linked ;\r
+ my-mailbox mailbox-get ?linked ;\r
+\r
+: receive-timeout ( timeout -- message )\r
+ my-mailbox swap mailbox-get-timeout ?linked ;\r
\r
: receive-if ( pred -- message )\r
- mailbox mailbox-get? ?linked ; inline\r
+ my-mailbox mailbox-get? ?linked ; inline\r
\r
-: rethrow-linked ( error process supervisor -- )\r
- >r <linked> r> send ;\r
+: receive-if-timeout ( pred timeout -- message )\r
+ my-mailbox swap mailbox-get-timeout? ?linked ; inline\r
\r
-: spawn-linked-to ( quot name mailbox -- thread )\r
- [ >r <linked> r> mailbox-put ] curry <thread>\r
- [ (spawn) ] keep ;\r
+: rethrow-linked ( error process supervisor -- )\r
+ >r <linked-error> r> send ;\r
\r
: spawn-linked ( quot name -- thread )\r
- mailbox spawn-linked-to ;\r
+ my-mailbox spawn-linked-to ;\r
\r
TUPLE: synchronous data sender tag ;\r
\r
: <reply> ( data synchronous -- reply )\r
synchronous-tag \ reply construct-boa ;\r
\r
+: synchronous-reply? ( response synchronous -- ? )\r
+ over reply?\r
+ [ >r reply-tag r> synchronous-tag = ]\r
+ [ 2drop f ] if ;\r
+\r
: send-synchronous ( message thread -- reply )\r
- >r <synchronous> dup r> send [\r
- over reply? [\r
- >r reply-tag r> synchronous-tag =\r
- ] [\r
- 2drop f\r
- ] if\r
- ] curry receive-if reply-data ;\r
+ dup self eq? [\r
+ "Cannot synchronous send to myself" throw\r
+ ] [\r
+ >r <synchronous> dup r> send\r
+ [ synchronous-reply? ] curry receive-if\r
+ reply-data\r
+ ] if ;\r
\r
: reply-synchronous ( message synchronous -- )\r
[ <reply> ] keep synchronous-sender send ;\r
\r
+: handle-synchronous ( quot -- )\r
+ receive [\r
+ synchronous-data swap call\r
+ ] keep reply-synchronous ; inline\r
+\r
<PRIVATE\r
\r
-: remote-processes ( -- hash )\r
- \ remote-processes get-global ;\r
+: registered-processes ( -- hash )\r
+ \ registered-processes get-global ;\r
\r
PRIVATE>\r
\r
: register-process ( name process -- )\r
- swap remote-processes set-at ;\r
+ swap registered-processes set-at ;\r
\r
: unregister-process ( name -- )\r
- remote-processes delete-at ;\r
+ registered-processes delete-at ;\r
\r
: get-process ( name -- process )\r
- dup remote-processes at [ ] [ thread ] ?if ;\r
+ dup registered-processes at [ ] [ thread ] ?if ;\r
\r
-\ remote-processes global [ H{ } assoc-like ] change-at\r
+\ registered-processes global [ H{ } assoc-like ] change-at\r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: concurrency.messaging kernel arrays\r
-continuations help.markup help.syntax quotations ;\r
+continuations help.markup help.syntax quotations calendar ;\r
IN: concurrency.promises\r
\r
HELP: promise\r
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;\r
\r
HELP: ?promise-timeout\r
-{ $values { "promise" promise } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } }\r
+{ $values { "promise" promise } { "timeout" "a " { $link duration } " or " { $link f } } { "result" object } }\r
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to " { $snippet "timeout" } " milliseconds." }\r
{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;\r
\r
HELP: ?promise\r
-{ $values { "promise" promise } { "value" object } }\r
+{ $values { "promise" promise } { "result" object } }\r
{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ;\r
\r
HELP: fulfill\r
-IN: temporary\r
+IN: concurrency.promises.tests\r
USING: vectors concurrency.promises kernel threads sequences\r
tools.test ;\r
\r
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: concurrency.messaging concurrency.messaging.private\r
-kernel ;\r
+USING: concurrency.mailboxes kernel continuations ;\r
IN: concurrency.promises\r
\r
TUPLE: promise mailbox ;\r
] if ;\r
\r
: ?promise-timeout ( promise timeout -- result )\r
- >r promise-mailbox r> block-if-empty\r
- mailbox-peek ?linked ;\r
+ >r promise-mailbox r> block-if-empty mailbox-peek ;\r
\r
: ?promise ( promise -- result )\r
f ?promise-timeout ;\r
IN: concurrency.semaphores\r
-USING: help.markup help.syntax kernel quotations ;\r
+USING: help.markup help.syntax kernel quotations calendar ;\r
\r
HELP: semaphore\r
{ $class-description "The class of counting semaphores." } ;\r
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }\r
{ $description "Creates a counting semaphore with the specified initial count." } ;\r
\r
+HELP: acquire-timeout\r
+{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } }\r
+{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }\r
+{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;\r
+\r
HELP: acquire\r
-{ $values { "semaphore" semaphore } { "timeout" "a timeout in milliseconds or " { $link f } } { "value" object } }\r
-{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits up to that number of milliseconds for the semaphore to be released." } ;\r
+{ $values { "semaphore" semaphore } }\r
+{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ;\r
\r
HELP: release\r
{ $values { "semaphore" semaphore } }\r
{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;\r
\r
+HELP: with-semaphore-timeout\r
+{ $values { "semaphore" semaphore } { "timeout" "a " { $link duration } " or " { $link f } } { "quot" quotation } }\r
+{ $description "Calls the quotation with the semaphore held." } ;\r
+\r
HELP: with-semaphore\r
{ $values { "semaphore" semaphore } { "quot" quotation } }\r
{ $description "Calls the quotation with the semaphore held." } ;\r
{ $subsection <semaphore> }\r
"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:"\r
{ $subsection acquire }\r
+{ $subsection acquire-timeout }\r
{ $subsection release }\r
-"A combinator which pairs acquisition and release:"\r
-{ $subsection with-semaphore } ;\r
+"Combinators which pair acquisition and release:"\r
+{ $subsection with-semaphore }\r
+{ $subsection with-semaphore-timeout } ;\r
\r
ABOUT: "concurrency.semaphores"\r
: wait-to-acquire ( semaphore timeout -- )\r
>r semaphore-threads r> "semaphore" wait ;\r
\r
-: acquire ( semaphore timeout -- )\r
- dup semaphore-count zero? [\r
- wait-to-acquire\r
- ] [\r
- drop\r
- dup semaphore-count 1- swap set-semaphore-count\r
- ] if ;\r
+: acquire-timeout ( semaphore timeout -- )\r
+ over semaphore-count zero?\r
+ [ dupd wait-to-acquire ] [ drop ] if\r
+ dup semaphore-count 1- swap set-semaphore-count ;\r
+\r
+: acquire ( semaphore -- )\r
+ f acquire-timeout ;\r
\r
: release ( semaphore -- )\r
dup semaphore-count 1+ over set-semaphore-count\r
semaphore-threads notify-1 ;\r
\r
+: with-semaphore-timeout ( semaphore timeout quot -- )\r
+ pick rot acquire-timeout swap\r
+ [ release ] curry [ ] cleanup ; inline\r
+\r
: with-semaphore ( semaphore quot -- )\r
- over acquire [ release ] curry [ ] cleanup ; inline\r
+ over acquire swap [ release ] curry [ ] cleanup ; inline\r
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
! See http://factorcode.org/license.txt for BSD license.
-IN: temporary
+IN: coroutines.tests
USING: coroutines kernel sequences prettyprint tools.test math ;
: test1 ( -- co )
!
USING: kernel math sequences words arrays io io.files namespaces
math.parser assocs quotations parser parser-combinators
-tools.time ;
+tools.time io.encodings.binary ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
: load-rom ( filename cpu -- )
#! Load the contents of the file into ROM.
#! (address 0x0000-0x1FFF).
- cpu-ram swap [
+ cpu-ram swap binary [
0 swap (load-rom)
] with-file-reader ;
#! file path shoul dbe relative to the '/roms' resource path.
rom-dir [
cpu-ram [
- swap first2 rom-dir swap path+ [
+ swap first2 rom-dir swap path+ binary [
swap (load-rom)
] with-file-reader
] curry each
IN: crypto.common
HELP: >32-bit
-{ $values { "x" "an integer" } { "y" "an integer" } }
+{ $values { "x" integer } { "y" integer } }
{ $description "Used to implement 32-bit integer overflow." } ;
HELP: >64-bit
-{ $values { "x" "an integer" } { "y" "an integer" } }
+{ $values { "x" integer } { "y" integer } }
{ $description "Used to implement 64-bit integer overflow." } ;
HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" "an integer" } }
+{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
- { $example "USE: crypto.common" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
- { $example "USE: crypto.common" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
+ { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
+ { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
{ $examples
- { $example "USE: crypto.common" "B{ 1 2 3 4 } hex-string print" "01020304" }
+ { $example "USING: crypto.common io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
}
{ $notes "Numbers are zero-padded on the left." } ;
-USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ;
-IN: temporary
+USING: kernel io strings byte-arrays sequences namespaces math
+parser crypto.hmac tools.test ;
+IN: crypto.hmac.tests
-[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" string>md5-hmac >string ] unit-test
-[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test
-[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>md5-hmac >string ] unit-test
+[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
+[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
+[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
-[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" string>sha1-hmac >string ] unit-test
-[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test
-[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <string> string>sha1-hmac >string ] unit-test
+[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
USING: arrays combinators crypto.common crypto.md5 crypto.sha1
-crypto.md5.private io io.binary io.files io.streams.string
-kernel math math.vectors memoize sequences ;
+crypto.md5.private io io.binary io.files io.streams.byte-array
+kernel math math.vectors memoize sequences io.encodings.binary ;
IN: crypto.hmac
: sha1-hmac ( Ko Ki -- hmac )
[ init-hmac sha1-hmac ] with-stream ;
: file>sha1-hmac ( K path -- hmac )
- <file-reader> stream>sha1-hmac ;
+ binary <file-reader> stream>sha1-hmac ;
-: string>sha1-hmac ( K string -- hmac )
- <string-reader> stream>sha1-hmac ;
+: byte-array>sha1-hmac ( K string -- hmac )
+ binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
[ init-hmac md5-hmac ] with-stream ;
: file>md5-hmac ( K path -- hmac )
- <file-reader> stream>md5-hmac ;
-
-: string>md5-hmac ( K string -- hmac )
- <string-reader> stream>md5-hmac ;
+ binary <file-reader> stream>md5-hmac ;
+: byte-array>md5-hmac ( K string -- hmac )
+ binary <byte-reader> stream>md5-hmac ;
USING: help.markup help.syntax kernel math sequences quotations
-crypto.common ;
+crypto.common byte-arrays ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
{ $description "Take the MD5 hash until end of stream." }
-{ $notes "Used to implement " { $link string>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
+{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
-HELP: string>md5
-{ $values { "string" "a string" } { "byte-array" "byte-array md5 hash" } }
-{ $description "Outputs the MD5 hash of a string." }
+HELP: byte-array>md5
+{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
+{ $description "Outputs the MD5 hash of a byte array." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: file>md5
-USING: kernel math namespaces crypto.md5 tools.test ;
+USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
-[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
-[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
-[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
-[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
-[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
-[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
-[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test
+[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
+[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
+[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
+[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
+[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
+[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
+[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test
! See http://www.faqs.org/rfcs/rfc1321.html
-USING: kernel io io.binary io.files io.streams.string math
+USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
-sequences crypto.common byte-arrays locals sequences.private ;
+sequences crypto.common byte-arrays locals sequences.private
+io.encodings.binary symbols ;
IN: crypto.md5
<PRIVATE
-SYMBOL: a
-SYMBOL: b
-SYMBOL: c
-SYMBOL: d
-SYMBOL: old-a
-SYMBOL: old-b
-SYMBOL: old-c
-SYMBOL: old-d
+SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >bignum ; foldable
old-c c update-old-new
old-d d update-old-new ;
-:: (ABCD) | x s i k func a b c d |
+:: (ABCD) ( x s i k func a b c d -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a [
b get c get d get func call w+
: stream>md5 ( stream -- byte-array )
[ initialize-md5 (stream>md5) get-md5 ] with-stream ;
-: string>md5 ( string -- byte-array ) <string-reader> stream>md5 ;
-: string>md5str ( string -- md5-string ) string>md5 hex-string ;
-: file>md5 ( path -- byte-array ) <file-reader> stream>md5 ;
-: file>md5str ( path -- md5-string ) file>md5 hex-string ;
+: byte-array>md5 ( byte-array -- checksum )
+ binary <byte-reader> stream>md5 ;
+
+: byte-array>md5str ( byte-array -- md5-string )
+ byte-array>md5 hex-string ;
+
+: file>md5 ( path -- byte-array )
+ binary <file-reader> stream>md5 ;
+
+: file>md5str ( path -- md5-string )
+ file>md5 hex-string ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces ;
-IN: crypto.rc4
-
-! http://en.wikipedia.org/wiki/RC4_%28cipher%29
-
-<PRIVATE
-
-SYMBOL: i
-SYMBOL: j
-SYMBOL: s
-SYMBOL: key
-SYMBOL: l
-
-! key scheduling algorithm, initialize s
-: ksa ( -- )
- 256 [ ] map s set
- 0 j set
- 256 [
- dup s get nth j get + over l get mod key get nth + 255 bitand j set
- dup j get s get exchange drop
- ] each ;
-
-: generate ( -- n )
- i get 1+ 255 bitand i set
- j get i get s get nth + 255 bitand j set
- i get j get s get exchange
- i get s get nth j get s get nth + 255 bitand s get nth ;
-
-PRIVATE>
-
-: rc4 ( key -- )
- [
- [ key set ] keep
- length l set
- ksa
- 0 i set
- 0 j set
- ] with-scope ;
-
USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
-[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
-[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
-10 swap <array> concat string>sha1str ] unit-test
+10 swap <array> concat byte-array>sha1str ] unit-test
[
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
] [
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
- string>sha1-interleave
+ byte-array>sha1-interleave
] unit-test
-USING: arrays combinators crypto.common kernel io io.binary
-io.files io.streams.string math.vectors strings sequences
-namespaces math parser sequences vectors
-hashtables ;
+USING: arrays combinators crypto.common kernel io
+io.encodings.binary io.files io.streams.byte-array math.vectors
+strings sequences namespaces math parser sequences vectors
+io.binary hashtables symbols ;
IN: crypto.sha1
! Implemented according to RFC 3174.
-SYMBOL: h0
-SYMBOL: h1
-SYMBOL: h2
-SYMBOL: h3
-SYMBOL: h4
-SYMBOL: A
-SYMBOL: B
-SYMBOL: C
-SYMBOL: D
-SYMBOL: E
-SYMBOL: w
-SYMBOL: K
+SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
: get-wth ( n -- wth ) w get nth ; inline
: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
: stream>sha1 ( stream -- sha1 )
- [ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ] with-scope ;
+ [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
-: string>sha1 ( string -- sha1 ) <string-reader> stream>sha1 ;
-: string>sha1str ( string -- str ) string>sha1 hex-string ;
-: string>sha1-bignum ( string -- n ) string>sha1 be> ;
-: file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
+: byte-array>sha1 ( string -- sha1 )
+ binary <byte-reader> stream>sha1 ;
-: string>sha1-interleave ( string -- seq )
+: byte-array>sha1str ( string -- str )
+ byte-array>sha1 hex-string ;
+
+: byte-array>sha1-bignum ( string -- n )
+ byte-array>sha1 be> ;
+
+: file>sha1 ( file -- sha1 )
+ binary <file-reader> stream>sha1 ;
+
+: byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
- seq>2seq [ string>sha1 ] 2apply
+ seq>2seq [ byte-array>sha1 ] 2apply
swap 2seq>seq ;
USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" string>sha-256-string ] unit-test
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" string>sha-256-string ] unit-test
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" string>sha-256-string ] unit-test
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" string>sha-256-string ] unit-test
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>sha-256-string ] unit-test
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>sha-256-string ] unit-test
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test
USING: crypto.common kernel splitting math sequences namespaces
-io.binary ;
+io.binary symbols ;
IN: crypto.sha2
<PRIVATE
-SYMBOL: vars
-SYMBOL: M
-SYMBOL: K
-SYMBOL: H
-SYMBOL: S0
-SYMBOL: S1
-SYMBOL: process-M
-SYMBOL: word-size
-SYMBOL: block-size
-SYMBOL: >word
+SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
: a 0 ;
: b 1 ;
T1 T2 update-vars
] with each vars get H get [ w+ ] 2map H set ;
-: seq>string ( n seq -- string )
- [ swap [ >be % ] curry each ] "" make ;
+: seq>byte-array ( n seq -- string )
+ [ swap [ >be % ] curry each ] B{ } make ;
-: string>sha2 ( string -- string )
+: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each
- 4 H get seq>string ;
+ 4 H get seq>byte-array ;
PRIVATE>
-: string>sha-256 ( string -- string )
+: byte-array>sha-256 ( string -- string )
[
K-256 K set
initial-H-256 H set
4 word-size set
64 block-size set
\ >32-bit >word set
- string>sha2
+ byte-array>sha2
] with-scope ;
-: string>sha-256-string ( string -- hexstring )
- string>sha-256 hex-string ;
-
+: byte-array>sha-256-string ( string -- hexstring )
+ byte-array>sha-256 hex-string ;
USING: crypto.timing kernel tools.test system math ;
-IN: temporary
+IN: crypto.timing.tests
[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test
USING: continuations crypto.xor kernel strings tools.test ;
-IN: temporary
+IN: crypto.xor.tests
! No key
[ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
-namespaces sequences sequences.lib tuples words strings ;
+namespaces sequences sequences.lib tuples words strings
+tools.walker new-slots accessors ;
IN: db
-TUPLE: db handle insert-statements update-statements delete-statements ;
+TUPLE: db
+ handle
+ insert-statements
+ update-statements
+ delete-statements ;
+
: <db> ( handle -- obj )
H{ } clone H{ } clone H{ } clone
db construct-boa ;
+GENERIC: make-db* ( seq class -- db )
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
+: make-db ( seq class -- db ) construct-empty make-db* ;
-: dispose-statements ( seq -- )
- [ dispose drop ] assoc-each ;
+: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
- dup db-insert-statements dispose-statements
- dup db-update-statements dispose-statements
- dup db-delete-statements dispose-statements
- db-handle db-close
+ dup insert-statements>> dispose-statements
+ dup update-statements>> dispose-statements
+ dup delete-statements>> dispose-statements
+ handle>> db-close
] with-variable ;
-TUPLE: statement sql params handle bound? slot-names ;
+TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
+TUPLE: result-set sql in-params out-params handle n max ;
+: <statement> ( sql in out -- statement )
+ { (>>sql) (>>in-params) (>>out-params) } statement construct ;
-HOOK: <simple-statement> db ( str -- statement )
-HOOK: <prepared-statement> db ( str -- statement )
+HOOK: <simple-statement> db ( str in out -- statement )
+HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
-GENERIC: bind-statement* ( obj statement -- )
-GENERIC: reset-statement ( statement -- )
-GENERIC: insert-statement ( statement -- id )
-
-TUPLE: result-set sql params handle n max ;
+GENERIC: bind-statement* ( statement -- )
+GENERIC: bind-tuple ( tuple statement -- )
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
-GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC# row-column 1 ( result-set column -- obj )
+GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
-: execute-statement ( statement -- ) query-results dispose ;
+: execute-statement ( statement -- )
+ dup sequence? [
+ [ execute-statement ] each
+ ] [
+ query-results dispose
+ ] if ;
: bind-statement ( obj statement -- )
- dup statement-bound? [ dup reset-statement ] when
- [ bind-statement* ] 2keep
- [ set-statement-params ] keep
- t swap set-statement-bound? ;
+ swap >>bind-params
+ [ bind-statement* ] keep
+ t >>bound? drop ;
: init-result-set ( result-set -- )
- dup #rows over set-result-set-max
- 0 swap set-result-set-n ;
+ dup #rows >>max
+ 0 >>n drop ;
: <result-set> ( query handle tuple -- result-set )
- >r >r { statement-sql statement-params } get-slots r>
- {
- set-result-set-sql
- set-result-set-params
- set-result-set-handle
- } result-set construct r> construct-delegate ;
+ >r >r { sql>> in-params>> out-params>> } get-slots r>
+ { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
+ construct r> construct-delegate ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
+: sql-row-typed ( result-set -- seq )
+ dup #columns [ row-column-typed ] with map ;
+
: query-each ( statement quot -- )
over more-rows? [
[ call ] 2keep over advance-row query-each
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
-: with-db ( db quot -- )
- [
- over db-open
- [ db swap with-variable ] curry with-disposal
- ] with-scope ;
+: with-db ( db seq quot -- )
+ >r make-db dup db-open db r>
+ [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
-: do-query ( query -- result-set )
+: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: do-bound-query ( obj query -- rows )
- [ bind-statement ] keep do-query ;
+ [ bind-statement ] keep default-query ;
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
-
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
HOOK: commit-transaction db ( -- )
] with-variable ;
: sql-query ( sql -- rows )
- <simple-statement> [ do-query ] with-disposal ;
+ f f <simple-statement> [ default-query ] with-disposal ;
: sql-command ( sql -- )
dup string? [
- <simple-statement> [ execute-statement ] with-disposal
+ f f <simple-statement> [ execute-statement ] with-disposal
] [
! [
[ sql-command ] each
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
- ;
+ drop ;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
-M: mysql-db <simple-statement> ( str -- statement )
- ;
+M: mysql-db <simple-statement> ( str in out -- statement )
+ 3drop f ;
-M: mysql-db <prepared-statement> ( str -- statement )
- ;
+M: mysql-db <prepared-statement> ( str in out -- statement )
+ 3drop f ;
M: mysql-statement prepare-statement ( statement -- )
- ;
+ drop ;
M: mysql-statement bind-statement* ( statement -- )
- ;
+ drop ;
M: mysql-statement query-results ( query -- result-set )
- ;
+ drop f ;
M: mysql-result-set #rows ( result-set -- n )
- ;
+ drop 0 ;
M: mysql-result-set #columns ( result-set -- n )
- ;
+ drop 0 ;
M: mysql-result-set row-column ( result-set n -- obj )
- ;
+ 2drop f ;
-M: mysql-result-set advance-row ( result-set -- ? )
- ;
+M: mysql-result-set advance-row ( result-set -- )
+ drop ;
M: mysql-db begin-transaction ( -- )
;
<< "postgresql" {
{ [ win32? ] [ "libpq.dll" ] }
- { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
+ { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
{ [ unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
FUNCTION: char* PQoidStatus ( PGresult* res ) ;
FUNCTION: Oid PQoidValue ( PGresult* res ) ;
FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
-FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+! FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: void* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
char* from, size_t length,
size_t* to_length ) ;
-FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
- size_t* retbuflen ) ;
+FUNCTION: void* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
+! FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, size_t* retbuflen ) ;
! These forms are deprecated!
FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
! Get encoding id from environment variable PGCLIENTENCODING
FUNCTION: int PQenv2encoding ( ) ;
+
+! From git, include/catalog/pg_type.h
+: BOOL-OID 16 ; inline
+: BYTEA-OID 17 ; inline
+: CHAR-OID 18 ; inline
+: NAME-OID 19 ; inline
+: INT8-OID 20 ; inline
+: INT2-OID 21 ; inline
+: INT4-OID 23 ; inline
+: TEXT-OID 23 ; inline
+: OID-OID 26 ; inline
+: FLOAT4-OID 700 ; inline
+: FLOAT8-OID 701 ; inline
+: VARCHAR-OID 1043 ; inline
+: DATE-OID 1082 ; inline
+: TIME-OID 1083 ; inline
+: TIMESTAMP-OID 1114 ; inline
+: TIMESTAMPTZ-OID 1184 ; inline
+: INTERVAL-OID 1186 ; inline
+: NUMERIC-OID 1700 ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
-db.types ;
+db.types tools.walker ascii splitting math.parser
+combinators combinators.cleave libc shuffle calendar.format
+byte-arrays destructors prettyprint new-slots accessors
+strings serialize io.encodings.binary io.streams.byte-array ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
] [
- PQresultErrorMessage [ CHAR: \n = ] right-trim
+ PQresultErrorMessage [ blank? ] trim
] if ;
: postgres-result-error ( res -- )
postgresql-result-error-message [ throw ] when* ;
+: (postgresql-error-message) ( handle -- str )
+ PQerrorMessage
+ "\n" split [ [ blank? ] trim ] map "\n" join ;
+
: postgresql-error-message ( -- str )
- db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
+ db get db-handle (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
- dup PQstatus zero? [ postgresql-error-message throw ] unless ;
+ dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
+: type>oid ( symbol -- n )
+ dup array? [ first ] when
+ {
+ { BLOB [ BYTEA-OID ] }
+ { FACTOR-BLOB [ BYTEA-OID ] }
+ [ drop 0 ]
+ } case ;
+
+: type>param-format ( symbol -- n )
+ dup array? [ first ] when
+ {
+ { BLOB [ 1 ] }
+ { FACTOR-BLOB [ 1 ] }
+ [ drop 0 ]
+ } case ;
+
+: param-types ( statement -- seq )
+ statement-in-params
+ [ sql-spec-type type>oid ] map
+ >c-uint-array ;
+
+: malloc-byte-array/length
+ [ malloc-byte-array dup free-always ] [ length ] bi ;
+
+
+: param-values ( statement -- seq seq2 )
+ [ statement-bind-params ]
+ [ statement-in-params ] bi
+ [
+ sql-spec-type {
+ { FACTOR-BLOB [
+ dup [
+ binary [ serialize ] with-byte-writer
+ malloc-byte-array/length ] [ 0 ] if ] }
+ { BLOB [
+ dup [ malloc-byte-array/length ] [ 0 ] if ] }
+ [
+ drop number>string* dup [
+ malloc-char-string dup free-always
+ ] when 0
+ ]
+ } case 2array
+ ] 2map flip dup empty? [
+ drop f f
+ ] [
+ first2 [ >c-void*-array ] [ >c-uint-array ] bi*
+ ] if ;
+
+: param-formats ( statement -- seq )
+ statement-in-params
+ [ sql-spec-type type>param-format ] map
+ >c-uint-array ;
+
: do-postgresql-bound-statement ( statement -- res )
- >r db get db-handle r>
- [ statement-sql ] keep
- [ statement-params length f ] keep
- statement-params
- [ first number>string* malloc-char-string ] map >c-void*-array
- f f 0 PQexecParams
- dup postgresql-result-ok? [
- dup postgresql-result-error-message swap PQclear throw
- ] unless ;
+ [
+ >r db get db-handle r>
+ {
+ [ statement-sql ]
+ [ statement-bind-params length ]
+ [ param-types ]
+ [ param-values ]
+ [ param-formats ]
+ } cleave
+ 0 PQexecParams dup postgresql-result-ok? [
+ dup postgresql-result-error-message swap PQclear throw
+ ] unless
+ ] with-destructors ;
+
+: pq-get-is-null ( handle row column -- ? )
+ PQgetisnull 1 = ;
+
+: pq-get-string ( handle row column -- obj )
+ 3dup PQgetvalue alien>char-string
+ dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
+
+: pq-get-number ( handle row column -- obj )
+ pq-get-string dup [ string>number ] when ;
+
+TUPLE: postgresql-malloc-destructor alien ;
+C: <postgresql-malloc-destructor> postgresql-malloc-destructor
+
+M: postgresql-malloc-destructor dispose ( obj -- )
+ alien>> PQfreemem ;
+
+: postgresql-free-always ( alien -- )
+ <postgresql-malloc-destructor> add-always-destructor ;
+
+: pq-get-blob ( handle row column -- obj/f )
+ [ PQgetvalue ] 3keep 3dup PQgetlength
+ dup 0 > [
+ 3nip
+ [
+ memory>byte-array >string
+ 0 <uint>
+ [
+ PQunescapeBytea dup zero? [
+ postgresql-result-error-message throw
+ ] [
+ dup postgresql-free-always
+ ] if
+ ] keep
+ *uint memory>byte-array
+ ] with-destructors
+ ] [
+ drop pq-get-is-null nip [ f ] [ B{ } clone ] if
+ ] if ;
+
+: postgresql-column-typed ( handle row column type -- obj )
+ dup array? [ first ] when
+ {
+ { +native-id+ [ pq-get-number ] }
+ { INTEGER [ pq-get-number ] }
+ { BIG-INTEGER [ pq-get-number ] }
+ { DOUBLE [ pq-get-number ] }
+ { TEXT [ pq-get-string ] }
+ { VARCHAR [ pq-get-string ] }
+ { DATE [ pq-get-string dup [ ymd>timestamp ] when ] }
+ { TIME [ pq-get-string dup [ hms>timestamp ] when ] }
+ { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
+ { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
+ { BLOB [ pq-get-blob ] }
+ { FACTOR-BLOB [
+ pq-get-blob
+ dup [ binary [ deserialize ] with-byte-reader ] when ] }
+ [ no-sql-type ]
+ } case ;
+ ! PQgetlength PQgetisnull
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
-USING: kernel db.postgresql alien continuations io prettyprint
-sequences namespaces tools.test db db.types ;
-IN: temporary
+USING: kernel db.postgresql alien continuations io classes
+prettyprint sequences namespaces tools.test db
+db.tuples db.types unicode.case ;
+IN: db.postgresql.tests
-IN: scratchpad
: test-db ( -- postgresql-db )
- "localhost" "postgres" "" "factor-test" <postgresql-db> ;
-IN: temporary
+ { "localhost" "postgres" "foob" "factor-test" } postgresql-db ;
[ ] [ test-db [ ] with-db ] unit-test
] with-db
] unit-test
-[
- { { "John" "America" } }
-] [
- test-db [
- "select * from person where name = $1 and country = $2"
- <simple-statement> [
- { { "Jane" TEXT } { "New Zealand" TEXT } }
- over do-bound-query
-
- { { "Jane" "New Zealand" } } =
- [ "test fails" throw ] unless
-
- { { "John" TEXT } { "America" TEXT } }
- swap do-bound-query
- ] with-disposal
- ] with-db
-] unit-test
-
[
{
{ "John" "America" }
"select * from person" sql-query length
] with-db
] unit-test
+
+
+: with-dummy-db ( quot -- )
+ >r T{ postgresql-db } db r> with-variable ;
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
-combinators ;
+combinators sequences.lib classes locals words tools.walker
+combinators.cleave namespaces.lib ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
TUPLE: postgresql-result-set ;
-: <postgresql-statement> ( statement -- postgresql-statement )
+: <postgresql-statement> ( statement in out -- postgresql-statement )
+ <statement>
postgresql-statement construct-delegate ;
-: <postgresql-db> ( host user pass db -- obj )
- {
- set-postgresql-db-host
- set-postgresql-db-user
- set-postgresql-db-pass
- set-postgresql-db-db
- } postgresql-db construct ;
+M: postgresql-db make-db* ( seq tuple -- db )
+ >r first4 r> [
+ {
+ set-postgresql-db-host
+ set-postgresql-db-user
+ set-postgresql-db-pass
+ set-postgresql-db-db
+ } set-slots
+ ] keep ;
M: postgresql-db db-open ( db -- )
- dup {
+ dup {
postgresql-db-host
postgresql-db-port
postgresql-db-pgopts
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
-: with-postgresql ( host ust pass db quot -- )
- >r <postgresql-db> r> with-disposal ;
-
-M: postgresql-statement bind-statement* ( seq statement -- )
- set-statement-params ;
-
-M: postgresql-statement reset-statement ( statement -- )
+M: postgresql-statement bind-statement* ( statement -- )
drop ;
+M: postgresql-statement bind-tuple ( tuple statement -- )
+ [
+ statement-in-params
+ [ sql-spec-slot-name swap get-slot-named ] with map
+ ] keep set-statement-bind-params ;
+
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
result-set-handle PQnfields ;
-M: postgresql-result-set row-column ( result-set n -- obj )
- >r dup result-set-handle swap result-set-n r> PQgetvalue ;
-
-M: postgresql-result-set row-column-typed ( result-set n type -- obj )
- >r row-column r> sql-type>factor-type ;
-
-M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
- {
- { INTEGER [ string>number ] }
- { BIG_INTEGER [ string>number ] }
- { DOUBLE [ string>number ] }
- [ drop ]
- } case ;
+M: postgresql-result-set row-column ( result-set column -- obj )
+ >r dup result-set-handle swap result-set-n r> pq-get-string ;
-M: postgresql-statement insert-statement ( statement -- id )
- query-results [ 0 row-column ] with-disposal string>number ;
+M: postgresql-result-set row-column-typed ( result-set column -- obj )
+ dup pick result-set-out-params nth sql-spec-type
+ >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
- dup statement-params [
+ dup statement-bind-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
- dup statement-sql swap statement-params
+ dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
-M: postgresql-db <simple-statement> ( sql -- statement )
- { set-statement-sql } statement construct
+M: postgresql-db <simple-statement> ( sql in out -- statement )
<postgresql-statement> ;
-M: postgresql-db <prepared-statement> ( sql -- statement )
- { set-statement-sql } statement construct
- <postgresql-statement> ;
+M: postgresql-db <prepared-statement> ( sql in out -- statement )
+ <postgresql-statement> dup prepare-statement ;
M: postgresql-db begin-transaction ( -- )
"BEGIN" sql-command ;
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
-: postgresql-type-hash* ( -- assoc )
- H{
- { SERIAL "serial" }
- } ;
+SYMBOL: postgresql-counter
+: bind-name% ( -- )
+ CHAR: $ 0,
+ postgresql-counter [ inc ] keep get 0# ;
-: postgresql-type-hash ( -- assoc )
- H{
- { INTEGER "integer" }
- { SERIAL "integer" }
- { TEXT "text" }
- { VARCHAR "varchar" }
- { DOUBLE "real" }
- } ;
-
-: enquote ( str -- newstr ) "(" swap ")" 3append ;
+M: postgresql-db bind% ( spec -- )
+ 1, bind-name% ;
-: postgresql-type ( str n/str -- newstr )
- " " swap number>string* enquote 3append ;
+: postgresql-make ( class quot -- )
+ >r sql-props r>
+ [ postgresql-counter off ] swap compose
+ { "" { } { } } nmake <postgresql-statement> ;
-: >sql-type* ( obj -- str )
- dup pair? [
- first2 >r >sql-type* r> postgresql-type
- ] [
- dup postgresql-type-hash* at* [
- nip
- ] [
- drop >sql-type
- ] if
- ] if ;
-
-M: postgresql-db >sql-type ( hash obj -- str )
- dup pair? [
- first2 >r >sql-type r> postgresql-type
- ] [
- postgresql-type-hash at* [
- no-sql-type
- ] unless
- ] if ;
-
-: insert-function ( columns table -- sql )
+: create-table-sql ( class -- statement )
[
- >r remove-id r>
- "create function add_" % dup %
- "(" %
- over [ "," % ]
- [ third dup array? [ first ] when >sql-type % ] interleave
- ")" %
- " returns bigint as '" %
-
- 2dup "insert into " %
- %
- "(" %
- dup [ ", " % ] [ second % ] interleave
- ") " %
- " values (" %
- length [1,b] [ ", " % ] [ "$" % # ] interleave
- "); " %
-
- "select currval(''" % % "_id_seq'');' language sql;" %
- drop
- ] "" make ;
-
-: drop-function ( columns table -- sql )
+ "create table " 0% 0%
+ "(" 0%
+ [ ", " 0% ] [
+ dup sql-spec-column-name 0%
+ " " 0%
+ dup sql-spec-type t lookup-type 0%
+ modifiers 0%
+ ] interleave ");" 0%
+ ] postgresql-make ;
+
+: create-function-sql ( class -- statement )
[
>r remove-id r>
- "drop function add_" % %
- "(" %
- [ "," % ] [ third >sql-type % ] interleave
- ")" %
- ] "" make ;
-
-M: postgresql-db create-sql ( columns table -- seq )
- [
+ "create function add_" 0% dup 0%
+ "(" 0%
+ over [ "," 0% ]
[
- 2dup
- "create table " % %
- " (" % [ ", " % ] [
- dup second % " " %
- dup third >sql-type* % " " %
- sql-modifiers " " join %
- ] interleave "); " %
- ] "" make ,
-
- over native-id? [ insert-function , ] [ 2drop ] if
+ sql-spec-type f lookup-type 0%
+ ] interleave
+ ")" 0%
+ " returns bigint as '" 0%
+
+ "insert into " 0%
+ dup 0%
+ "(" 0%
+ over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ ") values(" 0%
+ swap [ ", " 0% ] [ drop bind-name% ] interleave
+ "); " 0%
+ "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
+ ] postgresql-make ;
+
+M: postgresql-db create-sql-statement ( class -- seq )
+ [
+ [ create-table-sql , ] keep
+ dup db-columns find-primary-key native-id?
+ [ create-function-sql , ] [ drop ] if
] { } make ;
-M: postgresql-db drop-sql ( columns table -- seq )
+: drop-function-sql ( class -- statement )
[
- [
- dup "drop table " % % ";" %
- ] "" make ,
- over native-id? [ drop-function , ] [ 2drop ] if
+ "drop function add_" 0% 0%
+ "(" 0%
+ remove-id
+ [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
+ ");" 0%
+ ] postgresql-make ;
+
+: drop-table-sql ( table -- statement )
+ [
+ "drop table " 0% 0% ";" 0% drop
+ ] postgresql-make ;
+
+M: postgresql-db drop-sql-statement ( class -- seq )
+ [
+ [ drop-table-sql , ] keep
+ dup db-columns find-primary-key native-id?
+ [ drop-function-sql , ] [ drop ] if
] { } make ;
-M: postgresql-db insert-sql* ( columns table -- slot-names sql )
+M: postgresql-db <insert-native-statement> ( class -- statement )
+ [
+ "select add_" 0% 0%
+ "(" 0%
+ dup find-primary-key 2,
+ remove-id
+ [ ", " 0% ] [ bind% ] interleave
+ ");" 0%
+ ] postgresql-make ;
+
+M: postgresql-db <insert-assigned-statement> ( class -- statement )
[
- "select add_" % %
- "(" %
- length [1,b] [ ", " % ] [ "$" % # ] interleave
- ")" %
- ] "" make ;
+ "insert into " 0% 0%
+ "(" 0%
+ dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ ")" 0%
+
+ " values(" 0%
+ [ ", " 0% ] [ bind% ] interleave
+ ");" 0%
+ ] postgresql-make ;
-M: postgresql-db update-sql* ( columns table -- slot-names sql )
+M: postgresql-db insert-tuple* ( tuple statement -- )
+ query-modify-tuple ;
+
+M: postgresql-db <update-tuple-statement> ( class -- statement )
[
- "update " %
- %
- " set " %
+ "update " 0% 0%
+ " set " 0%
dup remove-id
- dup length [1,b] swap 2array flip
- [ ", " % ] [ first2 second % " = $" % # ] interleave
- " where " %
- [ primary-key? ] find nip second dup % " = $" % length 2 + #
- ] "" make ;
+ [ ", " 0% ]
+ [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ " where " 0%
+ find-primary-key
+ dup sql-spec-column-name 0% " = " 0% bind%
+ ] postgresql-make ;
+
+M: postgresql-db <delete-tuple-statement> ( class -- statement )
+ [
+ "delete from " 0% 0%
+ " where " 0%
+ find-primary-key
+ dup sql-spec-column-name 0% " = " 0% bind%
+ ] postgresql-make ;
-M: postgresql-db delete-sql* ( columns table -- slot-names sql )
+M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
- "delete from " %
- %
- " where " %
- first second % " = $1" %
- ] "" make ;
+ ! tuple columns table
+ "select " 0%
+ over [ ", " 0% ]
+ [ dup sql-spec-column-name 0% 2, ] interleave
+
+ " from " 0% 0%
+ [ sql-spec-slot-name swap get-slot-named ] with subset
+ dup empty? [
+ drop
+ ] [
+ " where " 0%
+ [ " and " 0% ]
+ [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ ] if ";" 0%
+ ] postgresql-make ;
-M: postgresql-db select-sql ( columns table -- slot-names sql )
- drop ;
+M: postgresql-db type-table ( -- hash )
+ H{
+ { +native-id+ "integer" }
+ { TEXT "text" }
+ { VARCHAR "varchar" }
+ { INTEGER "integer" }
+ { DOUBLE "real" }
+ { DATE "date" }
+ { TIME "time" }
+ { DATETIME "timestamp" }
+ { TIMESTAMP "timestamp" }
+ { BLOB "bytea" }
+ { FACTOR-BLOB "bytea" }
+ } ;
-M: postgresql-db tuple>params ( columns tuple -- obj )
- [ >r dup third swap first r> get-slot-named swap ]
- curry { } map>assoc ;
+M: postgresql-db create-type-table ( -- hash )
+ H{
+ { +native-id+ "serial primary key" }
+ } ;
+
+: postgresql-compound ( str n -- newstr )
+ over {
+ { "default" [ first number>string join-space ] }
+ { "varchar" [ first number>string paren append ] }
+ { "references" [
+ first2 >r [ unparse join-space ] keep db-columns r>
+ swap [ sql-spec-slot-name = ] with find nip
+ sql-spec-column-name paren append
+ ] }
+ [ "no compound found" 3array throw ]
+ } case ;
+
+M: postgresql-db compound-modifier ( str seq -- newstr )
+ postgresql-compound ;
-: postgresql-db-modifiers ( -- hashtable )
+M: postgresql-db modifier-table ( -- hashtable )
H{
- { +native-id+ "not null primary key" }
+ { +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
+ { +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +not-null+ "not null" }
} ;
-M: postgresql-db sql-modifiers* ( modifiers -- str )
- postgresql-db-modifiers swap [
- dup array? [
- first2
- >r swap at r> number>string*
- " " swap 3append
- ] [
- swap at
- ] if
- ] with map [ ] subset ;
+M: postgresql-db compound-type ( str n -- newstr )
+ postgresql-compound ;
--- /dev/null
+USING: kernel namespaces db.sql sequences math ;
+IN: db.sql.tests
+
+TUPLE: person name age ;
+: insert-1
+ { insert
+ { table "person" }
+ { columns "name" "age" }
+ { values "erg" 26 }
+ } ;
+
+: update-1
+ { update "person"
+ { set { "name" "erg" }
+ { "age" 6 } }
+ { where { "age" 6 } }
+ } ;
+
+: select-1
+ { select
+ { columns
+ "branchno"
+ { count "staffno" as "mycount" }
+ { sum "salary" as "mysum" } }
+ { from "staff" "lol" }
+ { where
+ { "salary" > all
+ { select
+ { columns "salary" }
+ { from "staff" }
+ { where { "branchno" "b003" } }
+ }
+ }
+ { "branchno" > 3 } }
+ { group-by "branchno" "lol2" }
+ { having { count "staffno" > 1 } }
+ { order-by "branchno" }
+ { offset 40 }
+ { limit 20 }
+ } ;
+
+
--- /dev/null
+USING: kernel parser quotations tuples words
+namespaces.lib namespaces sequences arrays combinators
+prettyprint strings math.parser sequences.lib math symbols ;
+USE: tools.walker
+IN: db.sql
+
+SYMBOLS: insert update delete select distinct columns from as
+where group-by having order-by limit offset is-null desc all
+any count avg table values ;
+
+: input-spec, 1, ;
+: output-spec, 2, ;
+: input, 3, ;
+: output, 4, ;
+
+DEFER: sql%
+
+: (sql-interleave) ( seq sep -- )
+ [ sql% ] curry [ sql% ] interleave ;
+
+: sql-interleave ( seq str sep -- )
+ swap sql% (sql-interleave) ;
+
+: sql-function, ( seq function -- )
+ sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
+
+: sql-array% ( array -- )
+ unclip
+ {
+ { columns [ "," (sql-interleave) ] }
+ { from [ "from" "," sql-interleave ] }
+ { where [ "where" "and" sql-interleave ] }
+ { group-by [ "group by" "," sql-interleave ] }
+ { having [ "having" "," sql-interleave ] }
+ { order-by [ "order by" "," sql-interleave ] }
+ { offset [ "offset" sql% sql% ] }
+ { limit [ "limit" sql% sql% ] }
+ { select [ "(select" sql% sql% ")" sql% ] }
+ { table [ sql% ] }
+ { set [ "set" "," sql-interleave ] }
+ { values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
+ { count [ "count" sql-function, ] }
+ { sum [ "sum" sql-function, ] }
+ { avg [ "avg" sql-function, ] }
+ { min [ "min" sql-function, ] }
+ { max [ "max" sql-function, ] }
+ [ sql% [ sql% ] each ]
+ } case ;
+
+TUPLE: no-sql-match ;
+: sql% ( obj -- )
+ {
+ { [ dup string? ] [ " " 0% 0% ] }
+ { [ dup array? ] [ sql-array% ] }
+ { [ dup number? ] [ number>string sql% ] }
+ { [ dup symbol? ] [ unparse sql% ] }
+ { [ dup word? ] [ unparse sql% ] }
+ { [ t ] [ T{ no-sql-match } throw ] }
+ } cond ;
+
+: parse-sql ( obj -- sql in-spec out-spec in out )
+ [
+ unclip {
+ { insert [ "insert into" sql% ] }
+ { update [ "update" sql% ] }
+ { delete [ "delete" sql% ] }
+ { select [ "select" sql% ] }
+ } case [ sql% ] each
+ ] { "" { } { } { } { } } nmake ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
-FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
-continuations db.types ;
+continuations db.types calendar.format serialize
+io.streams.byte-array byte-arrays io.encodings.binary
+tools.walker ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
: sqlite-bind-null ( handle i -- )
sqlite3_bind_null sqlite-check-result ;
+: sqlite-bind-blob ( handle i byte-array -- )
+ dup length SQLITE_TRANSIENT
+ sqlite3_bind_blob sqlite-check-result ;
+
: sqlite-bind-text-by-name ( handle name text -- )
parameter-index sqlite-bind-text ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
+: sqlite-bind-blob-by-name ( handle name blob -- )
+ parameter-index sqlite-bind-blob ;
+
: sqlite-bind-null-by-name ( handle name obj -- )
parameter-index drop sqlite-bind-null ;
: sqlite-bind-type ( handle key value type -- )
+ over [ drop NULL ] unless
dup array? [ first ] when
{
{ INTEGER [ sqlite-bind-int-by-name ] }
- { BIG_INTEGER [ sqlite-bind-int64-by-name ] }
+ { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
- { SERIAL [ sqlite-bind-int-by-name ] }
- ! { NULL [ sqlite-bind-null-by-name ] }
+ { DATE [ sqlite-bind-text-by-name ] }
+ { TIME [ sqlite-bind-text-by-name ] }
+ { DATETIME [ sqlite-bind-text-by-name ] }
+ { TIMESTAMP [ sqlite-bind-text-by-name ] }
+ { BLOB [ sqlite-bind-blob-by-name ] }
+ { FACTOR-BLOB [
+ binary [ serialize ] with-byte-writer
+ sqlite-bind-blob-by-name
+ ] }
+ { +native-id+ [ sqlite-bind-int-by-name ] }
+ { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
: sqlite-#columns ( query -- int )
sqlite3_column_count ;
-! TODO
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
+: sqlite-column-blob ( handle index -- byte-array/f )
+ [ sqlite3_column_bytes ] 2keep
+ pick zero? [
+ 3drop f
+ ] [
+ sqlite3_column_blob swap memory>byte-array
+ ] if ;
+
: sqlite-column-typed ( handle index type -- obj )
+ dup array? [ first ] when
{
+ { +native-id+ [ sqlite3_column_int64 ] }
{ INTEGER [ sqlite3_column_int ] }
- { BIG_INTEGER [ sqlite3_column_int64 ] }
- { TEXT [ sqlite3_column_text ] }
+ { BIG-INTEGER [ sqlite3_column_int64 ] }
{ DOUBLE [ sqlite3_column_double ] }
+ { TEXT [ sqlite3_column_text ] }
+ { VARCHAR [ sqlite3_column_text ] }
+ { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
+ { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
+ { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+ { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+ { BLOB [ sqlite-column-blob ] }
+ { FACTOR-BLOB [
+ sqlite-column-blob
+ dup [ binary [ deserialize ] with-byte-reader ] when
+ ] }
+ ! { NULL [ 2drop f ] }
+ [ no-sql-type ]
} case ;
-! TODO
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db sequences
-continuations db.types ;
-IN: temporary
+continuations db.types db.tuples unicode.case ;
+IN: db.sqlite.tests
-: test.db "extra/db/sqlite/test.db" resource-path ;
+: db-path "test.db" temp-file ;
+: test.db db-path sqlite-db ;
-[ ] [ [ test.db delete-file ] ignore-errors ] unit-test
+[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
[ ] [
test.db [
"create table person (name varchar(30), country varchar(30))" sql-command
"insert into person values('John', 'America')" sql-command
"insert into person values('Jane', 'New Zealand')" sql-command
- ] with-sqlite
+ ] with-db
] unit-test
[ { { "John" "America" } { "Jane" "New Zealand" } } ] [
test.db [
"select * from person" sql-query
- ] with-sqlite
-] unit-test
-
-[ { { "John" "America" } } ] [
- test.db [
- "select * from person where name = :name and country = :country"
- <simple-statement> [
- { { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } }
- over do-bound-query
-
- { { "Jane" "New Zealand" } } =
- [ "test fails" throw ] unless
-
- { { ":name" "John" TEXT } { ":country" "America" TEXT } }
- swap do-bound-query
- ] with-disposal
- ] with-sqlite
+ ] with-db
] unit-test
[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
-[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
+[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
[ ] [
test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
- ] with-sqlite
+ ] with-db
] unit-test
[
{ "2" "Jane" "New Zealand" }
{ "3" "Jimmy" "Canada" }
}
-] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
+] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
[
test.db [
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
- ] with-sqlite
+ ] with-db
] must-fail
[ 3 ] [
test.db [
"select * from person" sql-query length
- ] with-sqlite
+ ] with-db
] unit-test
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
- ] with-sqlite
+ ] with-db
] unit-test
[ 5 ] [
test.db [
"select * from person" sql-query length
- ] with-sqlite
+ ] with-db
] unit-test
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types ;
+words combinators.lib db.types combinators
+combinators.cleave io namespaces.lib ;
IN: db.sqlite
TUPLE: sqlite-db path ;
-C: <sqlite-db> sqlite-db
+
+M: sqlite-db make-db* ( path db -- db )
+ [ set-sqlite-db-path ] keep ;
M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- )
- >r <sqlite-db> r> with-db ; inline
+ sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
-C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set has-more? ;
-M: sqlite-db <simple-statement> ( str -- obj )
+M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
-M: sqlite-db <prepared-statement> ( str -- obj )
- db get db-handle over sqlite-prepare
- { set-statement-sql set-statement-handle } statement construct
- <sqlite-statement> [ set-delegate ] keep ;
+M: sqlite-db <prepared-statement> ( str in out -- obj )
+ {
+ set-statement-sql
+ set-statement-in-params
+ set-statement-out-params
+ } statement construct
+ db get db-handle over statement-sql sqlite-prepare
+ over set-statement-handle
+ sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
-M: sqlite-statement bind-statement* ( triples statement -- )
- statement-handle sqlite-bind ;
-
-M: sqlite-statement reset-statement ( statement -- )
+: reset-statement ( statement -- )
statement-handle sqlite-reset ;
+M: sqlite-statement bind-statement* ( statement -- )
+ dup statement-bound? [ dup reset-statement ] when
+ [ statement-bind-params ] [ statement-handle ] bi
+ sqlite-bind ;
+
+M: sqlite-statement bind-tuple ( tuple statement -- )
+ [
+ statement-in-params
+ [
+ [ sql-spec-column-name ":" swap append ]
+ [ sql-spec-slot-name rot get-slot-named ]
+ [ sql-spec-type ] tri 3array
+ ] with map
+ ] keep
+ bind-statement ;
+
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
-M: sqlite-statement insert-statement ( statement -- id )
- execute-statement last-insert-id ;
+M: sqlite-db insert-tuple* ( tuple statement -- )
+ execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ;
-M: sqlite-result-set row-column-typed ( result-set n type -- obj )
- >r result-set-handle r> sqlite-column-typed ;
+M: sqlite-result-set row-column-typed ( result-set n -- obj )
+ dup pick result-set-out-params nth sql-spec-type
+ >r >r result-set-handle r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
-M: sqlite-db create-sql ( columns table -- sql )
+: sqlite-make ( class quot -- )
+ >r sql-props r>
+ { "" { } { } } nmake <simple-statement> ;
+
+M: sqlite-db create-sql-statement ( class -- statement )
[
- "create table " % %
- " (" % [ ", " % ] [
- dup second % " " %
- dup third >sql-type % " " %
- sql-modifiers " " join %
- ] interleave ")" %
- ] "" make ;
-
-M: sqlite-db drop-sql ( columns table -- sql )
+ "create table " 0% 0%
+ "(" 0% [ ", " 0% ] [
+ dup sql-spec-column-name 0%
+ " " 0%
+ dup sql-spec-type t lookup-type 0%
+ modifiers 0%
+ ] interleave ");" 0%
+ ] sqlite-make ;
+
+M: sqlite-db drop-sql-statement ( class -- statement )
[
- "drop table " % %
- drop
- ] "" make ;
+ "drop table " 0% 0% ";" 0% drop
+ ] sqlite-make ;
-M: sqlite-db insert-sql* ( columns table -- sql )
+M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
- "insert into " %
- %
- "(" %
- dup [ ", " % ] [ second % ] interleave
- ") " %
- " values (" %
- [ ", " % ] [ ":" % second % ] interleave
- ")" %
- ] "" make ;
-
-: where-primary-key% ( columns -- )
- " where " %
- [ primary-key? ] find nip second dup % " = :" % % ;
-
-M: sqlite-db update-sql* ( columns table -- sql )
+ "insert into " 0% 0%
+ "(" 0%
+ maybe-remove-id
+ dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ ") values(" 0%
+ [ ", " 0% ] [ bind% ] interleave
+ ");" 0%
+ ] sqlite-make ;
+
+M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+ <insert-native-statement> ;
+
+: where-primary-key% ( specs -- )
+ " where " 0%
+ find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
+
+: where-clause ( specs -- )
+ " where " 0%
+ [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
+
+M: sqlite-db <update-tuple-statement> ( class -- statement )
[
- "update " %
- %
- " set " %
+ "update " 0%
+ 0%
+ " set " 0%
dup remove-id
- [ ", " % ] [ second dup % " = :" % % ] interleave
+ [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
where-primary-key%
- ] "" make ;
+ ] sqlite-make ;
-M: sqlite-db delete-sql* ( columns table -- sql )
+M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[
- "delete from " %
- %
- " where " %
- first second dup % " = :" % %
- ] "" make ;
+ "delete from " 0% 0%
+ " where " 0%
+ find-primary-key
+ dup sql-spec-column-name 0% " = " 0% bind%
+ ] sqlite-make ;
-: select-interval ( interval name -- )
- ;
+! : select-interval ( interval name -- ) ;
+! : select-sequence ( seq name -- ) ;
-: select-sequence ( seq name -- )
- ;
+M: sqlite-db bind% ( spec -- )
+ dup 1, sql-spec-column-name ":" swap append 0% ;
-M: sqlite-db select-sql ( columns table -- sql )
+M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
- "select ROWID, " %
- over [ ", " % ] [ second % ] interleave
- " from " % %
- " where " %
- ] "" make ;
+ "select " 0%
+ over [ ", " 0% ]
+ [ dup sql-spec-column-name 0% 2, ] interleave
-M: sqlite-db tuple>params ( columns tuple -- obj )
- [
- >r [ second ":" swap append ] keep r>
- dupd >r first r> get-slot-named swap
- third 3array
- ] curry map ;
+ " from " 0% 0%
+ [ sql-spec-slot-name swap get-slot-named ] with subset
+ dup empty? [ drop ] [ where-clause ] if ";" 0%
+ ] sqlite-make ;
-: sqlite-db-modifiers ( -- hashtable )
+M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +not-null+ "not null" }
} ;
-M: sqlite-db sql-modifiers* ( modifiers -- str )
- sqlite-db-modifiers swap [
- dup array? [
- first2
- >r swap at r> number>string*
- " " swap 3append
- ] [
- swap at
- ] if
- ] with map [ ] subset ;
-
-: sqlite-type-hash ( -- assoc )
+M: sqlite-db compound-modifier ( str obj -- newstr )
+ compound-type ;
+
+M: sqlite-db compound-type ( str seq -- newstr )
+ over {
+ { "default" [ first number>string join-space ] }
+ [ 2drop ] ! "no sqlite compound data type" 3array throw ]
+ } case ;
+
+M: sqlite-db type-table ( -- assoc )
H{
+ { +native-id+ "integer primary key" }
{ INTEGER "integer" }
- { SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
+ { DATE "date" }
+ { TIME "time" }
+ { DATETIME "datetime" }
+ { TIMESTAMP "timestamp" }
{ DOUBLE "real" }
+ { BLOB "blob" }
+ { FACTOR-BLOB "blob" }
} ;
-M: sqlite-db >sql-type ( obj -- str )
- dup pair? [
- first >sql-type
- ] [
- sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
- ] if ;
-
-! HOOK: get-column-value ( n result-set type -- )
-! M: sqlite get-column-value { { "TEXT" get-text-column } {
-! "INTEGER" get-integer-column } ... } case ;
+M: sqlite-db create-type-table
+ type-table ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.sqlite db.tuples
-db.types continuations namespaces db.postgresql math ;
-! tools.time ;
-IN: temporary
+USING: io.files kernel tools.test db db.tuples
+db.types continuations namespaces math
+prettyprint tools.walker db.sqlite calendar
+math.intervals db.postgresql ;
+IN: db.tuples.tests
-TUPLE: person the-id the-name the-number real ;
-: <person> ( name age real -- person )
+TUPLE: person the-id the-name the-number the-real
+ts date time blob factor-blob ;
+
+: <person> ( name age real ts date time blob -- person )
{
set-person-the-name
set-person-the-number
- set-person-real
+ set-person-the-real
+ set-person-ts
+ set-person-date
+ set-person-time
+ set-person-blob
+ set-person-factor-blob
} person construct ;
-: <assigned-person> ( id name number real -- obj )
+: <assigned-person> ( id name age real ts date time blob factor-blob -- person )
<person> [ set-person-the-id ] keep ;
-SYMBOL: the-person
+SYMBOL: person1
+SYMBOL: person2
+SYMBOL: person3
+SYMBOL: person4
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
+ [ person create-table ] must-fail
- [ ] [ the-person get insert-tuple ] unit-test
+ [ ] [ person1 get insert-tuple ] unit-test
+
+ [ 1 ] [ person1 get person-the-id ] unit-test
+
+ 200 person1 get set-person-the-number
+
+ [ ] [ person1 get update-tuple ] unit-test
+
+ [ T{ person f 1 "billy" 200 3.14 } ]
+ [ T{ person f 1 } select-tuple ] unit-test
+ [ ] [ person2 get insert-tuple ] unit-test
+ [
+ {
+ T{ person f 1 "billy" 200 3.14 }
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
+ [
+ {
+ T{ person f 1 "billy" 200 3.14 }
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f } select-tuples ] unit-test
+
+ [
+ {
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
+
+
+ [ ] [ person1 get delete-tuple ] unit-test
+ [ f ] [ T{ person f 1 } select-tuple ] unit-test
+
+ [ ] [ person3 get insert-tuple ] unit-test
+
+ [
+ T{
+ person
+ f
+ 3
+ "teddy"
+ 10
+ 3.14
+ T{ timestamp f 2008 3 5 16 24 11 0 }
+ T{ timestamp f 2008 11 22 f f f f }
+ T{ timestamp f f f f 12 34 56 f }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+ }
+ ] [ T{ person f 3 } select-tuple ] unit-test
+
+ [ ] [ person4 get insert-tuple ] unit-test
+ [
+ T{
+ person
+ f
+ 4
+ "eddie"
+ 10
+ 3.14
+ T{ timestamp f 2008 3 5 16 24 11 0 }
+ T{ timestamp f 2008 11 22 f f f f }
+ T{ timestamp f f f f 12 34 56 f }
+ f
+ H{ { 1 2 } { 3 4 } { 5 "lol" } }
+ }
+ ] [ T{ person f 4 } select-tuple ] unit-test
+
+ [ ] [ person drop-table ] unit-test ;
+
+: make-native-person-table ( -- )
+ [ person drop-table ] [ drop ] recover
+ person create-table
+ T{ person f f "billy" 200 3.14 } insert-tuple
+ T{ person f f "johnny" 10 3.14 } insert-tuple
+ ;
+
+: native-person-schema ( -- )
+ person "PERSON"
+ {
+ { "the-id" "ID" +native-id+ }
+ { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "the-number" "AGE" INTEGER { +default+ 0 } }
+ { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+ { "ts" "TS" TIMESTAMP }
+ { "date" "D" DATE }
+ { "time" "T" TIME }
+ { "blob" "B" BLOB }
+ { "factor-blob" "FB" FACTOR-BLOB }
+ } define-persistent
+ "billy" 10 3.14 f f f f f <person> person1 set
+ "johnny" 10 3.14 f f f f f <person> person2 set
+ "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
+ "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
+
+: assigned-person-schema ( -- )
+ person "PERSON"
+ {
+ { "the-id" "ID" INTEGER +assigned-id+ }
+ { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "the-number" "AGE" INTEGER { +default+ 0 } }
+ { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+ { "ts" "TS" TIMESTAMP }
+ { "date" "D" DATE }
+ { "time" "T" TIME }
+ { "blob" "B" BLOB }
+ { "factor-blob" "FB" FACTOR-BLOB }
+ } define-persistent
+ 1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
+ 2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
+ 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <assigned-person> person3 set
+ 4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
+
+TUPLE: paste n summary author channel mode contents timestamp annotations ;
+TUPLE: annotation n paste-id summary author mode contents ;
+
+: native-paste-schema ( -- )
+ paste "PASTE"
+ {
+ { "n" "ID" +native-id+ }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "channel" "CHANNEL" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ { "date" "DATE" TIMESTAMP }
+ { "annotations" { +has-many+ annotation } }
+ } define-persistent
+
+ annotation "ANNOTATION"
+ {
+ { "n" "ID" +native-id+ }
+ { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
+ { "summary" "SUMMARY" TEXT }
+ { "author" "AUTHOR" TEXT }
+ { "mode" "MODE" TEXT }
+ { "contents" "CONTENTS" TEXT }
+ } define-persistent ;
+
+! { "localhost" "postgres" "" "factor-test" } postgresql-db [
+ ! [ paste drop-table ] [ drop ] recover
+ ! [ annotation drop-table ] [ drop ] recover
+ ! [ paste drop-table ] [ drop ] recover
+ ! [ annotation drop-table ] [ drop ] recover
+ ! [ ] [ paste create-table ] unit-test
+ ! [ ] [ annotation create-table ] unit-test
+! ] with-db
+
+: test-sqlite ( quot -- )
+ >r "tuples-test.db" temp-file sqlite-db r> with-db ;
- [ 1 ] [ the-person get person-the-id ] unit-test
+: test-postgresql ( -- )
+>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
+
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
- 200 the-person get set-person-the-number
+[ native-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-tuples ] test-postgresql
- [ ] [ the-person get update-tuple ] unit-test
+TUPLE: serialize-me id data ;
- [ ] [ the-person get delete-tuple ] unit-test
- ; ! 1 [ ] [ person drop-table ] unit-test ;
+: test-serialize ( -- )
+ serialize-me "SERIALIZED"
+ {
+ { "id" "ID" +native-id+ }
+ { "data" "DATA" FACTOR-BLOB }
+ } define-persistent
+ [ serialize-me drop-table ] [ drop ] recover
+ [ ] [ serialize-me create-table ] unit-test
-: test-sqlite ( -- )
- "tuples-test.db" resource-path <sqlite-db> [
- test-tuples
- ] with-db ;
+ [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
+ [
+ { T{ serialize-me f 1 H{ { 1 2 } } } }
+ ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
-: test-postgresql ( -- )
- "localhost" "postgres" "" "factor-test" <postgresql-db> [
- test-tuples
- ] with-db ;
-
-person "PERSON"
-{
- { "the-id" "ID" SERIAL +native-id+ }
- { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
- { "the-number" "AGE" INTEGER { +default+ 0 } }
- { "real" "REAL" DOUBLE { +default+ 0.3 } }
-} define-persistent
-
-"billy" 10 3.14 <person> the-person set
-
-! test-sqlite
- test-postgresql
-
-! person "PERSON"
-! {
- ! { "the-id" "ID" INTEGER +assigned-id+ }
- ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
- ! { "the-number" "AGE" INTEGER { +default+ 0 } }
- ! { "real" "REAL" DOUBLE { +default+ 0.3 } }
-! } define-persistent
-
-! 1 "billy" 20 6.28 <assigned-person> the-person set
-
-! test-sqlite
-! test-postgresql
+[ test-serialize ] test-sqlite
+[ test-serialize ] test-postgresql
+
+TUPLE: exam id name score ;
+
+: test-ranges ( -- )
+ exam "EXAM"
+ {
+ { "id" "ID" +native-id+ }
+ { "name" "NAME" TEXT }
+ { "score" "SCORE" INTEGER }
+ } define-persistent
+ [ exam drop-table ] [ drop ] recover
+ [ ] [ exam create-table ] unit-test
+
+ [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+
+ [
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
+ ;
+
+! [ test-ranges ] test-sqlite
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
-tuples words sequences slots slots.private math
-math.parser io prettyprint db.types continuations ;
+tuples words sequences slots math
+math.parser io prettyprint db.types continuations
+mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
-: db-columns ( class -- obj ) "db-columns" word-prop ;
-: db-table ( class -- obj ) "db-table" word-prop ;
-
-TUPLE: no-slot-named ;
-: no-slot-named ( -- * ) T{ no-slot-named } throw ;
-
-: slot-spec-named ( str class -- slot-spec )
- "slots" word-prop [ slot-spec-name = ] with find nip
- [ no-slot-named ] unless* ;
-
-: offset-of-slot ( str obj -- n )
- class slot-spec-named slot-spec-offset ;
-
-: get-slot-named ( str obj -- value )
- tuck offset-of-slot [ no-slot-named ] unless* slot ;
-
-: set-slot-named ( value str obj -- )
- tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
-
-: primary-key-spec ( class -- spec )
- db-columns [ primary-key? ] find nip ;
-
-: primary-key ( tuple -- obj )
- dup class primary-key-spec get-slot-named ;
-
-: set-primary-key ( obj tuple -- )
- [ class primary-key-spec first ] keep
- set-slot-named ;
-
-: cache-statement ( columns class assoc quot -- statement )
- [ db-table dupd ] swap
- [ <prepared-statement> ] 3compose cache nip ; inline
-
-HOOK: create-sql db ( columns table -- seq )
-HOOK: drop-sql db ( columns table -- seq )
-
-HOOK: insert-sql* db ( columns table -- slot-names sql )
-HOOK: update-sql* db ( columns table -- slot-names sql )
-HOOK: delete-sql* db ( columns table -- slot-names sql )
-HOOK: select-sql db ( tuple -- statement )
-
-HOOK: row-column-typed db ( result-set n type -- sql )
-HOOK: sql-type>factor-type db ( obj type -- obj )
-HOOK: tuple>params db ( columns tuple -- obj )
-
-
-HOOK: make-slot-names* db ( quot -- seq )
-HOOK: column-slot-name% db ( spec -- )
-HOOK: column-bind-name% db ( spec -- )
-
-: make-slots-names ( quot -- seq str )
- [ make-slot-names* ] "" make ; inline
-: slot-name% ( seq -- ) first % ;
-: column-name% ( seq -- ) second % ;
-: column-type% ( seq -- ) third % ;
-
-: insert-sql ( columns class -- statement )
- db get db-insert-statements [ insert-sql* ] cache-statement ;
-
-: update-sql ( columns class -- statement )
- db get db-update-statements [ update-sql* ] cache-statement ;
+: define-persistent ( class table columns -- )
+ >r dupd "db-table" set-word-prop dup r>
+ [ relation? ] partition swapd
+ dupd [ spec>tuple ] with map
+ "db-columns" set-word-prop
+ "db-relations" set-word-prop ;
-: delete-sql ( columns class -- statement )
- db get db-delete-statements [ delete-sql* ] cache-statement ;
+: db-table ( class -- obj ) "db-table" word-prop ;
+: db-columns ( class -- obj ) "db-columns" word-prop ;
+: db-relations ( class -- obj ) "db-relations" word-prop ;
+: set-primary-key ( key tuple -- )
+ [
+ class db-columns find-primary-key sql-spec-slot-name
+ ] keep set-slot-named ;
+
+! returns a sequence of prepared-statements
+HOOK: create-sql-statement db ( class -- obj )
+HOOK: drop-sql-statement db ( class -- obj )
+
+HOOK: <insert-native-statement> db ( class -- obj )
+HOOK: <insert-assigned-statement> db ( class -- obj )
+
+HOOK: <update-tuple-statement> db ( class -- obj )
+HOOK: <update-tuples-statement> db ( class -- obj )
+
+HOOK: <delete-tuple-statement> db ( class -- obj )
+HOOK: <delete-tuples-statement> db ( class -- obj )
+
+HOOK: <select-by-slots-statement> db ( tuple -- tuple )
+
+HOOK: insert-tuple* db ( tuple statement -- )
+
+: resulting-tuple ( row out-params -- tuple )
+ dup first sql-spec-class construct-empty [
+ [
+ >r sql-spec-slot-name r> set-slot-named
+ ] curry 2each
+ ] keep ;
+
+: query-tuples ( statement -- seq )
+ [ statement-out-params ] keep query-results [
+ [ sql-row-typed swap resulting-tuple ] with query-map
+ ] with-disposal ;
+
+: query-modify-tuple ( tuple statement -- )
+ [ query-results [ sql-row-typed ] with-disposal ] keep
+ statement-out-params rot [
+ >r sql-spec-slot-name r> set-slot-named
+ ] curry 2each ;
+
+: sql-props ( class -- columns table )
+ dup db-columns swap db-table ;
+
+: with-disposals ( seq quot -- )
+ over sequence? [
+ [ with-disposal ] curry each
+ ] [
+ with-disposal
+ ] if ;
-: tuple-statement ( columns tuple quot -- statement )
- >r [ tuple>params ] 2keep class r> call
- 2dup . .
- [ bind-statement ] keep ;
+: create-table ( class -- )
+ create-sql-statement [ execute-statement ] with-disposals ;
-: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
- >r [ class db-columns ] swap compose keep
- r> tuple-statement ;
+: drop-table ( class -- )
+ drop-sql-statement [ execute-statement ] with-disposals ;
-: do-tuple-statement ( tuple columns-quot statement-quot -- )
- make-tuple-statement execute-statement ;
+: insert-native ( tuple -- )
+ dup class
+ db get db-insert-statements [ <insert-native-statement> ] cache
+ [ bind-tuple ] 2keep insert-tuple* ;
-: create-table ( class -- )
- dup db-columns swap db-table create-sql sql-command ;
-
-: drop-table ( class -- )
- dup db-columns swap db-table drop-sql sql-command ;
+: insert-assigned ( tuple -- )
+ dup class
+ db get db-insert-statements [ <insert-assigned-statement> ] cache
+ [ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
- [
- [ maybe-remove-id ] [ insert-sql ]
- make-tuple-statement insert-statement
- ] keep set-primary-key ;
+ dup class db-columns find-primary-key assigned-id? [
+ insert-assigned
+ ] [
+ insert-native
+ ] if ;
: update-tuple ( tuple -- )
- [ ] [ update-sql ] do-tuple-statement ;
+ dup class
+ db get db-update-statements [ <update-tuple-statement> ] cache
+ [ bind-tuple ] keep execute-statement ;
: delete-tuple ( tuple -- )
- [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
+ dup class
+ db get db-delete-statements [ <delete-tuple-statement> ] cache
+ [ bind-tuple ] keep execute-statement ;
-: select-tuple ( tuple -- )
- [ select-sql ] keep do-query ;
-
-: persist ( tuple -- )
- dup primary-key [ update-tuple ] [ insert-tuple ] if ;
-
-: define-persistent ( class table columns -- )
- >r dupd "db-table" set-word-prop r>
- "db-columns" set-word-prop ;
+: select-tuples ( tuple -- tuples )
+ dup dup class <select-by-slots-statement> [
+ [ bind-tuple ] keep query-tuples
+ ] with-disposal ;
-: define-relation ( spec -- )
- drop ;
+: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
-sequences continuations ;
+sequences continuations sequences.deep sequences.lib
+words namespaces tools.walker slots slots.private classes
+mirrors tuples combinators calendar.format symbols ;
IN: db.types
-! ID is the Primary key
-SYMBOL: +native-id+
-SYMBOL: +assigned-id+
+HOOK: modifier-table db ( -- hash )
+HOOK: compound-modifier db ( str seq -- hash )
+HOOK: type-table db ( -- hash )
+HOOK: create-type-table db ( -- hash )
+HOOK: compound-type db ( str n -- hash )
-: primary-key? ( spec -- ? )
- [ { +native-id+ +assigned-id+ } member? ] contains? ;
-
-: contains-id? ( columns id -- ? )
- swap [ member? ] with contains? ;
-
-: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
-: native-id? ( columns -- ? ) +native-id+ contains-id? ;
-
-! Same concept, SQLite has autoincrement, PostgreSQL has serial
-SYMBOL: +autoincrement+
-SYMBOL: +serial+
-SYMBOL: +unique+
-
-SYMBOL: +default+
-SYMBOL: +null+
-SYMBOL: +not-null+
-
-SYMBOL: +has-many+
+TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
-SYMBOL: SERIAL
-SYMBOL: INTEGER
-SYMBOL: DOUBLE
-SYMBOL: BOOLEAN
+SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
++serial+ +unique+ +default+ +null+ +not-null+
++foreign-id+ +has-many+ ;
-SYMBOL: TEXT
-SYMBOL: VARCHAR
+: (primary-key?) ( obj -- ? )
+ { +native-id+ +assigned-id+ } member? ;
-SYMBOL: TIMESTAMP
-SYMBOL: DATE
-
-SYMBOL: BIG_INTEGER
+: primary-key? ( spec -- ? )
+ sql-spec-primary-key (primary-key?) ;
+
+: normalize-spec ( spec -- )
+ dup sql-spec-type dup (primary-key?) [
+ swap set-sql-spec-primary-key
+ ] [
+ drop dup sql-spec-modifiers [
+ (primary-key?)
+ ] deep-find
+ [ swap set-sql-spec-primary-key ] [ drop ] if*
+ ] if ;
+
+: find-primary-key ( specs -- obj )
+ [ sql-spec-primary-key ] find nip ;
+
+: native-id? ( spec -- ? )
+ sql-spec-primary-key +native-id+ = ;
+
+: assigned-id? ( spec -- ? )
+ sql-spec-primary-key +assigned-id+ = ;
+
+: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
+
+SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
+DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
+
+: spec>tuple ( class spec -- tuple )
+ [ ?first3 ] keep 3 ?tail*
+ {
+ set-sql-spec-class
+ set-sql-spec-slot-name
+ set-sql-spec-column-name
+ set-sql-spec-type
+ set-sql-spec-modifiers
+ } sql-spec construct
+ dup normalize-spec ;
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-HOOK: sql-modifiers* db ( modifiers -- str )
-HOOK: >sql-type db ( obj -- str )
-
-! HOOK: >factor-type db ( obj -- obj )
+TUPLE: no-sql-modifier ;
+: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
-: maybe-remove-id ( columns -- obj )
- [ +native-id+ swap member? not ] subset ;
+: maybe-remove-id ( specs -- obj )
+ [ native-id? not ] subset ;
-: remove-id ( columns -- obj )
- [ primary-key? not ] subset ;
+: remove-relations ( specs -- newcolumns )
+ [ relation? not ] subset ;
-: sql-modifiers ( spec -- seq )
- 3 tail sql-modifiers* ;
+: remove-id ( specs -- obj )
+ [ sql-spec-primary-key not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+: lookup-modifier ( obj -- str )
+ dup array? [
+ unclip lookup-modifier swap compound-modifier
+ ] [
+ modifier-table at*
+ [ "unknown modifier" throw ] unless
+ ] if ;
+
+: lookup-type* ( obj -- str )
+ dup array? [
+ first lookup-type*
+ ] [
+ type-table at*
+ [ no-sql-type ] unless
+ ] if ;
+
+: lookup-create-type ( obj -- str )
+ dup array? [
+ unclip lookup-create-type swap compound-type
+ ] [
+ dup create-type-table at*
+ [ nip ] [ drop lookup-type* ] if
+ ] if ;
+
+: lookup-type ( obj create? -- str )
+ [ lookup-create-type ] [ lookup-type* ] if ;
+
+: single-quote ( str -- newstr )
+ "'" swap "'" 3append ;
+
+: double-quote ( str -- newstr )
+ "\"" swap "\"" 3append ;
+
+: paren ( str -- newstr )
+ "(" swap ")" 3append ;
+
+: join-space ( str1 str2 -- newstr )
+ " " swap 3append ;
+
+: modifiers ( spec -- str )
+ sql-spec-modifiers
+ [ lookup-modifier ] map " " join
+ dup empty? [ " " swap append ] unless ;
+
+HOOK: bind% db ( spec -- )
+
+TUPLE: no-slot-named ;
+: no-slot-named ( -- * ) T{ no-slot-named } throw ;
+
+: slot-spec-named ( str class -- slot-spec )
+ "slots" word-prop [ slot-spec-name = ] with find nip
+ [ no-slot-named ] unless* ;
+
+: offset-of-slot ( str obj -- n )
+ class slot-spec-named slot-spec-offset ;
+
+: get-slot-named ( str obj -- value )
+ tuck offset-of-slot [ no-slot-named ] unless* slot ;
+
+: set-slot-named ( value str obj -- )
+ tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+
+: tuple>filled-slots ( tuple -- alist )
+ dup <mirror> mirror-slots [ slot-spec-name ] map
+ swap tuple-slots 2array flip [ nip ] assoc-subset ;
+
+: tuple>params ( specs tuple -- obj )
+ [
+ >r dup sql-spec-type swap sql-spec-slot-name r>
+ get-slot-named swap
+ ] curry { } map>assoc ;
USING: delegate kernel arrays tools.test ;
-IN: temporary
+IN: delegate.tests
TUPLE: hello this that ;
C: <hello> hello
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
- [ method-def spin define-method ] [ 3drop ] if
+ [ "method-def" word-prop spin define-method ]
+ [ 3drop ] if
] 2curry each ;
: MIMIC:
-USING: help.markup help.syntax libc kernel ;
+USING: help.markup help.syntax libc kernel continuations ;
IN: destructors
HELP: free-always
HELP: with-destructors
{ $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc free-always ] with-destructors" }
USING: destructors kernel tools.test continuations ;
-IN: temporary
+IN: destructors.tests
TUPLE: dummy-obj destroyed? ;
C: <dummy-destructor> dummy-destructor
-M: dummy-destructor destruct ( obj -- )
+M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always
sequences system vectors ;
IN: destructors
-GENERIC: destruct ( obj -- )
-
SYMBOL: error-destructors
SYMBOL: always-destructors
TUPLE: destructor object destroyed? ;
-M: destructor destruct
+M: destructor dispose
dup destructor-destroyed? [
drop
] [
- dup destructor-object destruct
+ dup destructor-object dispose
t swap set-destructor-destroyed?
] if ;
<destructor> always-destructors get push ;
: do-always-destructors ( -- )
- always-destructors get [ destruct ] each ;
+ always-destructors get [ dispose ] each ;
: do-error-destructors ( -- )
- error-destructors get [ destruct ] each ;
+ error-destructors get [ dispose ] each ;
: with-destructors ( quot -- )
[
C: <memory-destructor> memory-destructor
-M: memory-destructor destruct ( obj -- )
+M: memory-destructor dispose ( obj -- )
memory-destructor-alien free ;
: free-always ( alien -- )
HOOK: destruct-handle io-backend ( obj -- )
-M: handle-destructor destruct ( obj -- )
+M: handle-destructor dispose ( obj -- )
handle-destructor-alien destruct-handle ;
: close-always ( handle -- )
HOOK: destruct-socket io-backend ( obj -- )
-M: socket-destructor destruct ( obj -- )
+M: socket-destructor dispose ( obj -- )
socket-destructor-alien destruct-socket ;
: close-socket-always ( handle -- )
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: digraphs kernel sequences tools.test ;
+IN: digraphs.tests
+
+: test-digraph ( -- digraph )
+ <digraph>
+ { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each
+ { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ;
+
+[ 5 ] [ test-digraph topological-sort length ] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel new-slots sequences vectors ;
+IN: digraphs
+
+TUPLE: digraph ;
+TUPLE: vertex value edges ;
+
+: <digraph> ( -- digraph )
+ digraph construct-empty H{ } clone over set-delegate ;
+
+: <vertex> ( value -- vertex )
+ V{ } clone vertex construct-boa ;
+
+: add-vertex ( key value digraph -- )
+ >r <vertex> swap r> set-at ;
+
+: children ( key digraph -- seq )
+ at edges>> ;
+
+: @edges ( from to digraph -- to edges ) swapd at edges>> ;
+: add-edge ( from to digraph -- ) @edges push ;
+: delete-edge ( from to digraph -- ) @edges delete ;
+
+: delete-to-edges ( to digraph -- )
+ [ nip dupd edges>> delete ] assoc-each drop ;
+
+: delete-vertex ( key digraph -- )
+ 2dup delete-at delete-to-edges ;
+
+: unvisited? ( unvisited key -- ? ) swap key? ;
+: visited ( unvisited key -- ) swap delete-at ;
+
+DEFER: (topological-sort)
+: visit-children ( seq unvisited key -- seq unvisited )
+ over children [ (topological-sort) ] each ;
+
+: (topological-sort) ( seq unvisited key -- seq unvisited )
+ 2dup unvisited? [
+ [ visit-children ] keep 2dup visited pick push
+ ] [
+ drop
+ ] if ;
+
+: topological-sort ( digraph -- seq )
+ dup clone V{ } clone spin
+ [ drop (topological-sort) ] assoc-each drop reverse ;
+
+: topological-sorted-values ( digraph -- seq )
+ dup topological-sort swap [ at value>> ] curry map ;
--- /dev/null
+Simple directed graph implementation for topological sorting
-IN: temporary
+IN: documents.tests
USING: documents namespaces tools.test ;
! Tests
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel math models namespaces sequences strings
-splitting io.streams.lines combinators unicode.categories ;
+splitting combinators unicode.categories ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;
+: edit-vocab ( name -- )
+ vocab-source-path 1 edit-location ;
+
: :edit ( -- )
error get delegates [ parse-error? ] find-last nip [
dup parse-error-file source-file-path ?resource-path
: fix ( word -- )
"Fixing " write dup pprint " and all usages..." print nl
- dup smart-usage swap add* [
+ dup usage swap add* [
"Editing " write dup .
"RETURN moves on to the next usage, C+d stops." print
flush
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+
- [ >lower "editpadpro.exe" tail? ] find-file-breadth
+ t [ >lower "editpadpro.exe" tail? ] find-file
] unless* ;
: editpadpro ( file line -- )
M: windows-io gvim-path
\ gvim-path get-global [
program-files "vim" path+
- [ "gvim.exe" tail? ] find-file-breadth
+ t [ "gvim.exe" tail? ] find-file
] unless* ;
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions io kernel math
namespaces parser prettyprint sequences strings words
-editors io.files io.sockets io.streams.string io.binary
-math.parser ;
+editors io.files io.sockets io.streams.byte-array io.binary
+math.parser io.encodings.ascii io.encodings.binary
+io.encodings.utf8 ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
- home "/.jedit/server" path+ [
+ home "/.jedit/server" path+ ascii [
readln drop
readln string>number
readln string>number
] with-file-reader ;
: make-jedit-request ( files -- code )
- [
+ utf8 [
"EditServer.handleClient(false,false,false," write
cwd pprint
"," write
"new String[] {" write
[ pprint "," write ] each
"null});\n" write
- ] with-string-writer ;
+ ] with-byte-writer ;
: send-jedit-request ( request -- )
- jedit-server-info swap "localhost" swap <inet> <client> [
+ jedit-server-info "localhost" rot <inet> binary <client> [
4 >be write
dup length 2 >be write
write
{ { "Emacs" [ "emacs &" system drop ] }
{ "KMail" [ "kmail &" system drop ] }
{ "Akregator" [ "akregator &" system drop ] }
- { "Amarok" [ "amarok &" system drop ] }
- { "K3b" [ "k3b &" system drop ] }
- { "xchat" [ "xchat &" system drop ] }
+ { "Amarok" [ "amarok &" system drop ] }
+ { "K3b" [ "k3b &" system drop ] }
+ { "xchat" [ "xchat &" system drop ] }
{ "Nautilus" [ "nautilus --no-desktop &" system drop ] }
- { "synaptic" [ "gksudo synaptic &" system drop ] }
+ { "synaptic" [ "gksudo synaptic &" system drop ] }
{ "Volume control" [ "gnome-volume-control &" system drop ] }
{ "Azureus" [ "~/azureus/azureus &" system drop ] }
- { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
+ { "Xephyr" [ "Xephyr -host-cursor :1 &" system drop ] }
{ "Stop Xephyr" [ "pkill Xephyr &" system drop ] }
{ "Stop Firefox" [ "pkill firefox &" system drop ] }
} apps-menu> set-menu-items
{ { "Maximize" [ maximize ] }
{ "Maximize Vertical" [ maximize-vertical ] }
{ "Restore" [ restore ] }
- { "Hide" [ minimize ] }
- { "Tile Master" [ tile-master ] }
+ { "Hide" [ minimize ] }
+ { "Tile Master" [ tile-master ] }
}
factory-menu> set-menu-items
! VAR: root-menu
{ { "xterm" [ "urxvt -bd grey +sb &" system drop ] }
- { "Firefox" [ "firefox &" system drop ] }
- { "xclock" [ "xclock &" system drop ] }
- { "Apps >" [ apps-menu> <- popup ] }
+ { "Firefox" [ "firefox &" system drop ] }
+ { "xclock" [ "xclock &" system drop ] }
+ { "Apps >" [ apps-menu> <- popup ] }
{ "Factor >" [ factor-menu> <- popup ] }
{ "Unmapped frames >" [ unmapped-frames-menu> <- popup ] }
- { "Emacs >" [ emacs-menu> <- popup ] }
- { "Mail >" [ mail-menu> <- popup ] }
- { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
- system drop ] }
- { "Edit menus" [ edit-factory-menus ] }
+ { "Emacs >" [ emacs-menu> <- popup ] }
+ { "Mail >" [ mail-menu> <- popup ] }
+ { "onigirihouse" [ "xterm -e 'ssh dharmatech@onigirihouse.com' &"
+ system drop ] }
+ { "Edit menus" [ edit-factory-menus ] }
{ "Reload menus" [ load-factory-menus ] }
- { "Factory >" [ factory-menu> <- popup ] }
+ { "Factory >" [ factory-menu> <- popup ] }
} root-menu> set-menu-items
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax ;
+IN: farkup
+
+HELP: convert-farkup
+{ $values { "string" "a string" } { "string'" "a string" } }
+{ $description "Parse a string as farkup (Factor mARKUP) and output the result aas an string of HTML." } ;
--- /dev/null
+USING: farkup kernel tools.test ;
+IN: farkup.tests
+
+[ "<ul><li>foo</li></ul>" ] [ "-foo" convert-farkup ] unit-test
+[ "<ul><li>foo</li></ul>\n" ] [ "-foo\n" convert-farkup ] unit-test
+[ "<ul><li>foo</li><li>bar</li></ul>" ] [ "-foo\n-bar" convert-farkup ] unit-test
+[ "<ul><li>foo</li><li>bar</li></ul>\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test
+
+[ "<ul><li>foo</li></ul>\n<p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
+[ "<p>*foo\nbar\n</p>" ] [ "*foo\nbar\n" convert-farkup ] unit-test
+[ "<p><strong>Wow!</strong></p>" ] [ "*Wow!*" convert-farkup ] unit-test
+[ "<p><em>Wow.</em></p>" ] [ "_Wow._" convert-farkup ] unit-test
+
+[ "<p>*</p>" ] [ "*" convert-farkup ] unit-test
+[ "<p>*</p>" ] [ "\\*" convert-farkup ] unit-test
+[ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
+
+[ "" ] [ "\n\n" convert-farkup ] unit-test
+[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
+
+[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
+
+[ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
+
+[ "" ] [ "" convert-farkup ] unit-test
+
+[ "<p>|a</p>" ]
+[ "|a" convert-farkup ] unit-test
+
+[ "<p>|a|</p>" ]
+[ "|a|" convert-farkup ] unit-test
+
+[ "<table><tr><td>a</td><td>b</td></tr></table>" ]
+[ "a|b" convert-farkup ] unit-test
+
+[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>" ]
+[ "a|b\nc|d" convert-farkup ] unit-test
+
+[ "<table><tr><td>a</td><td>b</td></tr></table>\n<table><tr><td>c</td><td>d</td></tr></table>\n" ]
+[ "a|b\nc|d\n" convert-farkup ] unit-test
+
+[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
+[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
+
+[ "<h1>foo</h1>\n" ] [ "=foo=\n" convert-farkup ] unit-test
+[ "<p>lol</p><h1>foo</h1>\n" ] [ "lol=foo=\n" convert-farkup ] unit-test
+[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
+[ "<p>=foo</p>" ] [ "=foo" convert-farkup ] unit-test
+[ "<p>==foo</p>" ] [ "==foo" convert-farkup ] unit-test
+[ "<p>=</p><h1>foo</h1>" ] [ "==foo=" convert-farkup ] unit-test
+[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
+[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
+[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
+
+
+[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
+
--- /dev/null
+! 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 ;
+IN: farkup
+
+: delimiters ( -- string )
+ "*_^~%[-=|\\\n" ; inline
+
+MEMO: text ( -- parser )
+ [ delimiters member? not ] satisfy repeat1
+ [ >string escape-string ] action ;
+
+MEMO: delimiter ( -- parser )
+ [ dup delimiters member? swap "\n=" member? not and ] satisfy
+ [ 1string ] action ;
+
+: surround-with-foo ( string tag -- seq )
+ dup <foo> swap </foo> swapd 3array ;
+
+: delimited ( str html -- parser )
+ [
+ over token hide ,
+ text [ surround-with-foo ] swapd curry action ,
+ token hide ,
+ ] seq* ;
+
+MEMO: escaped-char ( -- parser )
+ [ "\\" token hide , any-char , ] seq* [ >string ] action ;
+
+MEMO: strong ( -- parser ) "*" "strong" delimited ;
+MEMO: emphasis ( -- parser ) "_" "em" delimited ;
+MEMO: superscript ( -- parser ) "^" "sup" delimited ;
+MEMO: subscript ( -- parser ) "~" "sub" delimited ;
+MEMO: inline-code ( -- parser ) "%" "code" delimited ;
+MEMO: nl ( -- parser ) "\n" token ;
+MEMO: 2nl ( -- parser ) "\n\n" token hide ;
+MEMO: h1 ( -- parser ) "=" "h1" delimited ;
+MEMO: h2 ( -- parser ) "==" "h2" delimited ;
+MEMO: h3 ( -- parser ) "===" "h3" delimited ;
+MEMO: h4 ( -- parser ) "====" "h4" delimited ;
+
+MEMO: eq ( -- parser )
+ [
+ h1 ensure-not ,
+ h2 ensure-not ,
+ h3 ensure-not ,
+ h4 ensure-not ,
+ "=" token ,
+ ] seq* ;
+
+: render-code ( string mode -- string' )
+ >r string-lines r>
+ [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+
+: make-link ( href text -- seq )
+ >r escape-quoted-string r> escape-string
+ [ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
+
+MEMO: simple-link ( -- parser )
+ [
+ "[[" token hide ,
+ [ "|]" member? not ] satisfy repeat1 ,
+ "]]" token hide ,
+ ] seq* [ first f make-link ] action ;
+
+MEMO: labelled-link ( -- parser )
+ [
+ "[[" token hide ,
+ [ CHAR: | = not ] satisfy repeat1 ,
+ "|" token hide ,
+ [ CHAR: ] = not ] satisfy repeat1 ,
+ "]]" token hide ,
+ ] seq* [ first2 make-link ] action ;
+
+MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ;
+
+DEFER: line
+MEMO: list-item ( -- parser )
+ [
+ "-" token hide , line ,
+ ] seq* [ "li" surround-with-foo ] action ;
+
+MEMO: list ( -- parser )
+ list-item "\n" token hide list-of
+ [ "ul" surround-with-foo ] action ;
+
+MEMO: table-column ( -- parser )
+ text [ "td" surround-with-foo ] action ;
+
+MEMO: table-row ( -- parser )
+ [
+ table-column "|" token hide list-of-many ,
+ ] seq* [ "tr" surround-with-foo ] action ;
+
+MEMO: table ( -- parser )
+ table-row repeat1 [ "table" surround-with-foo ] action ;
+
+MEMO: code ( -- parser )
+ [
+ "[" token hide ,
+ [ "{" member? not ] satisfy repeat1 optional [ >string ] action ,
+ "{" token hide ,
+ [
+ [ any-char , "}]" token ensure-not , ] seq*
+ repeat1 [ concat >string ] action ,
+ [ any-char , "}]" token hide , ] seq* optional [ >string ] action ,
+ ] seq* [ concat ] action ,
+ ] seq* [ first2 swap render-code ] action ;
+
+MEMO: line ( -- parser )
+ [
+ text , strong , emphasis , link ,
+ superscript , subscript , inline-code ,
+ escaped-char , delimiter , eq ,
+ ] choice* repeat1 ;
+
+MEMO: paragraph ( -- parser )
+ line
+ "\n" token over 2seq repeat0
+ "\n" token "\n" token ensure-not 2seq optional 3seq
+ [
+ dup [ dup string? not swap [ blank? ] all? or ] deep-all?
+ [ "<p>" swap "</p>" 3array ] unless
+ ] action ;
+
+PEG: parse-farkup ( -- parser )
+ [
+ list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
+ ] choice* repeat0 "\n" token optional 2seq ;
+
+: write-farkup ( parse-result -- )
+ [ dup string? [ write ] [ drop ] if ] deep-each ;
+
+: convert-farkup ( string -- string' )
+ parse-farkup [ write-farkup ] with-string-writer ;
--- /dev/null
+Simple markup language for generating HTML
! Copyright (C) 2006 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test peg fjsc ;
-IN: temporary
+IN: fjsc.tests
{ T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [
"55 2abc1 100" 'expression' parse parse-result-ast
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg strings promises sequences math math.parser
namespaces words quotations arrays hashtables io
- io.streams.string assocs memoize ascii ;
+ io.streams.string assocs memoize ascii peg.parsers ;
IN: fjsc
TUPLE: ast-number value ;
--- /dev/null
+Slava Pestov
+Eduardo Cavazos
--- /dev/null
+USING: help.markup help.syntax quotations kernel ;\r
+IN: fry\r
+\r
+HELP: ,\r
+{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ;\r
+\r
+HELP: @\r
+{ $description "Fry specifier. Splices a quotation into the fried quotation." } ;\r
+\r
+HELP: _\r
+{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ;\r
+\r
+HELP: fry\r
+{ $values { "quot" quotation } { "quot'" quotation } }\r
+{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }\r
+{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"\r
+ { $code "[ X ] fry call" "'[ X ]" }\r
+} ;\r
+\r
+HELP: '[\r
+{ $syntax "code... ]" }\r
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;\r
+\r
+ARTICLE: "fry.examples" "Examples of fried quotations"\r
+"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."\r
+$nl\r
+"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"\r
+{ $code "{ 10 20 30 } '[ . ] each" }\r
+"Occurrences of " { $link , } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"\r
+{ $code \r
+ "{ 10 20 30 } 5 '[ , + ] map"\r
+ "{ 10 20 30 } 5 [ + ] curry map"\r
+ "{ 10 20 30 } [ 5 + ] map"\r
+}\r
+"Occurrences of " { $link , } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"\r
+{ $code \r
+ "{ 10 20 30 } 5 '[ 3 , / ] map"\r
+ "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"\r
+ "{ 10 20 30 } [ 3 5 / ] map"\r
+}\r
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"\r
+{ $code \r
+ "{ 10 20 30 } [ sq ] '[ @ . ] map"\r
+ "{ 10 20 30 } [ sq ] [ . ] compose map"\r
+ "{ 10 20 30 } [ sq . ] map"\r
+}\r
+"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"\r
+{ $code\r
+ "{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map"\r
+ "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"\r
+ "{ 8 13 14 27 } [ even? dup 5 ? ] map"\r
+}\r
+"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"\r
+{ $code \r
+ "{ 10 20 30 } 1 '[ , _ / ] map"\r
+ "{ 10 20 30 } 1 [ swap / ] curry map"\r
+ "{ 10 20 30 } [ 1 swap / ] map"\r
+}\r
+"For any quotation body " { $snippet "X" } ", the following two are equivalent:"\r
+{ $code\r
+ "[ >r X r> ]"\r
+ "[ X _ ]"\r
+}\r
+"Here are some built-in combinators rewritten in terms of fried quotations:"\r
+{ $table\r
+ { { $link literalize } { $snippet ": literalize '[ , ] ;" } }\r
+ { { $link slip } { $snippet ": slip '[ @ , ] call ;" } }\r
+ { { $link dip } { $snippet ": dip '[ @ _ ] call ;" } }\r
+ { { $link curry } { $snippet ": curry '[ , @ ] ;" } }\r
+ { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }\r
+ { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
+ { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } }\r
+} ;\r
+\r
+ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
+"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."\r
+$nl\r
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
+{ $code\r
+ "'[ 3 , + 4 , / ]"\r
+ "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"\r
+}\r
+"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:"\r
+{ $code\r
+ "'[ , 2 + , * _ / ]"\r
+ "[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]"\r
+} ;\r
+\r
+ARTICLE: "fry.limitations" "Fried quotation limitations"\r
+"As with " { $link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". Unlike " { $link "locals" } ", using " { $link dip } " is not a suitable workaround since unlike closure conversion, fry conversion is not recursive, and so the quotation passed to " { $link dip } " cannot contain fry specifiers." ;\r
+\r
+ARTICLE: "fry" "Fried quotations"\r
+"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."\r
+$nl\r
+"Fried quotations are denoted with a special parsing word:"\r
+{ $subsection POSTPONE: '[ }\r
+"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"\r
+{ $subsection , }\r
+{ $subsection @ }\r
+{ $subsection _ }\r
+"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."\r
+{ $subsection "fry.examples" }\r
+{ $subsection "fry.philosophy" }\r
+{ $subsection "fry.limitations" }\r
+"Quotations can also be fried without using a parsing word:"\r
+{ $subsection fry } ;\r
+\r
+ABOUT: "fry"\r
--- /dev/null
+IN: fry.tests
+USING: fry tools.test math prettyprint kernel io arrays
+sequences ;
+
+[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
+
+[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
+
+[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
+
+[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
+
+[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+
+[ [ "a" write "b" print ] ]
+[ "a" "b" '[ , write , print ] ] unit-test
+
+[ [ 1 2 + 3 4 - ] ]
+[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
+
+[ 1/2 ] [
+ 1 '[ , _ / ] 2 swap call
+] unit-test
+
+[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
+ 1 '[ , _ _ 3array ]
+ { "a" "b" "c" } { "A" "B" "C" } rot 2map
+] unit-test
+
+[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
+ '[ 1 _ 2array ]
+ { "a" "b" "c" } swap map
+] unit-test
+
+[ 1 2 ] [
+ 1 2 '[ _ , ] call
+] unit-test
+
+[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
+ 1 2 '[ , _ , 3array ]
+ { "a" "b" "c" } swap map
+] unit-test
+
+: funny-dip '[ @ _ ] call ; inline
+
+[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences combinators parser splitting
+quotations arrays namespaces qualified ;
+QUALIFIED: namespaces
+IN: fry
+
+: , "Only valid inside a fry" throw ;
+: @ "Only valid inside a fry" throw ;
+: _ "Only valid inside a fry" throw ;
+
+DEFER: (fry)
+
+: ((fry)) ( accum quot adder -- result )
+ >r [ ] swap (fry) r>
+ append swap dup empty? [ drop ] [
+ [ swap compose ] curry append
+ ] if ; inline
+
+: (fry) ( accum quot -- result )
+ dup empty? [
+ drop 1quotation
+ ] [
+ unclip {
+ { , [ [ curry ] ((fry)) ] }
+ { @ [ [ compose ] ((fry)) ] }
+
+ ! to avoid confusion, remove if fry goes core
+ { namespaces:, [ [ curry ] ((fry)) ] }
+
+ [ swap >r add r> (fry) ]
+ } case
+ ] if ;
+
+: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
+
+: fry ( quot -- quot' )
+ { _ } last-split1 [
+ [
+ trivial-fry %
+ [ >r ] %
+ fry %
+ [ [ dip ] curry r> compose ] %
+ ] [ ] make
+ ] [
+ trivial-fry
+ ] if* ;
+
+: '[ \ ] parse-until fry over push-all ; parsing
--- /dev/null
+Syntax for pictured partial application and composition
--- /dev/null
+extensions
+++ /dev/null
-Slava Pestov
-Doug Coleman
+++ /dev/null
-USING: kernel sequences namespaces math tools.test furnace furnace.validator ;
-IN: temporary
-
-TUPLE: test-tuple m n ;
-
-[ H{ { "m" 3 } { "n" 2 } } ]
-[
- [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc
-] unit-test
-
-[
- { 3 }
-] [
- H{ { "n" "3" } } { { "n" v-number } }
- [ action-param drop ] with map
-] unit-test
-
-: foo ;
-
-\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action
-
-[ t ] [ [ 1 2 foo ] action-call? ] unit-test
-[ f ] [ [ 2 + ] action-call? ] unit-test
-
-[
- { "2" "hello" }
-] [
- [
- H{
- { "bar" "hello" }
- } \ foo query>seq
- ] with-scope
-] unit-test
-
-[
- H{ { "foo" "1" } { "bar" "2" } }
-] [
- { "1" "2" } \ foo quot>query
-] unit-test
-
-[
- "/responder/temporary/foo?foo=3"
-] [
- [
- [ "3" foo ] quot-link
- ] with-scope
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs calendar debugger furnace.sessions
-furnace.validator hashtables heaps html.elements http
-http.server.responders http.server.templating io.files kernel
-math namespaces quotations sequences splitting words strings
-vectors webapps.callback continuations tuples classes vocabs
-html io ;
-IN: furnace
-
-: code>quotation ( word/quot -- quot )
- dup word? [ 1quotation ] when ;
-
-SYMBOL: default-action
-SYMBOL: template-path
-
-: render-template ( template -- )
- template-path get swap path+
- ".furnace" append resource-path
- run-template-file ;
-
-: define-action ( word hash -- )
- over t "action" set-word-prop
- "action-params" set-word-prop ;
-
-: define-form ( word1 word2 hash -- )
- dupd define-action
- swap code>quotation "form-failed" set-word-prop ;
-
-: default-values ( word hash -- )
- "default-values" set-word-prop ;
-
-SYMBOL: request-params
-SYMBOL: current-action
-SYMBOL: validators-errored
-SYMBOL: validation-errors
-
-: action-link ( query action -- url )
- [
- "/responder/" %
- dup word-vocabulary "webapps." ?head drop %
- "/" %
- word-name %
- ] "" make swap build-url ;
-
-: action-param ( hash paramsepc -- obj error/f )
- unclip rot at swap >quotation apply-validators ;
-
-: query>seq ( hash word -- seq )
- "action-params" word-prop [
- dup first -rot
- action-param [
- t validators-errored >session
- rot validation-errors session> set-at
- ] [
- nip
- ] if*
- ] with map ;
-
-: expire-sessions ( -- )
- sessions get-global
- [ nip session-last-seen 20 minutes ago <=> 0 > ]
- [ 2drop ] heap-pop-while ;
-
-: lookup-session ( hash -- session )
- "furnace-session-id" over at sessions get-global at [
- nip
- ] [
- new-session rot "furnace-session-id" swap set-at
- ] if* ;
-
-: quot>query ( seq action -- hash )
- >r >array r> "action-params" word-prop
- [ first swap 2array ] 2map >hashtable ;
-
-PREDICATE: word action "action" word-prop ;
-
-: action-call? ( quot -- ? )
- >vector dup pop action? >r [ word? not ] all? r> and ;
-
-: unclip* dup 1 head* swap peek ;
-
-: quot-link ( quot -- url )
- dup action-call? [
- unclip* [ quot>query ] keep action-link
- ] [
- t register-html-callback
- ] if ;
-
-: replace-variables ( quot -- quot )
- [ dup string? [ request-params session> at ] when ] map ;
-
-: furnace-session-id ( -- hash )
- "furnace-session-id" request-params session> at
- "furnace-session-id" associate ;
-
-: redirect-to-action ( -- )
- current-action session>
- "form-failed" word-prop replace-variables
- quot-link furnace-session-id build-url permanent-redirect ;
-
-: if-form-page ( if then -- )
- current-action session> "form-failed" word-prop -rot if ;
-
-: do-action
- current-action session> [ query>seq ] keep add >quotation call ;
-
-: process-form ( -- )
- H{ } clone validation-errors >session
- request-params session> current-action session> query>seq
- validators-errored session> [
- drop redirect-to-action
- ] [
- current-action session> add >quotation call
- ] if ;
-
-: page-submitted ( -- )
- [ process-form ] [ request-params session> do-action ] if-form-page ;
-
-: action-first-time ( -- )
- request-params session> current-action session>
- [ "default-values" word-prop swap union request-params >session ] keep
- request-params session> do-action ;
-
-: page-not-submitted ( -- )
- [ redirect-to-action ] [ action-first-time ] if-form-page ;
-
-: setup-call-action ( hash word -- )
- over lookup-session session set
- current-action >session
- request-params session> swap union
- request-params >session
- f validators-errored >session ;
-
-: call-action ( hash word -- )
- setup-call-action
- "furnace-form-submitted" request-params session> at
- [ page-submitted ] [ page-not-submitted ] if ;
-
-: responder-vocab ( str -- newstr )
- "webapps." swap append ;
-
-: lookup-action ( str webapp -- word )
- responder-vocab lookup dup [
- dup "action" word-prop [ drop f ] unless
- ] when ;
-
-: truncate-url ( str -- newstr )
- CHAR: / over index [ head ] when* ;
-
-: parse-action ( str -- word/f )
- dup empty? [ drop default-action get ] when
- truncate-url "responder" get lookup-action ;
-
-: service-request ( hash str -- )
- parse-action [
- [ call-action ] [ <pre> print-error </pre> ] recover
- ] [
- "404 no such action: " "argument" get append httpd-error
- ] if* ;
-
-: service-get
- "query" get swap service-request ;
-
-: service-post
- "response" get swap service-request ;
-
-: web-app ( name defaul path -- )
- [
- template-path set
- default-action set
- "responder" set
- [ service-get ] "get" set
- [ service-post ] "post" set
- ] make-responder ;
-
-: explode-tuple ( tuple -- )
- dup tuple-slots swap class "slot-names" word-prop
- [ set ] 2each ;
-
-SYMBOL: model
-
-: with-slots ( model quot -- )
- [
- >r [ dup model set explode-tuple ] when* r> call
- ] with-scope ;
-
-: render-component ( model template -- )
- swap [ render-template ] with-slots ;
-
-: browse-webapp-source ( vocab -- )
- <a vocab browser-link-href =href a>
- "Browse source" write
- </a> ;
-
-: send-resource ( name -- )
- template-path get swap path+ resource-path <file-reader>
- stdio get stream-copy ;
-
-: render-link ( quot name -- )
- <a swap quot-link =href a> write </a> ;
-
-: session-var ( str -- newstr )
- request-params session> at ;
-
-: render ( str -- )
- request-params session> at [ write ] when* ;
-
-: render-error ( str error-str -- )
- swap validation-errors session> at validation-error? [
- write
- ] [
- drop
- ] if ;
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: assoc-heaps assocs calendar crypto.sha2 heaps
-init kernel math.parser namespaces random ;
-IN: furnace.sessions
-
-SYMBOL: sessions
-
-[
- H{ } clone <min-heap> <assoc-heap>
- sessions set-global
-] "furnace.sessions" add-init-hook
-
-: new-session-id ( -- str )
- 4 big-random number>string string>sha-256-string
- dup sessions get-global at [ drop new-session-id ] when ;
-
-TUPLE: session created last-seen user-agent namespace ;
-
-M: session <=> ( session1 session2 -- n )
- [ session-last-seen ] 2apply <=> ;
-
-: <session> ( -- obj )
- now dup H{ } clone
- [ set-session-created set-session-last-seen set-session-namespace ]
- \ session construct ;
-
-: new-session ( -- obj id )
- <session> new-session-id [ sessions get-global set-at ] 2keep ;
-
-: get-session ( id -- obj/f )
- sessions get-global at* [ "no session found 1" throw ] unless ;
-
-! Delete from the assoc only, the heap will timeout
-: destroy-session ( id -- )
- sessions get-global assoc-heap-assoc delete-at ;
-
-: session> ( str -- obj )
- session get session-namespace at ;
-
-: >session ( value key -- )
- session get session-namespace set-at ;
+++ /dev/null
-Action-based web framework
+++ /dev/null
-enterprise
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: temporary
-USING: kernel sequences tools.test furnace.validator furnace ;
-
-[
- 123 f
-] [
- H{ { "foo" "123" } } { "foo" v-number } action-param
-] unit-test
-
-: validation-fails
- [ action-param nip not ] append [ f ] swap unit-test ;
-
-[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails
-
-[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails
-
-[ "ABCD" f ]
-[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ]
-unit-test
-
-[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ]
-validation-fails
-
-[ "AB" f ]
-[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ]
-unit-test
-
-[ "AB" f ]
-[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ]
-unit-test
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces math.parser ;
-IN: furnace.validator
-
-TUPLE: validation-error reason ;
-
-: apply-validators ( string quot -- obj error/f )
- [
- call f
- ] [
- dup validation-error? [ >r 2drop f r> ] [ rethrow ] if
- ] recover ;
-
-: validation-error ( msg -- * )
- \ validation-error construct-boa throw ;
-
-: v-default ( obj value -- obj )
- over empty? [ nip ] [ drop ] if ;
-
-: v-required ( str -- str )
- dup empty? [ "required" validation-error ] when ;
-
-: v-min-length ( str n -- str )
- over length over < [
- [ "must be at least " % # " characters" % ] "" make
- validation-error
- ] [
- drop
- ] if ;
-
-: v-max-length ( str n -- str )
- over length over > [
- [ "must be no more than " % # " characters" % ] "" make
- validation-error
- ] [
- drop
- ] if ;
-
-: v-number ( str -- n )
- string>number [
- "must be a number" validation-error
- ] unless* ;
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: assocs kernel gap-buffer.cursortree tools.test sequences trees
+arrays strings ;
+IN: gap-buffer.cursortree.tests
+
+[ t ] [ "this is a test string" <cursortree> 0 <left-cursor> at-beginning? ] unit-test
+[ t ] [ "this is a test string" <cursortree> dup length <left-cursor> at-end? ] unit-test
+[ 3 ] [ "this is a test string" <cursortree> 3 <left-cursor> cursor-pos ] unit-test
+[ CHAR: i ] [ "this is a test string" <cursortree> 3 <left-cursor> element< ] unit-test
+[ CHAR: s ] [ "this is a test string" <cursortree> 3 <left-cursor> element> ] unit-test
+[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test
+[ 0 ] [ "this is a test string" <cursortree> dup dup 3 <left-cursor> remove-cursor cursors length ] unit-test
+[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursors sequence= ] unit-test
+[ "this is no longer a test string" ] [ "this is a test string" <cursortree> 8 <left-cursor> "no longer " over insert cursor-tree >string ] unit-test
+[ "refactor" ] [ "factor" <cursortree> 0 <left-cursor> CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test
+[ "refactor" ] [ "factor" <cursortree> 0 <right-cursor> CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test
+[ "this a test string" 5 ] [ "this is a test string" <cursortree> 5 <right-cursor> dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test
+[ "this a test string" 5 ] [ "this is a test string" <cursortree> 8 <right-cursor> dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test
--- /dev/null
+! Copyright (C) 2007 Alex Chapman All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
+sequences quotations ;
+IN: gap-buffer.cursortree
+
+TUPLE: cursortree cursors ;
+
+: <cursortree> ( seq -- cursortree )
+ <gb> cursortree construct-empty tuck set-delegate <avl>
+ over set-cursortree-cursors ;
+
+GENERIC: cursortree-gb ( cursortree -- gb )
+M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
+GENERIC: set-cursortree-gb ( gb cursortree -- )
+M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
+
+TUPLE: cursor i tree ;
+TUPLE: left-cursor ;
+TUPLE: right-cursor ;
+
+: cursor-index ( cursor -- i ) cursor-i ;
+
+: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
+
+: remove-cursor ( cursortree cursor -- )
+ tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
+
+: set-cursor-index ( index cursor -- )
+ dup cursor-tree over remove-cursor tuck set-cursor-i
+ dup cursor-tree cursortree-cursors swap add-cursor ;
+
+GENERIC: cursor-pos ( cursor -- n )
+GENERIC: set-cursor-pos ( n cursor -- )
+M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
+M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
+M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
+M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
+
+: <cursor> ( cursortree -- cursor )
+ cursor construct-empty tuck set-cursor-tree ;
+
+: make-cursor ( cursortree pos cursor -- cursor )
+ >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
+
+: <left-cursor> ( cursortree pos -- left-cursor )
+ left-cursor construct-empty make-cursor ;
+
+: <right-cursor> ( cursortree pos -- right-cursor )
+ right-cursor construct-empty make-cursor ;
+
+: cursors ( cursortree -- seq )
+ cursortree-cursors values concat ;
+
+: cursor-positions ( cursortree -- seq )
+ cursors [ cursor-pos ] map ;
+
+M: cursortree move-gap ( n cursortree -- )
+ #! Get the position of each cursor before the move, then re-set the
+ #! position afterwards. This will update any changed cursor indices.
+ dup cursor-positions >r tuck cursortree-gb move-gap
+ cursors r> swap [ set-cursor-pos ] 2each ;
+
+: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
+: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
+
+: at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
+: at-end? ( cursor -- ? ) element@> length = ;
+
+: insert ( obj cursor -- ) element@> insert* ;
+
+: element< ( cursor -- elem ) element@< nth ;
+: element> ( cursor -- elem ) element@> nth ;
+
+: set-element< ( elem cursor -- ) element@< set-nth ;
+: set-element> ( elem cursor -- ) element@> set-nth ;
+
+GENERIC: fix-cursor ( cursortree cursor -- )
+
+M: left-cursor fix-cursor ( cursortree cursor -- )
+ >r gb-gap-start 1- r> set-cursor-index ;
+
+M: right-cursor fix-cursor ( cursortree cursor -- )
+ >r gb-gap-end r> set-cursor-index ;
+
+: fix-cursors ( old-gap-end cursortree -- )
+ tuck cursortree-cursors at [ fix-cursor ] with each ;
+
+M: cursortree delete* ( pos cursortree -- )
+ tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
+
+: delete< ( cursor -- ) element@< delete* ;
+: delete> ( cursor -- ) element@> delete* ;
+
--- /dev/null
+Collection of 'cursors' representing locations in a gap buffer
--- /dev/null
+USING: kernel sequences tools.test gap-buffer strings math ;
+
+! test copy-elements
+[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
+[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
+[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
+
+! test sequence protocol (like, length, nth, set-nth)
+[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
+
+! test move-gap-back-inside
+[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
+[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
+! test move-gap-forward-inside
+[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
+[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
+! test move-gap-back-around
+[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
+[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
+! test move-gap-forward-around
+[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
+[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
+
+! test changing buffer contents
+[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
+! test inserting multiple elements in different places. buffer should grow
+[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
+! test deleting elements. buffer should shrink
+[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
+! more testing of nth and set-nth
+[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
+
+! test stack/queue operations
+[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
+[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
+[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
+[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
+[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
+[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Alex Chapman All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
+! for a good introduction see:
+! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
+USING: kernel arrays sequences sequences.private circular math math.functions generic ;
+IN: gap-buffer
+
+! gap-start -- the first element of the gap
+! gap-end -- the first element after the gap
+! expand-factor -- should be > 1
+! min-size -- < 5 is not sensible
+
+TUPLE: gb
+ gap-start
+ gap-end
+ expand-factor
+ min-size ;
+
+GENERIC: gb-seq ( gb -- seq )
+GENERIC: set-gb-seq ( seq gb -- )
+M: gb gb-seq ( gb -- seq ) delegate ;
+M: gb set-gb-seq ( seq gb -- ) set-delegate ;
+
+: required-space ( n gb -- n )
+ tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
+
+: <gb> ( seq -- gb )
+ gb construct-empty
+ 5 over set-gb-min-size
+ 1.5 over set-gb-expand-factor
+ [ >r length r> set-gb-gap-start ] 2keep
+ [ swap length over required-space swap set-gb-gap-end ] 2keep
+ [
+ over length over required-space rot { } like resize-array <circular> swap set-gb-seq
+ ] keep ;
+
+M: gb like ( seq gb -- seq ) drop <gb> ;
+
+: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
+
+: buffer-length ( gb -- n ) gb-seq length ;
+
+M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
+
+: valid-position? ( pos gb -- ? )
+ #! one element past the end of the buffer is a valid position when we're inserting
+ length -1 swap between? ;
+
+: valid-index? ( i gb -- ? )
+ buffer-length -1 swap between? ;
+
+TUPLE: position-out-of-bounds position gap-buffer ;
+C: <position-out-of-bounds> position-out-of-bounds
+
+: position>index ( pos gb -- i )
+ 2dup valid-position? [
+ 2dup gb-gap-start >= [
+ gap-length +
+ ] [ drop ] if
+ ] [
+ <position-out-of-bounds> throw
+ ] if ;
+
+TUPLE: index-out-of-bounds index gap-buffer ;
+C: <index-out-of-bounds> index-out-of-bounds
+
+: index>position ( i gb -- pos )
+ 2dup valid-index? [
+ 2dup gb-gap-end >= [
+ gap-length -
+ ] [ drop ] if
+ ] [
+ <index-out-of-bounds> throw
+ ] if ;
+
+M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
+
+M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
+
+M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
+
+M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
+
+M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
+
+M: gb virtual-seq gb-seq ;
+
+INSTANCE: gb virtual-sequence
+
+! ------------- moving the gap -------------------------------
+
+: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
+
+: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
+
+: copy-elements-back ( dst start seq n -- )
+ dup 0 > [
+ >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
+ ] [ 3drop drop ] if ;
+
+: copy-elements-forward ( dst start seq n -- )
+ dup 0 > [
+ >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
+ ] [ 3drop drop ] if ;
+
+: copy-elements ( dst start end seq -- )
+ pick pick > [
+ >r dupd - r> swap copy-elements-forward
+ ] [
+ >r over - r> swap copy-elements-back
+ ] if ;
+
+! the gap can be moved either forward or back. Moving the gap 'inside' means
+! moving elements across the gap. Moving the gap 'around' means changing the
+! start of the circular buffer to avoid moving as many elements.
+
+! We decide which method (inside or around) to pick based on the number of
+! elements that will need to be moved. We always try to move as few elements as
+! possible.
+
+: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
+
+: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
+
+: move-gap-back-inside? ( i gb -- i gb ? )
+ #! is it cheaper to move the gap inside than around?
+ 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
+
+: move-gap-forward-inside? ( i gb -- i gb ? )
+ #! is it cheaper to move the gap inside than around?
+ 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
+
+: move-gap-forward-inside ( i gb -- )
+ [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
+
+: move-gap-back-inside ( i gb -- )
+ [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
+
+: move-gap-forward-around ( i gb -- )
+ 0 over move-gap-back-inside [
+ dup buffer-length [
+ swap gap-length - neg swap
+ ] keep
+ ] keep [
+ gb-seq copy-elements
+ ] keep dup gap-length swap gb-seq change-circular-start ;
+
+: move-gap-back-around ( i gb -- )
+ dup buffer-length over move-gap-forward-inside [
+ length swap -1
+ ] keep [
+ gb-seq copy-elements
+ ] keep dup length swap gb-seq change-circular-start ;
+
+: move-gap-forward ( i gb -- )
+ move-gap-forward-inside? [
+ move-gap-forward-inside
+ ] [
+ move-gap-forward-around
+ ] if ;
+
+: move-gap-back ( i gb -- )
+ move-gap-back-inside? [
+ move-gap-back-inside
+ ] [
+ move-gap-back-around
+ ] if ;
+
+: (move-gap) ( i gb -- )
+ move-gap? [
+ move-gap-forward? [
+ move-gap-forward
+ ] [
+ move-gap-back
+ ] if
+ ] [ 2drop ] if ;
+
+: fix-gap ( n gb -- )
+ 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
+
+! moving the gap to position 5 means that the element in position 5 will be immediately after the gap
+GENERIC: move-gap ( n gb -- )
+
+M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
+
+! ------------ resizing -------------------------------------
+
+: enough-room? ( n gb -- ? )
+ #! is there enough room to add 'n' elements to gb?
+ tuck length + swap buffer-length <= ;
+
+: set-new-gap-end ( array gb -- )
+ [ buffer-length swap length swap - ] keep
+ [ gb-gap-end + ] keep set-gb-gap-end ;
+
+: after-gap ( gb -- gb )
+ dup gb-seq swap gb-gap-end tail ;
+
+: before-gap ( gb -- gb )
+ dup gb-gap-start head ;
+
+: copy-after-gap ( array gb -- )
+ #! copy everything after the gap in 'gb' into the end of 'array',
+ #! and change 'gb's gap-end to reflect the gap-end in 'array'
+ dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
+
+: copy-before-gap ( array gb -- )
+ #! copy everything before the gap in 'gb' into the start of 'array'
+ before-gap 0 rot copy ; ! gap start doesn't change
+
+: resize-buffer ( gb new-size -- )
+ f <array> swap 2dup copy-before-gap 2dup copy-after-gap
+ >r <circular> r> set-gb-seq ;
+
+: decrease-buffer-size ( gb -- )
+ #! the gap is too big, so resize to something sensible
+ dup length over required-space resize-buffer ;
+
+: increase-buffer-size ( n gb -- )
+ #! increase the buffer to fit at least 'n' more elements
+ tuck length + over required-space resize-buffer ;
+
+: gb-too-big? ( gb -- ? )
+ dup buffer-length over gb-min-size > [
+ dup length over buffer-length rot gb-expand-factor sq / <
+ ] [ drop f ] if ;
+
+: ?decrease ( gb -- )
+ dup gb-too-big? [
+ decrease-buffer-size
+ ] [ drop ] if ;
+
+: ensure-room ( n gb -- )
+ #! ensure that ther will be enough room for 'n' more elements
+ 2dup enough-room? [ 2drop ] [
+ increase-buffer-size
+ ] if ;
+
+! ------- editing operations ---------------
+
+GENERIC# insert* 2 ( seq position gb -- )
+
+: prepare-insert ( seq position gb -- seq gb )
+ tuck move-gap over length over ensure-room ;
+
+: insert-elements ( seq gb -- )
+ dup gb-gap-start swap gb-seq copy ;
+
+: increment-gap-start ( gb n -- )
+ over gb-gap-start + swap set-gb-gap-start ;
+
+! generic dispatch identifies numbers as sequences before numbers...
+! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
+: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
+
+M: sequence insert* ( seq position gb -- )
+ pick number? [
+ number-insert
+ ] [
+ prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
+ ] if ;
+
+: (delete*) ( gb -- )
+ dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
+
+GENERIC: delete* ( pos gb -- )
+
+M: gb delete* ( position gb -- )
+ tuck move-gap (delete*) ;
+
+! -------- stack/queue operations -----------
+
+: push-start ( obj gb -- ) 0 swap insert* ;
+
+: push-end ( obj gb -- ) [ length ] keep insert* ;
+
+: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
+
+: pop-start ( gb -- elem ) 0 swap pop-elem ;
+
+: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
+
+: rotate ( n gb -- )
+ dup length 1 > [
+ swap dup 0 > [
+ [ dup [ pop-end ] keep push-start ]
+ ] [
+ neg [ dup [ pop-start ] keep push-end ]
+ ] if times drop
+ ] [ 2drop ] if ;
+
--- /dev/null
+Gap buffer data structure
--- /dev/null
+collections sequences
-IN: temporary
+IN: globs.tests
USING: tools.test globs ;
[ f ] [ "abd" "fdf" glob-matches? ] unit-test
USING: alien arrays byte-arrays combinators
graphics.viewer io io.binary io.files kernel libc math
math.functions namespaces opengl opengl.gl prettyprint
-sequences strings ui ui.gadgets.panes ;
+sequences strings ui ui.gadgets.panes io.encodings.binary ;
IN: graphics.bitmap
! Currently can only handle 24bit bitmaps.
dup color-index-length read swap set-bitmap-color-index ;
: load-bitmap ( path -- bitmap )
- [
+ binary [
T{ bitmap } clone
dup parse-file-header
dup parse-bitmap-header
raw-bitmap>string >byte-array over set-bitmap-array ;
: save-bitmap ( bitmap path -- )
- [
+ binary [
"BM" write
dup bitmap-array length 14 + 40 + 4 >le write
0 4 >le write
USING: tools.test hash2 kernel ;
+IN: hash2.tests
: sample-hash
5 <hash2>
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 2 }
{ deploy-io 1 }
- { deploy-word-props? f }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
{ deploy-compiler? t }
+ { deploy-word-defs? f }
+ { deploy-word-props? f }
+ { deploy-math? t }
{ deploy-name "Hello world" }
{ deploy-c-types? f }
+ { deploy-ui? t }
+ { deploy-threads? t }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
}
USING: tools.deploy.config ;
H{
- { deploy-c-types? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
+ { deploy-io 2 }
{ deploy-math? f }
+ { deploy-threads? f }
+ { deploy-compiler? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
+ { deploy-reflection 2 }
+ { deploy-c-types? f }
+ { deploy-ui? f }
{ "stop-after-last-window?" t }
- { deploy-compiler? f }
- { deploy-io 2 }
}
}
"Print the lines of a file in sorted order:"
{ $code
- "\"lines.txt\" file-lines natural-sort [ print ] each"
+ "utf8 \"lines.txt\" file-lines natural-sort [ print ] each"
}
"Read 1024 bytes from a file:"
{ $code
- "\"data.bin\" [ 1024 read ] with-file-reader"
+ "\"data.bin\" binary [ 1024 read ] with-file-reader"
}
-"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:"
+"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"\"mydata.dat\" dup file-length ["
" 4 <sliced-groups> [ reverse-here ] change-each"
-USING: help.crossref help.topics help.syntax help.markup ;
+USING: help.topics help.syntax help.markup ;
+IN: help.crossref
HELP: article-children
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
{ $values { "topic" "an article name or a word" } { "seq" "a new sequence" } }
{ $description "Outputs a sequence of all help articles which contain " { $snippet "topic" } " as a subsection, traversing all the way up to the root." }
{ $examples
- { $example "USE: help.crossref" "\"sequences\" help-path ." "{ \"collections\" \"handbook\" }" }
+ { $example "USING: help.crossref prettyprint ;" "\"sequences\" help-path ." "{ \"collections\" \"handbook\" }" }
} ;
HELP: xref-article
-IN: temporary
+IN: help.crossref.tests
USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units ;
[ ] [
- "IN: temporary USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
+ "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
] unit-test
[ $subsection ] [
[ t ] [
"foo" article-children
- "foo" "temporary" lookup 1array sequence=
+ "foo" "help.crossref.tests" lookup 1array sequence=
] unit-test
-[ "foo" ] [ "foo" "temporary" lookup article-parent ] unit-test
+[ "foo" ] [ "foo" "help.crossref.tests" lookup article-parent ] unit-test
[ ] [
- [ "foo" "temporary" lookup forget ] with-compilation-unit
+ [ "foo" "help.crossref.tests" lookup forget ] with-compilation-unit
] unit-test
[ ] [
- "IN: temporary USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
+ "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
] unit-test
[ ] [
USING: math definitions help.topics help tools.test
prettyprint parser io.streams.string kernel source-files
assocs namespaces words io sequences ;
-IN: temporary
+IN: help.definitions.tests
[ ] [ \ + >link see ] unit-test
[
[ 4 ] [
- "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
+ "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions first assoc-size
[ t ] [ "hello" articles get key? ] unit-test
[ t ] [ "hello2" articles get key? ] unit-test
[ t ] [
- "hello" "temporary" lookup "help" word-prop >boolean
+ "hello" "help.definitions.tests" lookup "help" word-prop >boolean
] unit-test
[ 2 ] [
- "IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
+ "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
parse-stream drop
"foo" source-file source-file-definitions first assoc-size
[ t ] [ "hello" articles get key? ] unit-test
[ f ] [ "hello2" articles get key? ] unit-test
[ f ] [
- "hello" "temporary" lookup "help" word-prop
+ "hello" "help.definitions.tests" lookup "help" word-prop
] unit-test
- [ ] [ "IN: temporary USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
+ [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
- [ ] [ "xxx" "temporary" lookup help ] unit-test
+ [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test
- [ ] [ "xxx" "temporary" lookup >link synopsis print ] unit-test
+ [ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
] with-file-vocabs
--- /dev/null
+IN: help.handbook.tests
+USING: help tools.test ;
+
+[ ] [ "article-index" help ] unit-test
+[ ] [ "primitive-index" help ] unit-test
+[ ] [ "error-index" help ] unit-test
+[ ] [ "type-index" help ] unit-test
+[ ] [ "class-index" help ] unit-test
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 ;
+quotations io.streams.byte-array io.encodings.string ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ "All other types of objects are pushed on the data stack." }
}
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
-$nl
-"There are various ways of implementing these evaluation semantics. See " { $link "compiler" } " and " { $link "meta-interpreter" } "." ;
+{ $see-also "compiler" } ;
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
concurrency.locks
concurrency.semaphores
concurrency.count-downs
-concurrency.exchangers ;
+concurrency.exchangers
+concurrency.flags ;
ARTICLE: "concurrency" "Concurrency"
"Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time."
{ $subsection "concurrency.combinators" }
{ $subsection "concurrency.promises" }
{ $subsection "concurrency.futures" }
+{ $subsection "concurrency.mailboxes" }
{ $subsection "concurrency.messaging" }
"Shared-state abstractions:"
{ $subsection "concurrency.locks" }
{ $subsection "concurrency.semaphores" }
{ $subsection "concurrency.count-downs" }
{ $subsection "concurrency.exchangers" }
+{ $subsection "concurrency.flags" }
"Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ;
ARTICLE: "objects" "Objects"
{ $subsection "classes" }
{ $subsection "tuples" }
{ $subsection "generic" }
+{ $subsection "slots" }
{ $subsection "mirrors" } ;
USE: random
USING: io.sockets io.launcher io.mmap io.monitors ;
-ARTICLE: "io" "Input and output"
+ARTICLE: "io" "Input and output"
+{ $heading "Streams" }
{ $subsection "streams" }
-"External streams:"
-{ $subsection "file-streams" }
-{ $subsection "network-streams" }
"Wrapper streams:"
{ $subsection "io.streams.duplex" }
-{ $subsection "io.streams.lines" }
{ $subsection "io.streams.plain" }
{ $subsection "io.streams.string" }
-"Stream utilities:"
+{ $subsection "io.streams.byte-array" }
+"Utilities:"
{ $subsection "stream-binary" }
{ $subsection "styles" }
-"Advanced features:"
-{ $subsection "io.launcher" }
+{ $heading "Files" }
+{ $subsection "io.files" }
{ $subsection "io.mmap" }
{ $subsection "io.monitors" }
+{ $heading "Encodings" }
+{ $subsection "io.encodings" }
+{ $subsection "io.encodings.string" }
+{ $heading "Other features" }
+{ $subsection "network-streams" }
+{ $subsection "io.launcher" }
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
"Debugging tools:"
{ $subsection "tools.annotations" }
{ $subsection "tools.test" }
-{ $subsection "meta-interpreter" }
+{ $subsection "tools.threads" }
"Performance tools:"
{ $subsection "tools.memory" }
{ $subsection "profiling" }
USING: help.cookbook help.tutorial ;
ARTICLE: "handbook" "Factor documentation"
-"Welcome to Factor. Factor is dynamically-typed, stack-based, and very expressive. It is one of the most powerful and flexible programming languages ever invented. Have fun with Factor!"
+"Welcome to Factor."
{ $heading "Starting points" }
{ $subsection "cookbook" }
{ $subsection "first-program" }
{ $subsection "help" }
{ $subsection "inference" }
{ $subsection "compiler" }
+{ $subsection "layouts" }
{ $heading "User interface" }
{ $about "ui" }
{ $about "ui.tools" }
{ $values { "element" "a markup element" } }
{ $description "Prints a heading followed by some examples. Word documentation should include examples, at least if the usage of the word is not entirely obvious." }
{ $examples
- { $markup-example { $examples { $example "2 2 + ." "4" } } }
+ { $markup-example { $examples { $example "USING: math prettyprint ;" "2 2 + ." "4" } } }
} ;
HELP: $example
{ $values { "element" "a markup element of the form " { $snippet "{ inputs... output }" } } }
{ $description "Prints a clickable example with sample output. The markup element must be an array of strings. All but the last string are joined by newlines and taken as the input text, and the last string is the output. The example becomes clickable if the output stream supports it, and clicking it opens a listener window with the input text inserted at the input prompt." }
{ $examples
- "The output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:"
+ "The input text must contain a correct " { $link POSTPONE: USING: } " declaration, and output text should be a string of what the input prints when executed, not the final stack contents or anything like that. So the following is an incorrect example:"
{ $markup-example { $unchecked-example "2 2 +" "4" } }
"However the following is right:"
- { $markup-example { $example "2 2 + ." "4" } }
+ { $markup-example { $example "USING: math prettyprint ;" "2 2 + ." "4" } }
"Examples can incorporate a call to " { $link .s } " to show multiple output values; the convention is that you may assume the stack is empty before the example evaluates."
} ;
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
{ $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." }
{ $examples
- { $example "USE: help.markup" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
+ { $example "USING: help.markup io ;" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" }
} ;
HELP: $links
HELP: $notes
{ $values { "element" "a markup element" } }
-{ $description "Prints the errors subheading found on the help page of some words. This section should usage tips and pitfalls." } ;
+{ $description "Prints the notes subheading found on the help page of some words. This section should document usage tips and pitfalls." } ;
HELP: $see
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
] ?if ;
: ($index) ( articles -- )
- subsection-style get [
- sort-articles [ nl ] [ ($subsection) ] interleave
- ] with-style ;
+ sort-articles [ \ $subsection swap 2array ] map print-element ;
: $index ( element -- )
first call dup empty?
: (:help-multi)
"This error has multiple delegates:" print
- ($index) nl ;
+ ($index) nl
+ "Use \\ ... help to get help about a specific delegate." print ;
: (:help-none)
drop "No help for this error. " print ;
+: (:help-debugger)
+ nl
+ "Debugger commands:" print
+ nl
+ ":s - data stack at error time" print
+ ":r - retain stack at error time" print
+ ":c - call stack at error time" print
+ ":edit - jump to source location (parse errors only)" print
+
+ ":get ( var -- value ) accesses variables at time of the error" print
+ ":vars - list all variables at error time";
+
: :help ( -- )
error get delegates [ error-help ] map [ ] subset
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
{ [ t ] [ (:help-multi) ] }
- } cond ;
+ } cond (:help-debugger) ;
: remove-article ( name -- )
dup articles get key? [
USING: help.markup help.syntax ;
IN: help.lint
-HELP: check-help
-{ $description "Checks all word and article help." } ;
+HELP: help-lint-all
+{ $description "Checks all word help and articles in all loaded vocabularies." } ;
-HELP: check-vocab-help
-{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Checks all word help in the given vocabulary." } ;
+HELP: help-lint
+{ $values { "prefix" "a vocabulary specifier" } }
+{ $description "Checks all word help and articles in the given vocabulary and all child vocabularies." } ;
ARTICLE: "help.lint" "Help lint tool"
"The " { $vocab-link "help.lint" } " vocabulary implements a tool to check documentation in an automated fashion. You should use this tool to check any documentation that you write."
$nl
"To run help lint, use one of the following two words:"
-{ $subsection check-help }
-{ $subsection check-vocab-help }
+{ $subsection help-lint }
+{ $subsection help-lint-all }
"Help lint performs the following checks:"
{ $list
"ensures examples run and produce stated output"
{ "ensures " { $link $see-also } " elements don't contain duplicate entries" }
{ "ensures " { $link $vocab-link } " elements point to modules which actually exist" }
{ "ensures that " { $link $values } " match the stack effect declaration" }
- { "ensures that word help articles actually render (this catches broken links, improper nesting, etc)" }
+ { "ensures that help topics actually render (this catches broken links, improper nesting, etc)" }
} ;
ABOUT: "help.lint"
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
-macros combinators.lib ;
+macros combinators.lib sequences.lib math ;
IN: help.lint
: check-example ( element -- )
] unless ;
: effect-values ( word -- seq )
- stack-effect dup effect-in swap effect-out
- append [ string? ] subset prune natural-sort ;
+ stack-effect dup effect-in swap effect-out append [
+ {
+ { [ dup word? ] [ word-name ] }
+ { [ dup integer? ] [ drop "object" ] }
+ { [ dup string? ] [ ] }
+ } cond
+ ] map prune natural-sort ;
: contains-funky-elements? ( element -- ? )
{
delegate error. ;
: check-something ( obj quot -- )
- over . flush [ <help-error> , ] recover ; inline
+ flush [ <help-error> , ] recover ; inline
: check-word ( word -- )
dup word-help [
[ dup check-rendering ] assert-depth drop
] check-something ;
-: check-articles ( -- )
- articles get keys [ check-article ] each ;
+: group-articles ( -- assoc )
+ articles get keys
+ vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
+ H{ } clone [
+ [
+ >r >r dup >link where ?first r> at r> [ ?push ] change-at
+ ] 2curry each
+ ] keep ;
+
+: check-vocab ( vocab -- seq )
+ "Checking " write dup write "..." print
+ [
+ dup words [ check-word ] each
+ "vocab-articles" get at [ check-article ] each
+ ] { } make ;
-: with-help-lint ( quot -- )
+: run-help-lint ( prefix -- alist )
[
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- call
- ] { } make [ nl error. ] each ; inline
+ articles get keys "group-articles" set
+ child-vocabs
+ [ dup check-vocab ] { } map>assoc
+ [ nip empty? not ] assoc-subset
+ ] with-scope ;
+
+: typos. ( assoc -- )
+ dup empty? [
+ drop
+ "==== ALL CHECKS PASSED" print
+ ] [
+ [
+ swap vocab-heading.
+ [ error. nl ] each
+ ] assoc-each
+ ] if ;
-: check-help ( -- )
- [ all-words check-words check-articles ] with-help-lint ;
+: help-lint ( prefix -- ) run-help-lint typos. ;
-: check-vocab-help ( vocab -- )
- [
- child-vocabs [ words check-words ] each
- ] with-help-lint ;
+: help-lint-all ( -- ) "" help-lint ;
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] subset ;
[ article-parent ] subset
[ "predicating" word-prop not ] subset ;
-MAIN: check-help
+MAIN: help-lint
USING: definitions help help.markup kernel sequences tools.test
words parser namespaces assocs generic io.streams.string ;
-IN: temporary
+IN: help.markup.tests
TUPLE: blahblah quux ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic io kernel assocs hashtables
namespaces parser prettyprint sequences strings io.styles
[ print-element ] with-style ;
: with-default-style ( quot -- )
- default-style get [
+ default-span-style get [
last-element off
- default-style get swap with-nesting
+ default-block-style get swap with-nesting
] with-style ; inline
: print-content ( element -- )
: $link ( element -- )
first ($link) ;
-: ($subsection) ( object -- )
- [ article-title ] keep >link write-object ;
+: ($long-link) ( object -- )
+ dup article-title swap >link write-link ;
-: $subsection ( element -- )
+: ($subsection) ( element quot -- )
[
subsection-style get [
bullet get write bl
- first ($subsection)
+ call
] with-style
- ] ($block) ;
+ ] ($block) ; inline
-: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
+: $subsection ( element -- )
+ [ first ($long-link) ] ($subsection) ;
+
+: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
+
+: $vocab-subsection ( element -- )
+ [
+ first2 dup vocab-help dup [
+ 2nip ($long-link)
+ ] [
+ drop ($vocab-link)
+ ] if
+ ] ($subsection) ;
-: $vocab-link ( element -- ) first ($vocab-link) ;
+: $vocab-link ( element -- ) first dup ($vocab-link) ;
: $vocabulary ( element -- )
first word-vocabulary [
- "Vocabulary" $heading nl ($vocab-link)
+ "Vocabulary" $heading nl dup ($vocab-link)
] when* ;
: textual-list ( seq quot -- )
USING: io.styles namespaces ;
IN: help.stylesheet
-SYMBOL: default-style
+SYMBOL: default-span-style
H{
{ font "sans-serif" }
{ font-size 12 }
{ font-style plain }
+} default-span-style set-global
+
+SYMBOL: default-block-style
+H{
{ wrap-margin 500 }
-} default-style set-global
+} default-block-style set-global
SYMBOL: link-style
H{
-IN: temporary
+IN: help.syntax.tests
USING: tools.test parser vocabs help.syntax namespaces ;
[
[ "foobar" ] [
- "IN: temporary USE: help.syntax ABOUT: \"foobar\"" eval
- "temporary" vocab vocab-help
+ "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval
+ "help.syntax.tests" vocab vocab-help
] unit-test
[ { "foobar" } ] [
- "IN: temporary USE: help.syntax ABOUT: { \"foobar\" }" eval
- "temporary" vocab vocab-help
+ "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval
+ "help.syntax.tests" vocab vocab-help
] unit-test
SYMBOL: xyz
[ xyz ] [
- "IN: temporary USE: help.syntax ABOUT: xyz" eval
- "temporary" vocab vocab-help
+ "IN: help.syntax.tests USE: help.syntax ABOUT: xyz" eval
+ "help.syntax.tests" vocab vocab-help
] unit-test
] with-file-vocabs
USING: definitions help help.topics help.crossref help.markup
help.syntax kernel sequences tools.test words parser namespaces
assocs source-files ;
-IN: temporary
+IN: help.topics.tests
! Test help cross-referencing
-IN: temporary
+IN: hexdump.tests
USING: hexdump kernel sequences tools.test ;
[ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
-IN: temporary
+IN: html.elements.tests
USING: tools.test html html.elements io.streams.string ;
: make-html-string
#! word.
foo> [ ">" write-html ] empty-effect html-word ;
-: </foo> [ "</" % % ">" % ] "" make ;
+: </foo> "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup [ write-html ] curry empty-effect html-word ;
-: <foo/> [ "<" % % "/>" % ] "" make ;
+: <foo/> "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media"
] [ define-attribute-word ] each
] with-compilation-unit
USING: html http io io.streams.string io.styles kernel
namespaces tools.test xml.writer sbufs sequences html.private ;
-IN: temporary
+IN: html.tests
: make-html-string
[ with-html-stream ] with-string-writer ;
USING: assocs html.parser kernel math sequences strings ascii
-arrays shuffle unicode.case namespaces splitting
-http.server.responders ;
+arrays shuffle unicode.case namespaces splitting http
+sequences.lib ;
IN: html.parser.analyzer
+: (find-relative)
+ [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
+
+: find-relative ( seq quot n -- i elt )
+ >r over [ find drop ] dip r> swap pick
+ (find-relative) ;
+
+: (find-all) ( n seq quot -- )
+ 2dup >r >r find* [
+ dupd 2array , 1+ r> r> (find-all)
+ ] [
+ r> r> 3drop
+ ] if* ;
+
+: find-all ( seq quot -- alist )
+ [ 0 -rot (find-all) ] { } make ;
+
+: (find-nth) ( offset seq quot n count -- obj )
+ >r >r [ find* ] 2keep 4 npick [
+ r> r> 1+ 2dup <= [
+ 4drop
+ ] [
+ >r >r >r >r drop 1+ r> r> r> r>
+ (find-nth)
+ ] if
+ ] [
+ 2drop r> r> 2drop
+ ] if ;
+
+: find-nth ( seq quot n -- i elt )
+ 0 -roll 0 (find-nth) ;
+
+: find-nth-relative ( seq quot n offest -- i elt )
+ >r [ find-nth ] 3keep 2drop nip r> swap pick
+ (find-relative) ;
+
: remove-blank-text ( vector -- vector' )
[
dup tag-name text = [
>r >lower r>
[ tag-attributes at over = ] with find rot drop ;
-: find-between ( i/f tag/f vector -- vector )
+: find-between* ( i/f tag/f vector -- vector )
pick integer? [
- rot 1+ tail-slice
+ rot tail-slice
>r tag-name r>
- [ find-matching-close drop ] keep swap head
+ [ find-matching-close drop 1+ ] keep swap head
] [
3drop V{ } clone
] if ;
+
+: find-between ( i/f tag/f vector -- vector )
+ find-between* dup length 3 >= [
+ [ 1 tail-slice 1 head-slice* ] keep like
+ ] when ;
+
+: find-between-first ( string vector -- vector' )
+ [ find-first-name ] keep find-between ;
+
+: tag-link ( tag -- link/f )
+ tag-attributes [ "href" swap at ] [ f ] if* ;
: find-links ( vector -- vector )
[ tag-name "a" = ] subset
- [ tag-attributes "href" swap at ] map
- [ ] subset ;
+ [ tag-link ] subset ;
-: (find-all) ( n seq quot -- )
- 2dup >r >r find* [
- dupd 2array , 1+ r> r> (find-all)
- ] [
- r> r> 3drop
- ] if* ;
-: find-all ( seq quot -- alist )
- [ 0 -rot (find-all) ] { } make ;
+: find-by-text ( seq quot -- tag )
+ [ dup tag-name text = ] swap compose find drop ;
: find-opening-tags-by-name ( name seq -- seq )
[ [ tag-name = ] keep tag-closing? not and ] with find-all ;
: href-contains? ( str tag -- ? )
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
-: query>hash* ( str -- hash )
- "?" split1 nip query>hash ;
+: query>assoc* ( str -- hash )
+ "?" split1 nip query>assoc ;
! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
! "a" over find-opening-tags-by-name
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
! first first 8 + over nth
-! tag-attributes "href" swap at query>hash*
+! tag-attributes "href" swap at query>assoc*
! "lat" over at "lon" rot at
USING: html.parser kernel tools.test ;
-IN: temporary
+IN: html.parser.tests
[
V{ T{ tag f "html" H{ } f f f } }
namespaces prettyprint quotations sequences splitting
state-parser strings tools.test ;
USING: html.parser.utils ;
-IN: temporary
+IN: html.parser.utils.tests
[ "'Rome'" ] [ "Rome" single-quote ] unit-test
[ "\"Roma\"" ] [ "Roma" double-quote ] unit-test
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax crypto.sha2 ;
-IN: http.basic-authentication
-
-HELP: realms
-{ $description
- "A hashtable mapping a basic authentication realm (a string) "
- "to either a quotation or a hashtable. The quotation has "
- "stack effect ( username sha-256-string -- bool ). It "
- "is expected to perform the user authentication when called." $nl
- "If the realm maps to a hashtable then the hashtable should be a "
- "mapping of usernames to sha-256 hashed passwords." $nl
- "If the 'realms' variable does not exist in the current scope then "
- "authentication will always fail." }
-{ $see-also add-realm with-basic-authentication } ;
-
-HELP: add-realm
-{ $values
- { "data" "a quotation or a hashtable" } { "name" "a string" } }
-{ $description
- "Adds the authentication data to the " { $link realms } ". 'data' can be "
- "a quotation with stack effect ( username sha-256-string -- bool ) or "
- "a hashtable mapping username strings to sha-256-string passwords." }
-{ $examples
- { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" }
- { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" }
-}
-{ $see-also with-basic-authentication realms } ;
-
-HELP: with-basic-authentication
-{ $values
- { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } }
-{ $description
- "Checks if the HTTP request has the correct authorisation headers "
- "for basic authentication within the named realm. If the headers "
- "are not present then a '401' HTTP response results from the "
- "request, otherwise the quotation is called." }
-{ $examples
-{ $code "\"my-realm\" [\n serving-html \"<html><body>Success!</body></html>\" write\n] with-basic-authentication" } }
-{ $see-also add-realm realms }
- ;
-
-ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication"
-"The Basic Authentication system provides a simple browser based "
-"authentication method to web applications. When the browser requests "
-"a resource protected with basic authentication the server responds with "
-"a '401' response code which means the user is unauthorized."
-$nl
-"When the browser receives this it prompts the user for a username and "
-"password. This is sent back to the server in a special HTTP header. The "
-"server then checks this against its authentication information and either "
-"accepts or rejects the users request."
-$nl
-"Authentication is split up into " { $link realms } ". Each realm can have "
-"a different database of username and password information. A responder can "
-"require basic authentication by using the " { $link with-basic-authentication } " word."
-$nl
-"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "."
-$nl
-"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word."
-$nl
-"Note that Basic Authentication itself is insecure in that it "
-"sends the username and password as clear text (although it is "
-"base64 encoded this is not much help). To prevent eavesdropping "
-"it is best to use Basic Authentication with SSL." ;
-
-IN: http.basic-authentication
-ABOUT: { "http-authentication" "basic-authentication" }
+++ /dev/null
-! Copyright (c) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel crypto.sha2 http.basic-authentication tools.test
- namespaces base64 sequences ;
-
-{ t } [
- [
- H{ } clone realms set
- H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
- "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ f } [
- [
- H{ } clone realms set
- H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
- "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ f } [
- [
- H{ } clone realms set
- H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
- "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ t } [
- [
- H{ } clone realms set
- [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
- "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ f } [
- [
- H{ } clone realms set
- [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
- "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ f } [
- [
- H{ } clone realms set
- [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
- "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ f } [
- [
- f realms set
- "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
- ] with-scope
-] unit-test
-
-{ f } [
- [
- H{ } clone realms set
- "test-realm" "Basic " "admin:password" >base64 append authorization-ok?
- ] with-scope
-] unit-test
+++ /dev/null
-! Copyright (c) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel base64 http.server crypto.sha2 namespaces assocs
- quotations hashtables combinators splitting sequences
- http.server.responders io html.elements ;
-IN: http.basic-authentication
-
-! 'realms' is a hashtable mapping a realm (a string) to
-! either a quotation or a hashtable. The quotation
-! has stack effect ( username sha-256-string -- bool ).
-! It should perform the user authentication. 'sha-256-string'
-! is the plain text password provided by the user passed through
-! 'string>sha-256-string'. If 'realms' maps to a hashtable then
-! it is a mapping of usernames to sha-256 hashed passwords.
-!
-! 'realms' can be set on a per vhost basis in the vhosts
-! table.
-!
-! If there are no realms then authentication fails.
-SYMBOL: realms
-
-: add-realm ( data name -- )
- #! Add the named realm to the realms table.
- #! 'data' should be a hashtable or a quotation.
- realms get [ H{ } clone dup realms set ] unless*
- set-at ;
-
-: user-authorized? ( username password realm -- bool )
- realms get dup [
- at {
- { [ dup quotation? ] [ call ] }
- { [ dup hashtable? ] [ swapd at = ] }
- { [ t ] [ 3drop f ] }
- } cond
- ] [
- 3drop drop f
- ] if ;
-
-: authorization-ok? ( realm header -- bool )
- #! Given the realm and the 'Authorization' header,
- #! authenticate the user.
- dup [
- " " split dup first "Basic" = [
- second base64> ":" split first2 string>sha-256-string rot
- user-authorized?
- ] [
- 2drop f
- ] if
- ] [
- 2drop f
- ] if ;
-
-: authentication-error ( realm -- )
- "401 Unauthorized" response
- "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header
- <html> <body>
- "Username or Password is invalid" write
- </body> </html> ;
-
-: with-basic-authentication ( realm quot -- )
- #! Check if the user is authenticated in the given realm
- #! to run the specified quotation. If not, use Basic
- #! Authentication to ask for authorization details.
- over "Authorization" header-param authorization-ok?
- [ nip call ] [ drop authentication-error ] if ;
+++ /dev/null
-HTTP Basic Authentication implementation
-USING: http.client tools.test ;
+USING: http.client http.client.private http tools.test
+tuple-syntax namespaces ;
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
-[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
-[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
-[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
-[ 404 ] [ "404 File not found" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
+[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
+[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+
+[
+ TUPLE{ request
+ method: "GET"
+ host: "www.apple.com"
+ path: "/index.html"
+ port: 80
+ version: "1.1"
+ cookies: V{ }
+ }
+] [
+ [
+ "http://www.apple.com/index.html"
+ <get-request>
+ ] with-scope
+] unit-test
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
-splitting continuations assocs.lib ;
+splitting calendar continuations accessors vectors
+io.encodings.latin1 io.encodings.binary fry ;
IN: http.client
-: parse-host ( url -- host port )
- #! Extract the host name and port number from an HTTP URL.
- ":" split1 [ string>number ] [ 80 ] if* ;
+DEFER: http-request
-SYMBOL: domain
+<PRIVATE
-: parse-url ( url -- host resource )
- dup "https://" head? [
- "ssl not yet supported: " swap append throw
- ] when "http://" ?head drop
+: parse-url ( url -- resource host port )
+ "http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" swap append ] [ "/" ] if*
- >r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
-
-: parse-response ( line -- code )
- "HTTP/" ?head [ " " split1 nip ] when
- " " split1 drop string>number [
- "Premature end of stream" throw
- ] unless* ;
-
-: read-response ( -- code header )
- #! After sending a GET or POST we read a response line and
- #! header.
- flush readln parse-response read-header ;
-
-: crlf "\r\n" write ;
-
-: http-request ( host resource method -- )
- write bl write " HTTP/1.0" write crlf
- "Host: " write write crlf ;
-
-: get-request ( host resource -- )
- "GET" http-request crlf ;
-
-DEFER: http-get-stream
-
-: do-redirect ( code headers stream -- code headers stream )
- #! Should this support Location: headers that are
- #! relative URLs?
- pick 100 /i 3 = [
- dispose "location" swap peek-at nip http-get-stream
- ] when ;
-
-: default-timeout 60 1000 * over set-timeout ;
-
-: http-get-stream ( url -- code headers stream )
- #! Opens a stream for reading from an HTTP URL.
- parse-url over parse-host <inet> <client> [
- [ [ get-request read-response ] with-stream* ] keep
- default-timeout
- ] [ ] [ dispose ] cleanup do-redirect ;
+ swap parse-host ;
+
+: store-path ( request path -- request )
+ "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
+
+: request-with-url ( url request -- request )
+ swap parse-url >r >r store-path r> >>host r> >>port ;
+
+! This is all pretty complex because it needs to handle
+! HTTP redirects, which might be absolute or relative
+: absolute-redirect ( url -- request )
+ request get request-with-url ;
+
+: relative-redirect ( path -- request )
+ request get swap store-path ;
+
+: do-redirect ( response -- response stream )
+ dup response-code 300 399 between? [
+ stdio get dispose
+ header>> "location" swap at
+ dup "http://" head? [
+ absolute-redirect
+ ] [
+ relative-redirect
+ ] if "GET" >>method http-request
+ ] [
+ stdio get
+ ] if ;
+
+: request-addr ( request -- addr )
+ dup host>> swap port>> <inet> ;
+
+: close-on-error ( stream quot -- )
+ '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
+
+PRIVATE>
+
+: http-request ( request -- response stream )
+ dup request [
+ dup request-addr latin1 <client>
+ 1 minutes over set-timeout
+ [
+ write-request flush
+ read-response
+ do-redirect
+ ] close-on-error
+ ] with-variable ;
+
+: <get-request> ( url -- request )
+ <request> request-with-url "GET" >>method ;
+
+: http-get-stream ( url -- response stream )
+ <get-request> http-request ;
: success? ( code -- ? ) 200 = ;
-: check-response ( code headers stream -- stream )
- nip swap success?
- [ dispose "HTTP download failed" throw ] unless ;
+: check-response ( response -- )
+ code>> success?
+ [ "HTTP download failed" throw ] unless ;
: http-get ( url -- string )
- http-get-stream check-response contents ;
+ http-get-stream contents swap check-response ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- >r http-get-stream check-response
- r> <file-writer> stream-copy ;
+ swap http-get-stream swap check-response
+ [ swap latin1 <file-writer> stream-copy ] with-disposal ;
: download ( url -- )
dup download-name download-to ;
-: post-request ( content-type content host resource -- )
- #! Note: It is up to the caller to url encode the content if
- #! it is required according to the content-type.
- "POST" http-request [
- "Content-Length: " write length number>string write crlf
- "Content-Type: " write url-encode write crlf
- crlf
- ] keep write ;
-
-: http-post ( content-type content url -- code headers string )
- #! Make a POST request. The content is URL encoded for you.
- parse-url over parse-host <inet> <client> [
- post-request flush read-response stdio get contents
- ] with-stream ;
+: <post-request> ( content-type content url -- request )
+ <request>
+ request-with-url
+ "POST" >>method
+ swap >>post-data
+ swap >>post-data-type ;
+
+: http-post ( content-type content url -- response string )
+ #! The content is URL encoded for you.
+ >r url-encode r> <post-request> http-request contents ;
-USING: http tools.test ;
-IN: temporary
+USING: http tools.test multiline tuple-syntax
+io.streams.string kernel arrays splitting sequences ;
+IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "/" ] [ "http://foo.com" url>path ] unit-test
+[ "/" ] [ "http://foo.com/" url>path ] unit-test
+[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
+[ "/bar" ] [ "/bar" url>path ] unit-test
+
+STRING: read-request-test-1
+GET http://foo/bar HTTP/1.1
+Some-Header: 1
+Some-Header: 2
+Content-Length: 4
+
+blah
+;
+
+[
+ TUPLE{ request
+ port: 80
+ method: "GET"
+ path: "/bar"
+ query: H{ }
+ version: "1.1"
+ header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
+ post-data: "blah"
+ cookies: V{ }
+ }
+] [
+ read-request-test-1 [
+ read-request
+ ] with-string-reader
+] unit-test
+
+STRING: read-request-test-1'
+GET /bar HTTP/1.1
+content-length: 4
+some-header: 1; 2
+
+blah
+;
+
+read-request-test-1' 1array [
+ read-request-test-1
+ [ read-request ] with-string-reader
+ [ write-request ] with-string-writer
+ ! normalize crlf
+ string-lines "\n" join
+] unit-test
+
+STRING: read-request-test-2
+HEAD http://foo/bar HTTP/1.1
+Host: www.sex.com
+;
+
+[
+ TUPLE{ request
+ port: 80
+ method: "HEAD"
+ path: "/bar"
+ query: H{ }
+ version: "1.1"
+ header: H{ { "host" "www.sex.com" } }
+ host: "www.sex.com"
+ cookies: V{ }
+ }
+] [
+ read-request-test-2 [
+ read-request
+ ] with-string-reader
+] unit-test
+
+STRING: read-response-test-1
+HTTP/1.1 404 not found
+Content-Type: text/html
+
+blah
+;
+
+[
+ TUPLE{ response
+ version: "1.1"
+ code: 404
+ message: "not found"
+ header: H{ { "content-type" "text/html" } }
+ cookies: V{ }
+ }
+] [
+ read-response-test-1
+ [ read-response ] with-string-reader
+] unit-test
+
+
+STRING: read-response-test-1'
+HTTP/1.1 404 not found
+content-type: text/html
+
+
+;
+
+read-response-test-1' 1array [
+ read-response-test-1
+ [ read-response ] with-string-reader
+ [ write-response ] with-string-writer
+ ! normalize crlf
+ string-lines "\n" join
+] unit-test
+
+[ t ] [
+ "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
+ dup parse-cookies unparse-cookies =
+] unit-test
+
+! Live-fire exercise
+USING: http.server http.server.static http.server.actions
+http.client io.server io.files io accessors namespaces threads
+io.encodings.ascii ;
+
+[ ] [
+ [
+ <dispatcher>
+ <action>
+ [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+ "quit" add-responder
+ "extra/http/test" resource-path <static> >>default
+ main-responder set
+
+ [ 1237 httpd ] "HTTPD test" spawn drop
+ ] with-scope
+] unit-test
+
+[ t ] [
+ "extra/http/test/foo.html" resource-path ascii file-contents
+ "http://localhost:1237/foo.html" http-get =
+] unit-test
+
+[ "Goodbye" ] [
+ "http://localhost:1237/quit" http-get
+] unit-test
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ascii io.encodings.utf8 assocs.lib
-namespaces unicode.case ;
+USING: fry hashtables io io.streams.string kernel math
+namespaces math.parser assocs sequences strings splitting ascii
+io.encodings.utf8 io.encodings.string namespaces unicode.case
+combinators vectors sorting new-slots accessors calendar
+calendar.format quotations arrays ;
IN: http
-: header-line ( line -- )
- ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
-
-: (read-header) ( -- )
- readln dup
- empty? [ drop ] [ header-line (read-header) ] if ;
-
-: read-header ( -- hash )
- [ (read-header) ] H{ } make-assoc ;
+: http-port 80 ; inline
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
over digit? or
swap "/_-." member? or ; foldable
-: push-utf8 ( string -- )
- 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+: push-utf8 ( ch -- )
+ 1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[ [
] if ;
: url-decode ( str -- str )
- [ 0 swap url-decode-iter ] "" make decode-utf8 ;
+ [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+: crlf "\r\n" write ;
+
+: add-header ( value key assoc -- )
+ [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
+
+: header-line ( line -- )
+ dup first blank? [
+ [ blank? ] left-trim
+ "last-header" get
+ "header" get
+ add-header
+ ] [
+ ": " split1 dup [
+ swap >lower dup "last-header" set
+ "header" get add-header
+ ] [
+ 2drop
+ ] if
+ ] if ;
+
+: read-header-line ( -- )
+ readln dup
+ empty? [ drop ] [ header-line read-header-line ] if ;
+
+: read-header ( -- assoc )
+ H{ } clone [
+ "header" [ read-header-line ] with-variable
+ ] keep ;
+
+: header-value>string ( value -- string )
+ {
+ { [ dup number? ] [ number>string ] }
+ { [ dup timestamp? ] [ timestamp>http-string ] }
+ { [ dup string? ] [ ] }
+ { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
+ } cond ;
-: hash>query ( hash -- str )
+: check-header-string ( str -- str )
+ #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
+ dup "\r\n" seq-intersect empty?
+ [ "Header injection attack" throw ] unless ;
+
+: write-header ( assoc -- )
+ >alist sort-keys [
+ swap url-encode write ": " write
+ header-value>string check-header-string write crlf
+ ] assoc-each crlf ;
+
+: query>assoc ( query -- assoc )
+ dup [
+ "&" split [
+ "=" split1 [ dup [ url-decode ] when ] 2apply
+ ] H{ } map>assoc
+ ] when ;
+
+: assoc>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
"&" join ;
-: build-url ( str query-params -- newstr )
+TUPLE: cookie name value path domain expires http-only ;
+
+: <cookie> ( value name -- cookie )
+ cookie construct-empty
+ swap >>name swap >>value ;
+
+: parse-cookies ( string -- seq )
[
- over %
- dup assoc-empty? [
- 2drop
- ] [
- CHAR: ? rot member? "&" "?" ? %
- hash>query %
- ] if
- ] "" make ;
+ f swap
+
+ ";" split [
+ [ blank? ] trim "=" split1 swap >lower {
+ { "expires" [ >>expires ] }
+ { "domain" [ >>domain ] }
+ { "path" [ >>path ] }
+ { "httponly" [ drop t >>http-only ] }
+ { "" [ drop ] }
+ [ <cookie> dup , nip ]
+ } case
+ ] each
+
+ drop
+ ] { } make ;
+
+: (unparse-cookie) ( key value -- )
+ {
+ { [ dup f eq? ] [ 2drop ] }
+ { [ dup t eq? ] [ drop , ] }
+ { [ t ] [ "=" swap 3append , ] }
+ } cond ;
+
+: unparse-cookie ( cookie -- strings )
+ [
+ dup name>> >lower over value>> (unparse-cookie)
+ "path" over path>> (unparse-cookie)
+ "domain" over domain>> (unparse-cookie)
+ "expires" over expires>> (unparse-cookie)
+ "httponly" over http-only>> (unparse-cookie)
+ drop
+ ] { } make ;
+
+: unparse-cookies ( cookies -- string )
+ [ unparse-cookie ] map concat "; " join ;
+
+TUPLE: request
+host
+port
+method
+path
+query
+version
+header
+post-data
+post-data-type
+cookies ;
+
+: <request>
+ request construct-empty
+ "1.1" >>version
+ http-port >>port
+ H{ } clone >>query
+ V{ } clone >>cookies ;
+
+: query-param ( request key -- value )
+ swap query>> at ;
+
+: set-query-param ( request value key -- request )
+ pick query>> set-at ;
+
+: chop-hostname ( str -- str' )
+ CHAR: / over index over length or tail
+ dup empty? [ drop "/" ] when ;
+
+: url>path ( url -- path )
+ #! Technically, only proxies are meant to support hostnames
+ #! in HTTP requests, but IE sends these sometimes so we
+ #! just chop the hostname part.
+ url-decode "http://" ?head [ chop-hostname ] when ;
+
+: read-method ( request -- request )
+ " " read-until [ "Bad request: method" throw ] unless
+ >>method ;
+
+: read-query ( request -- request )
+ " " read-until
+ [ "Bad request: query params" throw ] unless
+ query>assoc >>query ;
+
+: read-url ( request -- request )
+ " ?" read-until {
+ { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
+ { CHAR: ? [ url>path >>path read-query ] }
+ [ "Bad request: URL" throw ]
+ } case ;
+
+: parse-version ( string -- version )
+ "HTTP/" ?head [ "Bad version" throw ] unless
+ dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
+
+: read-request-version ( request -- request )
+ readln [ CHAR: \s = ] left-trim
+ parse-version
+ >>version ;
+
+: read-request-header ( request -- request )
+ read-header >>header ;
+
+: header ( request/response key -- value )
+ swap header>> at ;
+
+SYMBOL: max-post-request
+
+1024 256 * max-post-request set-global
+
+: content-length ( header -- n )
+ "content-length" swap at string>number dup [
+ dup max-post-request get > [
+ "content-length > max-post-request" throw
+ ] when
+ ] when ;
+
+: read-post-data ( request -- request )
+ dup header>> content-length [ read >>post-data ] when* ;
+
+: parse-host ( string -- host port )
+ "." ?tail drop ":" split1
+ [ string>number ] [ http-port ] if* ;
+
+: extract-host ( request -- request )
+ dup "host" header parse-host >r >>host r> >>port ;
+
+: extract-post-data-type ( request -- request )
+ dup "content-type" header >>post-data-type ;
+
+: extract-cookies ( request -- request )
+ dup "cookie" header [ parse-cookies >>cookies ] when* ;
+
+: read-request ( -- request )
+ <request>
+ read-method
+ read-url
+ read-request-version
+ read-request-header
+ read-post-data
+ extract-host
+ extract-post-data-type
+ extract-cookies ;
+
+: write-method ( request -- request )
+ dup method>> write bl ;
+
+: write-url ( request -- request )
+ dup path>> url-encode write
+ dup query>> dup assoc-empty? [ drop ] [
+ "?" write
+ assoc>query write
+ ] if ;
+
+: write-request-url ( request -- request )
+ write-url bl ;
+
+: write-version ( request -- request )
+ "HTTP/" write dup request-version write crlf ;
+
+: write-request-header ( request -- request )
+ dup header>> >hashtable
+ over host>> [ "host" pick set-at ] when*
+ over post-data>> [ length "content-length" pick set-at ] when*
+ over post-data-type>> [ "content-type" pick set-at ] when*
+ over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
+ write-header ;
+
+: write-post-data ( request -- request )
+ dup post-data>> [ write ] when* ;
+
+: write-request ( request -- )
+ write-method
+ write-request-url
+ write-version
+ write-request-header
+ write-post-data
+ flush
+ drop ;
+
+: request-url ( request -- url )
+ [
+ dup host>> [
+ "http://" write
+ dup host>> url-encode write
+ ":" write
+ dup port>> number>string write
+ ] when
+ dup path>> "/" head? [ "/" write ] unless
+ write-url
+ drop
+ ] with-string-writer ;
+
+: set-header ( request/response value key -- request/response )
+ pick header>> set-at ;
+
+GENERIC: write-response ( response -- )
+
+GENERIC: write-full-response ( request response -- )
+
+TUPLE: response
+version
+code
+message
+header
+cookies
+body ;
+
+: <response>
+ response construct-empty
+ "1.1" >>version
+ H{ } clone >>header
+ "close" "connection" set-header
+ now timestamp>http-string "date" set-header
+ V{ } clone >>cookies ;
+
+: read-response-version
+ " \t" read-until
+ [ "Bad response: version" throw ] unless
+ parse-version
+ >>version ;
+
+: read-response-code
+ " \t" read-until [ "Bad response: code" throw ] unless
+ string>number [ "Bad response: code" throw ] unless*
+ >>code ;
+
+: read-response-message
+ readln >>message ;
+
+: read-response-header
+ read-header >>header
+ dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
+
+: read-response ( -- response )
+ <response>
+ read-response-version
+ read-response-code
+ read-response-message
+ read-response-header ;
+
+: write-response-version ( response -- response )
+ "HTTP/" write
+ dup version>> write bl ;
+
+: write-response-code ( response -- response )
+ dup code>> number>string write bl ;
+
+: write-response-message ( response -- response )
+ dup message>> write crlf ;
+
+: write-response-header ( response -- response )
+ dup header>> clone
+ over cookies>> f like
+ [ 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 ] }
+ { [ t ] [ stdio get stream-copy ] }
+ } cond ;
+
+M: response write-response ( respose -- )
+ write-response-version
+ write-response-code
+ write-response-message
+ write-response-header
+ flush
+ drop ;
+
+M: response write-full-response ( request response -- )
+ dup write-response
+ swap method>> "HEAD" = [ write-response-body ] unless ;
+
+: set-content-type ( request/response content-type -- request/response )
+ "content-type" set-header ;
+
+: get-cookie ( request/response name -- cookie/f )
+ >r cookies>> r> '[ , _ name>> = ] find nip ;
+
+: delete-cookie ( request/response name -- )
+ over cookies>> >r get-cookie r> delete ;
+
+: put-cookie ( request/response cookie -- request/response )
+ [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
+ over cookies>> push ;
+
+TUPLE: raw-response
+version
+code
+message
+body ;
+
+: <raw-response> ( -- response )
+ raw-response construct-empty
+ "1.1" >>version ;
+
+M: raw-response write-response ( respose -- )
+ write-response-version
+ write-response-code
+ write-response-message
+ write-response-body
+ drop ;
+
+M: raw-response write-full-response ( response -- )
+ write-response nip ;
{ "pdf" "application/pdf" }
{ "factor" "text/plain" }
+ { "cgi" "application/x-cgi-script" }
{ "fhtml" "application/x-factor-server-page" }
} "mime-types" set-global
--- /dev/null
+IN: http.server.actions.tests
+USING: http.server.actions tools.test math math.parser
+multiline namespaces http io.streams.string http.server
+sequences accessors ;
+
+<action>
+ [ "a" get "b" get + ] >>display
+ { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
+"action-1" set
+
+STRING: action-request-test-1
+GET http://foo/bar?a=12&b=13 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-1 [ read-request ] with-string-reader
+ request set
+ "/blah"
+ "action-1" get call-responder
+] unit-test
+
+<action>
+ [ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
+ { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+"action-2" set
+
+STRING: action-request-test-2
+POST http://foo/bar/baz HTTP/1.1
+content-length: 5
+
+xxx=4
+;
+
+[ "/blahXXXX" ] [
+ action-request-test-2 [ read-request ] with-string-reader
+ request set
+ "/blah"
+ "action-2" get call-responder
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors new-slots sequences kernel assocs combinators\r
+http.server http.server.validators http hashtables namespaces\r
+combinators.cleave fry continuations ;\r
+IN: http.server.actions\r
+\r
+SYMBOL: +path+\r
+\r
+SYMBOL: params\r
+\r
+TUPLE: action init display submit get-params post-params ;\r
+\r
+: <action>\r
+ action construct-empty\r
+ [ ] >>init\r
+ [ <400> ] >>display\r
+ [ <400> ] >>submit ;\r
+\r
+: extract-params ( path -- assoc )\r
+ +path+ associate\r
+ request get dup method>> {\r
+ { "GET" [ query>> ] }\r
+ { "HEAD" [ query>> ] }\r
+ { "POST" [ post-data>> query>assoc ] }\r
+ } case union ;\r
+\r
+: with-validator ( string quot -- result error? )\r
+ '[ , @ f ] [\r
+ dup validation-error? [ t ] [ rethrow ] if\r
+ ] recover ; inline\r
+\r
+: validate-param ( name validator assoc -- error? )\r
+ swap pick\r
+ >r >r at r> with-validator swap r> set ;\r
+\r
+: action-params ( validators -- error? )\r
+ [ params get validate-param ] { } assoc>map [ ] contains? ;\r
+\r
+: handle-get ( -- response )\r
+ action get get-params>> action-params [ <400> ] [\r
+ action get [ init>> call ] [ display>> call ] bi\r
+ ] if ;\r
+\r
+: handle-post ( -- response )\r
+ action get post-params>> action-params\r
+ [ <400> ] [ action get submit>> call ] if ;\r
+\r
+: validation-failed ( -- * )\r
+ action get display>> call exit-with ;\r
+\r
+M: action call-responder ( path action -- response )\r
+ [ extract-params params set ]\r
+ [\r
+ action set\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case\r
+ ] bi* ;\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: http.server.sessions accessors\r
+http.server.auth.providers ;\r
+IN: http.server.auth\r
+\r
+SYMBOL: logged-in-user\r
+\r
+: uid ( -- string ) logged-in-user sget username>> ;\r
--- /dev/null
+! Copyright (c) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors new-slots quotations assocs kernel splitting\r
+base64 html.elements io combinators http.server\r
+http.server.auth.providers http.server.auth.providers.null\r
+http sequences ;\r
+IN: http.server.auth.basic\r
+\r
+TUPLE: basic-auth responder realm provider ;\r
+\r
+C: <basic-auth> basic-auth\r
+\r
+: authorization-ok? ( provider header -- ? )\r
+ #! Given the realm and the 'Authorization' header,\r
+ #! authenticate the user.\r
+ dup [\r
+ " " split1 swap "Basic" = [\r
+ base64> ":" split1 spin check-login\r
+ ] [\r
+ 2drop f\r
+ ] if\r
+ ] [\r
+ 2drop f\r
+ ] if ;\r
+\r
+: <401> ( realm -- response )\r
+ 401 "Unauthorized" <trivial-response>\r
+ "Basic realm=\"" rot "\"" 3append\r
+ "WWW-Authenticate" set-header\r
+ [\r
+ <html> <body>\r
+ "Username or Password is invalid" write\r
+ </body> </html>\r
+ ] >>body ;\r
+\r
+: logged-in? ( request responder -- ? )\r
+ provider>> swap "authorization" header authorization-ok? ;\r
+\r
+M: basic-auth call-responder ( request path responder -- response )\r
+ pick over logged-in?\r
+ [ responder>> call-responder ] [ 2nip realm>> <401> ] if ;\r
--- /dev/null
+IN: http.server.auth.login.tests\r
+USING: tools.test http.server.auth.login ;\r
+\r
+\ <login> must-infer\r
+\ allow-registration must-infer\r
+\ allow-password-recovery must-infer\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors new-slots quotations assocs kernel splitting\r
+base64 html.elements io combinators http.server\r
+http.server.auth.providers http.server.auth.providers.null\r
+http.server.actions http.server.components http.server.sessions\r
+http.server.templating.fhtml http.server.validators\r
+http.server.auth http sequences io.files namespaces hashtables\r
+fry io.sockets combinators.cleave arrays threads locals\r
+qualified ;\r
+IN: http.server.auth.login\r
+QUALIFIED: smtp\r
+\r
+TUPLE: login users ;\r
+\r
+SYMBOL: post-login-url\r
+SYMBOL: login-failed?\r
+\r
+! ! ! Login\r
+\r
+: <login-form>\r
+ "login" <form>\r
+ "resource:extra/http/server/auth/login/login.fhtml" >>edit-template\r
+ "username" <username>\r
+ t >>required\r
+ add-field\r
+ "password" <password>\r
+ t >>required\r
+ add-field ;\r
+\r
+: successful-login ( user -- response )\r
+ logged-in-user sset\r
+ post-login-url sget f <permanent-redirect> ;\r
+\r
+:: <login-action> ( -- action )\r
+ [let | form [ <login-form> ] |\r
+ <action>\r
+ [ blank-values ] >>init\r
+\r
+ [\r
+ "text/html" <content>\r
+ [ form edit-form ] >>body\r
+ ] >>display\r
+\r
+ [\r
+ blank-values\r
+\r
+ form validate-form\r
+\r
+ "password" value "username" value\r
+ login get users>> check-login [\r
+ successful-login\r
+ ] [\r
+ login-failed? on\r
+ validation-failed\r
+ ] if*\r
+ ] >>submit\r
+ ] ;\r
+\r
+! ! ! New user registration\r
+\r
+: <register-form> ( -- form )\r
+ "register" <form>\r
+ "resource:extra/http/server/auth/login/register.fhtml" >>edit-template\r
+ "username" <username>\r
+ t >>required\r
+ add-field\r
+ "realname" <string> add-field\r
+ "password" <password>\r
+ t >>required\r
+ add-field\r
+ "verify-password" <password>\r
+ t >>required\r
+ add-field\r
+ "email" <email> add-field\r
+ "captcha" <captcha> add-field ;\r
+\r
+SYMBOL: password-mismatch?\r
+SYMBOL: user-exists?\r
+\r
+: same-password-twice ( -- )\r
+ "password" value "verify-password" value = [ \r
+ password-mismatch? on\r
+ validation-failed\r
+ ] unless ;\r
+\r
+:: <register-action> ( -- action )\r
+ [let | form [ <register-form> ] |\r
+ <action>\r
+ [ blank-values ] >>init\r
+\r
+ [\r
+ "text/html" <content>\r
+ [ form edit-form ] >>body\r
+ ] >>display\r
+\r
+ [\r
+ blank-values\r
+\r
+ form validate-form\r
+\r
+ same-password-twice\r
+\r
+ <user> values get [\r
+ "username" get >>username\r
+ "realname" get >>realname\r
+ "password" get >>password\r
+ "email" get >>email\r
+ ] bind\r
+\r
+ login get users>> new-user [\r
+ user-exists? on\r
+ validation-failed\r
+ ] unless*\r
+\r
+ successful-login\r
+ ] >>submit\r
+ ] ;\r
+\r
+! ! ! Password recovery\r
+\r
+SYMBOL: lost-password-from\r
+\r
+: current-host ( -- string )\r
+ request get host>> host-name or ;\r
+\r
+: new-password-url ( user -- url )\r
+ "new-password"\r
+ swap [\r
+ [ username>> "username" set ]\r
+ [ ticket>> "ticket" set ]\r
+ bi\r
+ ] H{ } make-assoc\r
+ derive-url ;\r
+\r
+: password-email ( user -- email )\r
+ smtp:<email>\r
+ [ "[ " % current-host % " ] password recovery" % ] "" make >>subject\r
+ lost-password-from get >>from\r
+ over email>> 1array >>to\r
+ [\r
+ "This e-mail was sent by the application server on " % current-host % "\n" %\r
+ "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %\r
+ "login form, and requested a new password for the user named ``" %\r
+ over username>> % "''.\n" %\r
+ "\n" %\r
+ "If you believe that this request was legitimate, you may click the below link in\n" %\r
+ "your browser to set a new password for your account:\n" %\r
+ "\n" %\r
+ swap new-password-url %\r
+ "\n\n" %\r
+ "Love,\n" %\r
+ "\n" %\r
+ " FactorBot\n" %\r
+ ] "" make >>body ;\r
+\r
+: send-password-email ( user -- )\r
+ '[ , password-email smtp:send-email ]\r
+ "E-mail send thread" spawn drop ;\r
+\r
+: <recover-form-1> ( -- form )\r
+ "register" <form>\r
+ "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template\r
+ "username" <username>\r
+ t >>required\r
+ add-field\r
+ "email" <email>\r
+ t >>required\r
+ add-field\r
+ "captcha" <captcha> add-field ;\r
+\r
+:: <recover-action-1> ( -- action )\r
+ [let | form [ <recover-form-1> ] |\r
+ <action>\r
+ [ blank-values ] >>init\r
+\r
+ [\r
+ "text/html" <content>\r
+ [ form edit-form ] >>body\r
+ ] >>display\r
+\r
+ [\r
+ blank-values\r
+\r
+ form validate-form\r
+\r
+ "email" value "username" value\r
+ login get users>> issue-ticket [\r
+ send-password-email\r
+ ] when*\r
+\r
+ "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template\r
+ ] >>submit\r
+ ] ;\r
+\r
+: <recover-form-3>\r
+ "new-password" <form>\r
+ "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template\r
+ "username" <username> <hidden>\r
+ t >>required\r
+ add-field\r
+ "password" <password>\r
+ t >>required\r
+ add-field\r
+ "verify-password" <password>\r
+ t >>required\r
+ add-field\r
+ "ticket" <string> <hidden>\r
+ t >>required\r
+ add-field ;\r
+\r
+:: <recover-action-3> ( -- action )\r
+ [let | form [ <recover-form-3> ] |\r
+ <action>\r
+ [\r
+ { "username" [ v-required ] }\r
+ { "ticket" [ v-required ] }\r
+ ] >>get-params\r
+\r
+ [\r
+ [\r
+ "username" [ get ] keep set\r
+ "ticket" [ get ] keep set\r
+ ] H{ } make-assoc values set\r
+ ] >>init\r
+\r
+ [\r
+ "text/html" <content>\r
+ [ <recover-form-3> edit-form ] >>body\r
+ ] >>display\r
+\r
+ [\r
+ blank-values\r
+\r
+ form validate-form\r
+\r
+ same-password-twice\r
+\r
+ "ticket" value\r
+ "username" value\r
+ login get users>> claim-ticket [\r
+ "password" value >>password\r
+ login get users>> update-user\r
+\r
+ "resource:extra/http/server/auth/login/recover-4.fhtml"\r
+ serve-template\r
+ ] [\r
+ <400>\r
+ ] if*\r
+ ] >>submit\r
+ ] ;\r
+\r
+! ! ! Logout\r
+: <logout-action> ( -- action )\r
+ <action>\r
+ [\r
+ f logged-in-user sset\r
+ "login" f <permanent-redirect>\r
+ ] >>submit ;\r
+\r
+! ! ! Authentication logic\r
+\r
+TUPLE: protected responder ;\r
+\r
+C: <protected> protected\r
+\r
+M: protected call-responder ( path responder -- response )\r
+ logged-in-user sget [ responder>> call-responder ] [\r
+ 2drop\r
+ request get method>> { "GET" "HEAD" } member? [\r
+ request get request-url post-login-url sset\r
+ "login" f <permanent-redirect>\r
+ ] [ <400> ] if\r
+ ] if ;\r
+\r
+M: login call-responder ( path responder -- response )\r
+ dup login set\r
+ delegate call-responder ;\r
+\r
+: <login> ( responder -- auth )\r
+ login <webapp>\r
+ swap <protected> >>default\r
+ <login-action> "login" add-responder\r
+ <logout-action> "logout" add-responder\r
+ no >>users ;\r
+\r
+! ! ! Configuration\r
+\r
+: allow-registration ( login -- login )\r
+ <register-action> "register" add-responder ;\r
+\r
+: allow-password-recovery ( login -- login )\r
+ <recover-action-1> "recover-password" add-responder\r
+ <recover-action-3> "new-password" add-responder ;\r
+\r
+: allow-registration? ( -- ? )\r
+ login get responders>> "register" swap key? ;\r
+\r
+: allow-password-recovery? ( -- ? )\r
+ login get responders>> "recover-password" swap key? ;\r
--- /dev/null
+<% USING: http.server.auth.login http.server.components kernel\r
+namespaces ; %>\r
+<html>\r
+<body>\r
+<h1>Login required</h1>\r
+\r
+<form method="POST" action="login">\r
+<table>\r
+\r
+<tr>\r
+<td>User name:</td>\r
+<td><% "username" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Password:</td>\r
+<td><% "password" component render-edit %></td>\r
+</tr>\r
+\r
+</table>\r
+\r
+<p><input type="submit" value="Log in" />\r
+<%\r
+login-failed? get\r
+[ "Invalid username or password" render-error ] when\r
+%>\r
+</p>\r
+\r
+</form>\r
+\r
+<p>\r
+<% allow-registration? [ %>\r
+ <a href="register">Register</a>\r
+<% ] when %>\r
+<% allow-password-recovery? [ %>\r
+ <a href="recover-password">Recover Password</a>\r
+<% ] when %>\r
+</p>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+<% USING: http.server.components ; %>\r
+<html>\r
+<body>\r
+<h1>Recover lost password: step 1 of 4</h1>\r
+\r
+<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>\r
+\r
+<form method="POST" action="recover-password">\r
+<table>\r
+\r
+<tr>\r
+<td>User name:</td>\r
+<td><% "username" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>E-mail:</td>\r
+<td><% "email" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Captcha:</td>\r
+<td><% "captcha" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>\r
+</tr>\r
+\r
+</table>\r
+\r
+<input type="submit" value="Recover password" />\r
+\r
+</form>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+<% USING: http.server.components ; %>\r
+<html>\r
+<body>\r
+<h1>Recover lost password: step 2 of 4</h1>\r
+\r
+<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>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+<% USING: http.server.components http.server.auth.login\r
+namespaces kernel combinators ; %>\r
+<html>\r
+<body>\r
+<h1>Recover lost password: step 3 of 4</h1>\r
+\r
+<p>Choose a new password for your account.</p>\r
+\r
+<form method="POST" action="new-password">\r
+<table>\r
+\r
+<% "username" component render-edit %>\r
+<% "ticket" component render-edit %>\r
+\r
+<tr>\r
+<td>Password:</td>\r
+<td><% "password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Verify password:</td>\r
+<td><% "verify-password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Enter your password twice to ensure it is correct.</td>\r
+</tr>\r
+\r
+</table>\r
+\r
+<p><input type="submit" value="Set password" />\r
+\r
+<% password-mismatch? get [\r
+"passwords do not match" render-error\r
+] when %>\r
+\r
+</p>\r
+\r
+</form>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+<% USING: http.server.components http.server.auth.login\r
+namespaces kernel combinators ; %>\r
+<html>\r
+<body>\r
+<h1>Recover lost password: step 4 of 4</h1>\r
+\r
+<p>Your password has been reset. You may now <a href="login">log in</a>.</p>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+<% USING: http.server.components http.server.auth.login\r
+namespaces kernel combinators ; %>\r
+<html>\r
+<body>\r
+<h1>New user registration</h1>\r
+\r
+<form method="POST" action="register">\r
+<table>\r
+\r
+<tr>\r
+<td>User name:</td>\r
+<td><% "username" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Real name:</td>\r
+<td><% "realname" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Specifying a real name is optional.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Password:</td>\r
+<td><% "password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Verify:</td>\r
+<td><% "verify-password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Enter your password twice to ensure it is correct.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td>E-mail:</td>\r
+<td><% "email" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Captcha:</td>\r
+<td><% "captcha" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>\r
+</tr>\r
+\r
+</table>\r
+\r
+<p><input type="submit" value="Register" />\r
+\r
+<% {\r
+ { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
+ { [ user-exists? get ] [ "username taken" render-error ] }\r
+ { [ t ] [ ] }\r
+} cond %>\r
+\r
+</p>\r
+\r
+</form>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+IN: http.server.auth.providers.assoc.tests\r
+USING: http.server.auth.providers \r
+http.server.auth.providers.assoc tools.test\r
+namespaces accessors kernel ;\r
+\r
+<in-memory> "provider" set\r
+\r
+[ t ] [\r
+ <user>\r
+ "slava" >>username\r
+ "foobar" >>password\r
+ "slava@factorcode.org" >>email\r
+ "provider" get new-user\r
+ username>> "slava" =\r
+] unit-test\r
+\r
+[ f ] [\r
+ <user>\r
+ "slava" >>username\r
+ "provider" get new-user\r
+] unit-test\r
+\r
+[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+\r
+[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+\r
+[ f ] [ "xx" "blah" "provider" get set-password ] unit-test\r
+\r
+[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test\r
+\r
+[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+\r
+[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+IN: http.server.auth.providers.assoc\r
+USING: new-slots accessors assocs kernel\r
+http.server.auth.providers ;\r
+\r
+TUPLE: in-memory assoc ;\r
+\r
+: <in-memory> ( -- provider )\r
+ H{ } clone in-memory construct-boa ;\r
+\r
+M: in-memory get-user ( username provider -- user/f )\r
+ assoc>> at ;\r
+\r
+M: in-memory update-user ( user provider -- ) 2drop ;\r
+\r
+M: in-memory new-user ( user provider -- user/f )\r
+ >r dup username>> r> assoc>>\r
+ 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;\r
--- /dev/null
+IN: http.server.auth.providers.db.tests\r
+USING: http.server.auth.providers\r
+http.server.auth.providers.db tools.test\r
+namespaces db db.sqlite db.tuples continuations\r
+io.files accessors kernel ;\r
+\r
+from-db "provider" set\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+\r
+ [ user drop-table ] ignore-errors\r
+ [ user create-table ] ignore-errors\r
+\r
+ [ t ] [\r
+ <user>\r
+ "slava" >>username\r
+ "foobar" >>password\r
+ "slava@factorcode.org" >>email\r
+ "provider" get new-user\r
+ username>> "slava" =\r
+ ] unit-test\r
+\r
+ [ f ] [\r
+ <user>\r
+ "slava" >>username\r
+ "provider" get new-user\r
+ ] unit-test\r
+\r
+ [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+\r
+ [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+\r
+ [ f ] [ "xx" "blah" "provider" get set-password ] unit-test\r
+\r
+ [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test\r
+\r
+ [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+\r
+ [ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: db db.tuples db.types new-slots accessors\r
+http.server.auth.providers kernel continuations ;\r
+IN: http.server.auth.providers.db\r
+\r
+user "USERS"\r
+{\r
+ { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }\r
+ { "realname" "REALNAME" { VARCHAR 256 } }\r
+ { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }\r
+ { "email" "EMAIL" { VARCHAR 256 } }\r
+ { "ticket" "TICKET" { VARCHAR 256 } }\r
+ { "profile" "PROFILE" FACTOR-BLOB }\r
+} define-persistent\r
+\r
+: init-users-table ( -- )\r
+ [ user drop-table ] ignore-errors\r
+ user create-table ;\r
+\r
+TUPLE: from-db ;\r
+\r
+: from-db T{ from-db } ;\r
+\r
+: find-user ( username -- user )\r
+ <user>\r
+ swap >>username\r
+ select-tuple ;\r
+\r
+M: from-db get-user\r
+ drop\r
+ find-user ;\r
+\r
+M: from-db new-user\r
+ drop\r
+ [\r
+ dup username>> find-user [\r
+ drop f\r
+ ] [\r
+ dup insert-tuple\r
+ ] if\r
+ ] with-transaction ;\r
+\r
+M: from-db update-user\r
+ drop update-tuple ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: http.server.auth.providers kernel ;\r
+IN: http.server.auth.providers.null\r
+\r
+! Named "no" because we can say no >>users\r
+\r
+TUPLE: no ;\r
+\r
+: no T{ no } ;\r
+\r
+M: no get-user 2drop f ;\r
+\r
+M: no new-user 2drop f ;\r
+\r
+M: no update-user 2drop ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel new-slots accessors random math.parser locals\r
+sequences math ;\r
+IN: http.server.auth.providers\r
+\r
+TUPLE: user username realname password email ticket profile ;\r
+\r
+: <user> user construct-empty H{ } clone >>profile ;\r
+\r
+GENERIC: get-user ( username provider -- user/f )\r
+\r
+GENERIC: update-user ( user provider -- )\r
+\r
+GENERIC: new-user ( user provider -- user/f )\r
+\r
+: check-login ( password username provider -- user/f )\r
+ get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;\r
+\r
+:: set-password ( password username provider -- ? )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user\r
+ password >>password\r
+ provider update-user t\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+! Password recovery support\r
+\r
+:: issue-ticket ( email username provider -- user/f )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user email>> length 0 > [\r
+ user email>> email = [\r
+ user\r
+ random-256 >hex >>ticket\r
+ dup provider update-user\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+:: claim-ticket ( ticket username provider -- user/f )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user ticket>> ticket = [\r
+ user f >>ticket dup provider update-user\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+! For configuration\r
+\r
+: add-user ( provider user -- provider )\r
+ over new-user [ "User exists" throw ] when ;\r
--- /dev/null
+IN: http.server.callbacks\r
+USING: http.server.actions http.server.callbacks accessors\r
+http.server http tools.test namespaces io fry sequences\r
+splitting kernel hashtables continuations ;\r
+\r
+[ 123 ] [\r
+ [\r
+ <request> "GET" >>method request set\r
+ [\r
+ exit-continuation set\r
+ "xxx"\r
+ <action> [ [ "hello" print 123 ] show-final ] >>display\r
+ <callback-responder>\r
+ call-responder\r
+ ] callcc1\r
+ ] with-scope\r
+] unit-test\r
+\r
+[\r
+ <action> [\r
+ [\r
+ "hello" print\r
+ "text/html" <content> swap '[ , write ] >>body\r
+ ] show-page\r
+ "byebye" print\r
+ [ 123 ] show-final\r
+ ] >>display\r
+ <callback-responder> "r" set\r
+\r
+ [ 123 ] [\r
+ [\r
+ exit-continuation set\r
+ <request> "GET" >>method request set\r
+ "" "r" get call-responder\r
+ ] callcc1\r
+\r
+ body>> first\r
+\r
+ <request>\r
+ "GET" >>method\r
+ swap cont-id associate >>query\r
+ "/" >>path\r
+ request set\r
+\r
+ [\r
+ exit-continuation set\r
+ "/"\r
+ "r" get call-responder\r
+ ] callcc1\r
+\r
+ ! get-post-get\r
+ <request>\r
+ "GET" >>method\r
+ swap "location" header "=" last-split1 nip cont-id associate >>query\r
+ "/" >>path\r
+ request set\r
+\r
+ [\r
+ exit-continuation set\r
+ "/"\r
+ "r" get call-responder\r
+ ] callcc1\r
+ ] unit-test\r
+] with-scope\r
--- /dev/null
+! Copyright (C) 2004 Chris Double.\r
+! Copyright (C) 2006, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: html http http.server io kernel math namespaces\r
+continuations calendar sequences assocs new-slots hashtables\r
+accessors arrays alarms quotations combinators\r
+combinators.cleave fry ;\r
+IN: http.server.callbacks\r
+\r
+SYMBOL: responder\r
+\r
+TUPLE: callback-responder responder callbacks ;\r
+\r
+: <callback-responder> ( responder -- responder' )\r
+ #! A continuation responder is a special type of session\r
+ #! manager. However it works entirely differently from\r
+ #! the URL and cookie session managers.\r
+ H{ } clone callback-responder construct-boa ;\r
+\r
+TUPLE: callback cont quot expires alarm responder ;\r
+\r
+: timeout 20 minutes ;\r
+\r
+: timeout-callback ( callback -- )\r
+ [ alarm>> cancel-alarm ]\r
+ [ dup responder>> callbacks>> delete-at ]\r
+ bi ;\r
+\r
+: touch-callback ( callback -- )\r
+ dup expires>> [\r
+ dup alarm>> [ cancel-alarm ] when*\r
+ dup '[ , timeout-callback ] timeout later >>alarm\r
+ ] when drop ;\r
+\r
+: <callback> ( cont quot expires? -- callback )\r
+ f callback-responder get callback construct-boa\r
+ dup touch-callback ;\r
+\r
+: invoke-callback ( callback -- response )\r
+ [ touch-callback ]\r
+ [ quot>> request get exit-continuation get 3array ]\r
+ [ cont>> continue-with ]\r
+ tri ;\r
+\r
+: register-callback ( cont quot expires? -- id )\r
+ <callback> callback-responder get callbacks>> set-at-unique ;\r
+\r
+: forward-to-url ( url query -- * )\r
+ #! When executed inside a 'show' call, this will force a\r
+ #! HTTP 302 to occur to instruct the browser to forward to\r
+ #! the request URL.\r
+ <temporary-redirect> exit-with ;\r
+\r
+: cont-id "factorcontid" ;\r
+\r
+: forward-to-id ( id -- * )\r
+ #! When executed inside a 'show' call, this will force a\r
+ #! HTTP 302 to occur to instruct the browser to forward to\r
+ #! the request URL.\r
+ f swap cont-id associate forward-to-url ;\r
+\r
+: restore-request ( pair -- )\r
+ first3 exit-continuation set request set call ;\r
+\r
+SYMBOL: post-refresh-get?\r
+\r
+: redirect-to-here ( -- )\r
+ #! Force a redirect to the client browser so that the browser\r
+ #! goes to the current point in the code. This forces an URL\r
+ #! change on the browser so that refreshing that URL will\r
+ #! immediately run from this code point. This prevents the\r
+ #! "this request will issue a POST" warning from the browser\r
+ #! and prevents re-running the previous POST logic. This is\r
+ #! known as the 'post-refresh-get' pattern.\r
+ post-refresh-get? get [\r
+ [\r
+ [ ] t register-callback forward-to-id\r
+ ] callcc1 restore-request\r
+ ] [\r
+ post-refresh-get? on\r
+ ] if ;\r
+\r
+SYMBOL: current-show\r
+\r
+: store-current-show ( -- )\r
+ #! Store the current continuation in the variable 'current-show'\r
+ #! so it can be returned to later by 'quot-id'. Note that it\r
+ #! recalls itself when the continuation is called to ensure that\r
+ #! it resets its value back to the most recent show call.\r
+ [ current-show set f ] callcc1\r
+ [ restore-request store-current-show ] when* ;\r
+\r
+: show-final ( quot -- * )\r
+ >r redirect-to-here store-current-show r>\r
+ call exit-with ; inline\r
+\r
+: resuming-callback ( responder request -- id )\r
+ cont-id query-param swap callbacks>> at ;\r
+\r
+M: callback-responder call-responder ( path responder -- response )\r
+ [ callback-responder set ]\r
+ [ request get resuming-callback ] bi\r
+\r
+ [ invoke-callback ]\r
+ [ callback-responder get responder>> call-responder ] ?if ;\r
+\r
+: show-page ( quot -- )\r
+ >r redirect-to-here store-current-show r>\r
+ [\r
+ [ ] t register-callback swap call exit-with\r
+ ] callcc1 restore-request ; inline\r
+\r
+: quot-id ( quot -- id )\r
+ current-show get swap t register-callback ;\r
+\r
+: quot-url ( quot -- url )\r
+ quot-id f swap cont-id associate derive-url ;\r
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: namespaces kernel assocs io.files combinators\r
+arrays io.launcher io http.server.static http.server\r
+http accessors sequences strings math.parser fry ;\r
+IN: http.server.cgi\r
+\r
+: post? request get method>> "POST" = ;\r
+\r
+: cgi-variables ( script-path -- assoc )\r
+ #! This needs some work.\r
+ [\r
+ "CGI/1.0" "GATEWAY_INTERFACE" set\r
+ "HTTP/" request get version>> append "SERVER_PROTOCOL" set\r
+ "Factor" "SERVER_SOFTWARE" set\r
+\r
+ dup "PATH_TRANSLATED" set\r
+ "SCRIPT_FILENAME" set\r
+\r
+ request get path>> "SCRIPT_NAME" set\r
+\r
+ request get host>> "SERVER_NAME" set\r
+ request get port>> number>string "SERVER_PORT" set\r
+ "" "PATH_INFO" set\r
+ "" "REMOTE_HOST" set\r
+ "" "REMOTE_ADDR" set\r
+ "" "AUTH_TYPE" set\r
+ "" "REMOTE_USER" set\r
+ "" "REMOTE_IDENT" set\r
+\r
+ request get method>> "REQUEST_METHOD" set\r
+ request get query>> assoc>query "QUERY_STRING" set\r
+ request get "cookie" header "HTTP_COOKIE" set \r
+\r
+ request get "user-agent" header "HTTP_USER_AGENT" set\r
+ request get "accept" header "HTTP_ACCEPT" set\r
+\r
+ post? [\r
+ request get post-data-type>> "CONTENT_TYPE" set\r
+ request get post-data>> length number>string "CONTENT_LENGTH" set\r
+ ] when\r
+ ] H{ } make-assoc ;\r
+\r
+: <cgi-process> ( name -- desc )\r
+ <process>\r
+ over 1array >>command\r
+ swap cgi-variables >>environment ;\r
+\r
+: serve-cgi ( name -- response )\r
+ <raw-response>\r
+ 200 >>code\r
+ "CGI output follows" >>message\r
+ swap '[\r
+ , stdio get swap <cgi-process> <process-stream> [\r
+ post? [ request get post-data>> write flush ] when\r
+ stdio get swap (stream-copy)\r
+ ] with-stream\r
+ ] >>body ;\r
+\r
+: enable-cgi ( responder -- responder )\r
+ [ serve-cgi ] "application/x-cgi-script"\r
+ pick special>> set-at ;\r
--- /dev/null
+IN: http.server.components.tests\r
+USING: http.server.components http.server.validators\r
+namespaces tools.test kernel accessors new-slots\r
+tuple-syntax mirrors http.server.actions ;\r
+\r
+validation-failed? off\r
+\r
+[ 3 ] [ "3" "n" <number> validate ] unit-test\r
+\r
+[ 123 ] [\r
+ ""\r
+ "n" <number>\r
+ 123 >>default\r
+ validate\r
+] unit-test\r
+\r
+[ f ] [ validation-failed? get ] unit-test\r
+\r
+[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test\r
+\r
+[ t ] [ validation-failed? get ] unit-test\r
+\r
+[ "" ] [ "" "email" <email> validate ] unit-test\r
+\r
+[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test\r
+\r
+[ "slava@jedit.org" ] [\r
+ "slava@jedit.org"\r
+ "email" <email>\r
+ t >>required\r
+ validate\r
+] unit-test\r
+\r
+[ t ] [\r
+ "a"\r
+ "email" <email>\r
+ t >>required\r
+ validate validation-error?\r
+] unit-test\r
+\r
+[ t ] [ "a" "email" <email> validate validation-error? ] unit-test\r
+\r
+TUPLE: test-tuple text number more-text ;\r
+\r
+: <test-tuple> test-tuple construct-empty ;\r
+\r
+: <test-form> ( -- form )\r
+ "test" <form>\r
+ "resource:extra/http/server/components/test/form.fhtml" >>view-template\r
+ "resource:extra/http/server/components/test/form.fhtml" >>edit-template\r
+ "text" <string>\r
+ t >>required\r
+ add-field\r
+ "number" <number>\r
+ 123 >>default\r
+ t >>required\r
+ 0 >>min-value\r
+ 10 >>max-value\r
+ add-field\r
+ "more-text" <text>\r
+ "hi" >>default\r
+ add-field ;\r
+\r
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test\r
+\r
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test\r
+\r
+[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [\r
+ <test-tuple> from-tuple\r
+ <test-form> set-defaults\r
+ values-tuple\r
+] unit-test\r
+\r
+[\r
+ H{\r
+ { "text" "fdafsa" }\r
+ { "number" "xxx" }\r
+ { "more-text" "" }\r
+ } params set\r
+\r
+ H{ } clone values set\r
+\r
+ [ t ] [ <test-form> (validate-form) ] unit-test\r
+\r
+ [ "fdafsa" ] [ "text" value ] unit-test\r
+\r
+ [ t ] [ "number" value validation-error? ] unit-test\r
+] with-scope\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: new-slots html.elements http.server.validators accessors
+namespaces kernel io math.parser assocs classes words tuples
+arrays sequences io.files http.server.templating.fhtml
+http.server.actions splitting mirrors hashtables
+combinators.cleave fry continuations math ;
+IN: http.server.components
+
+SYMBOL: validation-failed?
+
+SYMBOL: components
+
+TUPLE: component id required default ;
+
+: component ( name -- component )
+ dup components get at
+ [ ] [ "No such component: " swap append throw ] ?if ;
+
+GENERIC: validate* ( value component -- result )
+GENERIC: render-view* ( value component -- )
+GENERIC: render-edit* ( value component -- )
+GENERIC: render-error* ( reason value component -- )
+
+SYMBOL: values
+
+: value values get at ;
+
+: set-value values get set-at ;
+
+: validate ( value component -- result )
+ '[
+ , ,
+ over empty? [
+ [ default>> [ v-default ] when* ]
+ [ required>> [ v-required ] when ]
+ bi
+ ] [ validate* ] if
+ ] [
+ dup validation-error?
+ [ validation-failed? on ] [ rethrow ] if
+ ] recover ;
+
+: 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 construct-empty
+ 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 ;
+
+! String input fields
+TUPLE: string min-length max-length ;
+
+: <string> ( id -- component ) string <component> ;
+
+M: string validate*
+ [ v-one-line ] [
+ [ min-length>> [ v-min-length ] when* ]
+ [ max-length>> [ v-max-length ] when* ]
+ bi
+ ] bi* ;
+
+M: string render-view*
+ drop write ;
+
+M: string render-edit*
+ "text" render-input ;
+
+M: string render-error*
+ "text" render-input render-error ;
+
+! Username fields
+TUPLE: username ;
+
+: <username> ( id -- component )
+ <string> username construct-delegate
+ 2 >>min-length
+ 20 >>max-length ;
+
+M: username validate*
+ delegate validate* v-one-word ;
+
+! E-mail fields
+TUPLE: email ;
+
+: <email> ( id -- component )
+ <string> email construct-delegate
+ 5 >>min-length
+ 60 >>max-length ;
+
+M: email validate*
+ delegate validate* dup empty? [ v-email ] unless ;
+
+! Password fields
+TUPLE: password ;
+
+: <password> ( id -- component )
+ <string> password construct-delegate
+ 6 >>min-length
+ 60 >>max-length ;
+
+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 ;
+
+! Number fields
+TUPLE: number min-value max-value ;
+
+: <number> ( id -- component ) number <component> ;
+
+M: number validate*
+ [ v-number ] [
+ [ min-value>> [ v-min-value ] when* ]
+ [ max-value>> [ v-max-value ] when* ]
+ bi
+ ] bi* ;
+
+M: number render-view*
+ drop number>string write ;
+
+M: number render-edit*
+ >r number>string r> "text" render-input ;
+
+M: number render-error*
+ "text" render-input render-error ;
+
+! Text areas
+TUPLE: text ;
+
+: <text> ( id -- component ) <string> text construct-delegate ;
+
+: render-textarea
+ <textarea
+ id>> [ =id ] [ =name ] bi
+ textarea>
+ write
+ </textarea> ;
+
+M: text render-edit*
+ render-textarea ;
+
+M: text render-error*
+ render-textarea render-error ;
+
+! Simple captchas
+TUPLE: captcha ;
+
+: <captcha> ( id -- component )
+ <string> captcha construct-delegate ;
+
+M: captcha validate*
+ drop v-captcha ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: splitting http.server.components kernel io sequences\r
+farkup ;\r
+IN: http.server.components.farkup\r
+\r
+TUPLE: farkup ;\r
+\r
+: <farkup> ( id -- component )\r
+ <text> farkup construct-delegate ;\r
+\r
+M: farkup render-view*\r
+ drop string-lines "\n" join convert-farkup write ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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>
+ { { "id" [ v-number ] } } >>get-params
+
+ [ "id" get ctor call select-tuple from-tuple ] >>init
+
+ [
+ "text/html" <content>
+ [ form view-form ] >>body
+ ] >>display ;
+
+: <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
+
+ [
+ "text/html" <content>
+ [ form edit-form ] >>body
+ ] >>display
+
+ [
+ f ctor call from-tuple
+
+ form validate-form
+
+ values-tuple update-tuple
+
+ "id" value next <id-redirect>
+ ] >>submit ;
+
+:: <delete-action> ( ctor next -- action )
+ <action>
+ { { "id" [ v-number ] } } >>post-params
+
+ [
+ "id" get ctor call delete-tuple
+
+ next f <permanent-redirect>
+ ] >>submit ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: db http.server kernel new-slots accessors\r
+continuations namespaces destructors combinators.cleave ;\r
+IN: http.server.db\r
+\r
+TUPLE: db-persistence responder db params ;\r
+\r
+C: <db-persistence> db-persistence\r
+\r
+: connect-db ( db-persistence -- )\r
+ [ db>> ] [ params>> ] bi make-db\r
+ [ db set ] [ db-open ] [ add-always-destructor ] tri ;\r
+\r
+M: db-persistence call-responder\r
+ [ connect-db ] [ responder>> call-responder ] bi ;\r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs hashtables html html.elements splitting
-http io kernel math math.parser namespaces parser sequences
-strings io.server vectors assocs.lib logging ;
-
-IN: http.server.responders
-
-! Variables
-SYMBOL: vhosts
-SYMBOL: responders
-
-: >header ( value key -- multi-hash )
- H{ } clone [ insert-at ] keep ;
-
-: print-header ( alist -- )
- [ swap write ": " write print ] multi-assoc-each nl ;
-
-: response ( msg -- ) "HTTP/1.0 " write print ;
-
-: error-body ( error -- )
- <html> <body> <h1> write </h1> </body> </html> ;
-
-: error-head ( error -- )
- response
- H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
-
-: httpd-error ( error -- )
- #! This must be run from handle-request
- dup error-head
- "head" "method" get = [ drop ] [ error-body ] if ;
-
-\ httpd-error ERROR add-error-logging
-
-: bad-request ( -- )
- [
- ! Make httpd-error print a body
- "get" "method" set
- "400 Bad request" httpd-error
- ] with-scope ;
-
-: serving-content ( mime -- )
- "200 Document follows" response
- "Content-Type" >header print-header ;
-
-: serving-html "text/html" serving-content ;
-
-: serve-html ( quot -- )
- serving-html with-html-stream ;
-
-: serving-text "text/plain" serving-content ;
-
-: redirect ( to response -- )
- response "Location" >header print-header ;
-
-: permanent-redirect ( to -- )
- "301 Moved Permanently" redirect ;
-
-: temporary-redirect ( to -- )
- "307 Temporary Redirect" redirect ;
-
-: directory-no/ ( -- )
- [
- "request" get % CHAR: / ,
- "raw-query" get [ CHAR: ? , % ] when*
- ] "" make permanent-redirect ;
-
-: query>hash ( query -- hash )
- dup [
- "&" split [
- "=" split1 [ dup [ url-decode ] when ] 2apply 2array
- ] map
- ] when >hashtable ;
-
-SYMBOL: max-post-request
-
-1024 256 * max-post-request set-global
-
-: content-length ( header -- n )
- "Content-Length" swap at string>number dup [
- dup max-post-request get > [
- "Content-Length > max-post-request" throw
- ] when
- ] when ;
-
-: read-post-request ( header -- str hash )
- content-length [ read dup query>hash ] [ f f ] if* ;
-
-LOG: log-headers DEBUG
-
-: interesting-headers ( assoc -- string )
- [
- [
- drop {
- "user-agent"
- "referer"
- "x-forwarded-for"
- "host"
- } member?
- ] assoc-subset [
- ": " swap 3append % "\n" %
- ] multi-assoc-each
- ] "" make ;
-
-: prepare-url ( url -- url )
- #! This is executed in the with-request namespace.
- "?" split1
- dup "raw-query" set query>hash "query" set
- dup "request" set ;
-
-: prepare-header ( -- )
- read-header
- dup "header" set
- dup interesting-headers log-headers
- read-post-request "response" set "raw-response" set ;
-
-! Responders are called in a new namespace with these
-! variables:
-
-! - method -- one of get, post, or head.
-! - request -- the entire URL requested, including responder
-! name
-! - responder-url -- the component of the URL for the responder
-! - raw-query -- raw query string
-! - query -- a hashtable of query parameters, eg
-! foo.bar?a=b&c=d becomes
-! H{ { "a" "b" } { "c" "d" } }
-! - header -- a hashtable of headers from the user's client
-! - response -- a hashtable of the POST request response
-! - raw-response -- raw POST request response
-
-: query-param ( key -- value ) "query" get at ;
-
-: header-param ( key -- value )
- "header" get peek-at ;
-
-: host ( -- string )
- #! The host the current responder was called from.
- "Host" header-param ":" split1 drop ;
-
-: add-responder ( responder -- )
- #! Add a responder object to the list.
- "responder" over at responders get set-at ;
-
-: make-responder ( quot -- )
- #! quot has stack effect ( url -- )
- [
- [
- drop "GET method not implemented" httpd-error
- ] "get" set
- [
- drop "POST method not implemented" httpd-error
- ] "post" set
- [
- drop "HEAD method not implemented" httpd-error
- ] "head" set
- [
- drop bad-request
- ] "bad" set
-
- call
- ] H{ } make-assoc add-responder ;
-
-: add-simple-responder ( name quot -- )
- [
- [ drop ] swap append dup "get" set "post" set
- "responder" set
- ] make-responder ;
-
-: vhost ( name -- vhost )
- vhosts get at [ "default" vhost ] unless* ;
-
-: responder ( name -- responder )
- responders get at [ "404" responder ] unless* ;
-
-: set-default-responder ( name -- )
- responder "default" responders get set-at ;
-
-: call-responder ( method argument responder -- )
- over "argument" set [ swap get with-scope ] bind ;
-
-: serve-default-responder ( method url -- )
- "/" "responder-url" set
- "default" responder call-responder ;
-
-: trim-/ ( url -- url )
- #! Trim a leading /, if there is one.
- "/" ?head drop ;
-
-: serve-explicit-responder ( method url -- )
- "/" split1
- "/responder/" pick "/" 3append "responder-url" set
- dup [
- swap responder call-responder
- ] [
- ! Just a responder name by itself
- drop "request" get "/" append permanent-redirect 2drop
- ] if ;
-
-: serve-responder ( method path host -- )
- #! Responder paths come in two forms:
- #! /foo/bar... - default responder used
- #! /responder/foo/bar - responder foo, argument bar
- vhost [
- trim-/ "responder/" ?head [
- serve-explicit-responder
- ] [
- serve-default-responder
- ] if
- ] bind ;
-
-\ serve-responder DEBUG add-input-logging
-
-: no-such-responder ( -- )
- "404 No such responder" httpd-error ;
-
-! create a responders hash if it doesn't already exist
-global [
- responders [ H{ } assoc-like ] change
-
- ! 404 error message pages are served by this guy
- "404" [ no-such-responder ] add-simple-responder
-
- H{ } clone "default" associate vhosts set
-] bind
-USING: webapps.file http.server.responders http
-http.server namespaces io tools.test strings io.server
-logging ;
-IN: temporary
+USING: http.server tools.test kernel namespaces accessors
+new-slots io http math sequences assocs ;
+IN: http.server.tests
-[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
+[
+ <request>
+ "www.apple.com" >>host
+ "/xxx/bar" >>path
+ { { "a" "b" } } >>query
+ request set
-[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
+ [ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test
+ [ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test
+ [ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test
+ [ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test
+ [ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test
+ [ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
+ [ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
+ [ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
+] with-scope
-[ "index.html" ]
-[ "http://www.jedit.org/index.html" url>path ] unit-test
+TUPLE: mock-responder path ;
-[ "foo/bar" ]
-[ "http://www.jedit.org/foo/bar" url>path ] unit-test
+C: <mock-responder> mock-responder
-[ "" ]
-[ "http://www.jedit.org/" url>path ] unit-test
+M: mock-responder call-responder
+ nip
+ path>> on
+ "text/plain" <content> ;
-[ "" ]
-[ "http://www.jedit.org" url>path ] unit-test
+: check-dispatch ( tag path -- ? )
+ over off
+ main-responder get call-responder
+ write-response get ;
-[ "foobar" ]
-[ "foobar" secure-path ] unit-test
+[
+ <dispatcher>
+ "foo" <mock-responder> "foo" add-responder
+ "bar" <mock-responder> "bar" add-responder
+ <dispatcher>
+ "123" <mock-responder> "123" add-responder
+ "default" <mock-responder> >>default
+ "baz" add-responder
+ main-responder set
-[ f ]
-[ "foobar/../baz" secure-path ] unit-test
+ [ "foo" ] [
+ "foo" main-responder get find-responder path>> nip
+ ] unit-test
-[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test
-[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
+ [ "bar" ] [
+ "bar" main-responder get find-responder path>> nip
+ ] unit-test
-[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test
+ [ t ] [ "foo" "foo" check-dispatch ] unit-test
+ [ f ] [ "foo" "bar" check-dispatch ] unit-test
+ [ t ] [ "bar" "bar" check-dispatch ] unit-test
+ [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
+ [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
+ [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
+ [ t ] [ "123" "baz/123" check-dispatch ] unit-test
+ [ t ] [ "123" "baz///123" check-dispatch ] unit-test
-[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ]
-[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
+ [ t ] [
+ <request>
+ "baz" >>path
+ request set
+ "baz" main-responder get call-responder
+ dup code>> 300 399 between? >r
+ header>> "location" swap at "baz/" tail? r> and
+ ] unit-test
+] with-scope
-[ H{ { "Baz" " " } } ]
-[ "Baz=%20" query>hash ] unit-test
+[
+ <dispatcher>
+ "default" <mock-responder> >>default
+ main-responder set
-[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test
+ [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
+] with-scope
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
-threads http http.server.responders sequences prettyprint
-io.server logging ;
-
+threads http sequences prettyprint io.server logging calendar
+new-slots html.elements accessors math.parser combinators.lib
+vocabs.loader debugger html continuations random combinators
+destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
-: (url>path) ( uri -- path )
- url-decode "http://" ?head [
- "/" split1 dup "" ? nip
- ] when ;
+GENERIC: call-responder ( path responder -- response )
+
+: <content> ( content-type -- response )
+ <response>
+ 200 >>code
+ swap set-content-type ;
+
+TUPLE: trivial-responder response ;
+
+C: <trivial-responder> trivial-responder
+
+M: trivial-responder call-responder nip response>> call ;
+
+: trivial-response-body ( code message -- )
+ <html>
+ <body>
+ <h1> [ number>string write bl ] [ write ] bi* </h1>
+ </body>
+ </html> ;
+
+: <trivial-response> ( code message -- response )
+ 2dup '[ , , trivial-response-body ]
+ "text/html" <content>
+ swap >>body
+ swap >>message
+ swap >>code ;
+
+: <400> ( -- response )
+ 400 "Bad request" <trivial-response> ;
+
+: <404> ( -- response )
+ 404 "Not Found" <trivial-response> ;
+
+SYMBOL: 404-responder
-: url>path ( uri -- path )
- "?" split1 dup [
- >r (url>path) "?" r> 3append
+[ <404> ] <trivial-responder> 404-responder set-global
+
+: url-redirect ( to query -- url )
+ #! Different host.
+ dup assoc-empty? [
+ drop
] [
- drop (url>path)
+ assoc>query "?" swap 3append
] if ;
-: secure-path ( path -- path )
- ".." over subseq? [ drop f ] when ;
+: absolute-redirect ( to query -- url )
+ #! Same host.
+ request get clone
+ swap [ >>query ] when*
+ swap >>path
+ request-url ;
+
+: replace-last-component ( path with -- path' )
+ >r "/" last-split1 drop "/" r> 3append ;
+
+: relative-redirect ( to query -- url )
+ request get clone
+ swap [ >>query ] when*
+ swap [ '[ , replace-last-component ] change-path ] when*
+ request-url ;
+
+: derive-url ( to query -- url )
+ {
+ { [ over "http://" head? ] [ url-redirect ] }
+ { [ over "/" head? ] [ absolute-redirect ] }
+ { [ t ] [ relative-redirect ] }
+ } cond ;
+
+: <redirect> ( to query code message -- response )
+ <trivial-response> -rot derive-url "location" set-header ;
+
+\ <redirect> DEBUG add-input-logging
+
+: <permanent-redirect> ( to query -- response )
+ 301 "Moved Permanently" <redirect> ;
+
+: <temporary-redirect> ( to query -- response )
+ 307 "Temporary Redirect" <redirect> ;
+
+TUPLE: dispatcher default responders ;
-: request-method ( cmd -- method )
- H{
- { "GET" "get" }
- { "POST" "post" }
- { "HEAD" "head" }
- } at "bad" or ;
+: <dispatcher> ( -- dispatcher )
+ 404-responder get H{ } clone dispatcher construct-boa ;
-: (handle-request) ( arg cmd -- method path host )
- request-method dup "method" set swap
- prepare-url prepare-header host ;
+: set-main ( dispatcher name -- dispatcher )
+ '[ , f <permanent-redirect> ] <trivial-responder>
+ >>default ;
-: handle-request ( arg cmd -- )
- [ (handle-request) serve-responder ] with-scope ;
+: split-path ( path -- rest first )
+ [ CHAR: / = ] left-trim "/" split1 swap ;
-: parse-request ( request -- )
- " " split1 dup [
- " HTTP" split1 drop url>path secure-path dup [
- swap handle-request
+: find-responder ( path dispatcher -- path responder )
+ over split-path pick responders>> at*
+ [ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
+
+: redirect-with-/ ( -- response )
+ request get path>> "/" append f <permanent-redirect> ;
+
+M: dispatcher call-responder ( path dispatcher -- response )
+ over [
+ 2dup find-responder call-responder [
+ 2nip
] [
- 2drop bad-request
- ] if
+ default>> [
+ call-responder
+ ] [
+ drop f
+ ] if*
+ ] if*
] [
- 2drop bad-request
+ 2drop redirect-with-/
] if ;
-\ parse-request NOTICE add-input-logging
+: add-responder ( dispatcher responder path -- dispatcher )
+ pick responders>> set-at ;
+
+: add-main-responder ( dispatcher responder path -- dispatcher )
+ [ add-responder ] keep set-main ;
+
+: <webapp> ( class -- dispatcher )
+ <dispatcher> swap construct-delegate ; inline
+
+SYMBOL: main-responder
+
+main-responder global
+[ drop 404-responder get-global ] cache
+drop
+
+SYMBOL: development-mode
+
+: <500> ( error -- response )
+ 500 "Internal server error" <trivial-response>
+ swap '[
+ , "Internal server error" [
+ development-mode get [
+ [ print-error nl :c ] with-html-stream
+ ] [
+ 500 "Internal server error"
+ trivial-response-body
+ ] if
+ ] simple-page
+ ] >>body ;
+
+: do-response ( response -- )
+ dup write-response
+ request get method>> "HEAD" =
+ [ drop ] [ write-response-body ] if ;
+
+LOG: httpd-hit NOTICE
+
+: log-request ( request -- )
+ { method>> host>> path>> } map-exec-with httpd-hit ;
+
+SYMBOL: exit-continuation
+
+: exit-with exit-continuation get continue-with ;
+
+: do-request ( request -- response )
+ '[
+ exit-continuation set ,
+ [
+ [ log-request ]
+ [ request set ]
+ [ path>> main-responder get call-responder ] tri
+ [ <404> ] unless*
+ ] [
+ [ \ do-request log-error ]
+ [ <500> ]
+ bi
+ ] recover
+ ] callcc1
+ exit-continuation off ;
+
+: default-timeout 1 minutes stdio get set-timeout ;
+
+: ?refresh-all ( -- )
+ development-mode get-global
+ [ global [ refresh-all ] bind ] when ;
+
+: handle-client ( -- )
+ [
+ default-timeout
+ ?refresh-all
+ read-request
+ do-request
+ do-response
+ ] with-destructors ;
: httpd ( port -- )
- internet-server "http.server" [
- 60000 stdio get set-timeout
- readln [ parse-request ] when*
- ] with-server ;
+ internet-server "http.server"
+ latin1 [ handle-client ] with-server ;
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main
-! Load default webapps
-USE: webapps.file
-USE: webapps.callback
-USE: webapps.continuation
-USE: webapps.cgi
+! Utility
+: generate-key ( assoc -- str )
+ >r random-256 >hex r>
+ 2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+ dup generate-key [ swap set-at ] keep ;
--- /dev/null
+Doug Coleman
--- /dev/null
+IN: http.server.sessions.tests\r
+USING: tools.test http.server.sessions math namespaces\r
+kernel accessors ;\r
+\r
+: with-session \ session swap with-variable ; inline\r
+\r
+TUPLE: foo ;\r
+\r
+C: <foo> foo\r
+\r
+M: foo init-session* drop 0 "x" sset ;\r
+\r
+f <session> [\r
+ [ ] [ 3 "x" sset ] unit-test\r
+ \r
+ [ 9 ] [ "x" sget sq ] unit-test\r
+ \r
+ [ ] [ "x" [ 1- ] schange ] unit-test\r
+ \r
+ [ 4 ] [ "x" sget sq ] unit-test\r
+] with-session\r
+\r
+[ t ] [ f <url-sessions> url-sessions? ] unit-test\r
+[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test\r
+\r
+[ ] [\r
+ <foo> <url-sessions>\r
+ "manager" set\r
+] unit-test\r
+\r
+[ { 5 0 } ] [\r
+ [\r
+ "manager" get new-session\r
+ dup "manager" get get-session [ 5 "a" sset ] with-session\r
+ dup "manager" get get-session [ "a" sget , ] with-session\r
+ dup "manager" get get-session [ "x" sget , ] with-session\r
+ "manager" get get-session delete-session\r
+ ] { } make\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs calendar kernel math.parser namespaces random
+boxes alarms new-slots accessors http http.server
+quotations hashtables sequences fry combinators.cleave ;
+IN: http.server.sessions
+
+! ! ! ! ! !
+! WARNING: this session manager is vulnerable to XSRF attacks
+! ! ! ! ! !
+
+GENERIC: init-session* ( responder -- )
+
+M: dispatcher init-session* drop ;
+
+TUPLE: session-manager responder sessions ;
+
+: <session-manager> ( responder class -- responder' )
+ >r H{ } clone session-manager construct-boa r>
+ construct-delegate ; inline
+
+TUPLE: session manager id namespace alarm ;
+
+: <session> ( manager -- session )
+ f H{ } clone <box> \ session construct-boa ;
+
+: timeout ( -- dt ) 20 minutes ;
+
+: cancel-timeout ( session -- )
+ alarm>> [ cancel-alarm ] if-box? ;
+
+: delete-session ( session -- )
+ [ cancel-timeout ]
+ [ dup manager>> sessions>> delete-at ]
+ bi ;
+
+: touch-session ( session -- session )
+ [ cancel-timeout ]
+ [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
+ [ ]
+ tri ;
+
+: session ( -- assoc ) \ session get namespace>> ;
+
+: sget ( key -- value ) session at ;
+
+: sset ( value key -- ) session set-at ;
+
+: schange ( key quot -- ) session swap change-at ; inline
+
+: init-session ( session -- session )
+ dup dup \ session [
+ manager>> responder>> init-session*
+ ] with-variable ;
+
+: new-session ( responder -- id )
+ [ <session> init-session touch-session ]
+ [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
+ bi id>> ;
+
+: get-session ( id responder -- session/f )
+ sessions>> at* [ touch-session ] when ;
+
+: call-responder/session ( path responder session -- response )
+ \ session set responder>> call-responder ;
+
+: sessions ( -- manager/f )
+ \ session get dup [ manager>> ] when ;
+
+GENERIC: session-link* ( url query sessions -- string )
+
+M: object session-link* 2drop url-encode ;
+
+: session-link ( url query -- string ) sessions session-link* ;
+
+TUPLE: null-sessions ;
+
+: <null-sessions>
+ null-sessions <session-manager> ;
+
+M: null-sessions call-responder ( path responder -- response )
+ dup <session> call-responder/session ;
+
+TUPLE: url-sessions ;
+
+: <url-sessions> ( responder -- responder' )
+ url-sessions <session-manager> ;
+
+: sess-id "factorsessid" ;
+
+: current-session ( responder request -- session )
+ sess-id query-param swap get-session ;
+
+M: url-sessions call-responder ( path responder -- response )
+ dup request get current-session [
+ call-responder/session
+ ] [
+ nip
+ f swap new-session sess-id associate <temporary-redirect>
+ ] if* ;
+
+M: url-sessions session-link*
+ drop
+ url-encode
+ \ session get id>> sess-id associate union assoc>query
+ dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
+
+TUPLE: cookie-sessions ;
+
+: <cookie-sessions> ( responder -- responder' )
+ cookie-sessions <session-manager> ;
+
+: get-session-cookie ( responder -- cookie )
+ request get sess-id get-cookie
+ [ value>> swap get-session ] [ drop f ] if* ;
+
+: <session-cookie> ( id -- cookie )
+ sess-id <cookie> ;
+
+M: cookie-sessions call-responder ( path responder -- response )
+ dup get-session-cookie [
+ call-responder/session
+ ] [
+ dup new-session
+ [ over get-session call-responder/session ] keep
+ <session-cookie> put-cookie
+ ] if* ;
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: calendar html io io.files kernel math math.parser http\r
+http.server namespaces parser sequences strings assocs\r
+hashtables debugger http.mime sorting html.elements logging\r
+calendar.format new-slots accessors io.encodings.binary\r
+combinators.cleave fry ;\r
+IN: http.server.static\r
+\r
+SYMBOL: responder\r
+\r
+! special maps mime types to quots with effect ( path -- )\r
+TUPLE: file-responder root hook special ;\r
+\r
+: unix-time>timestamp ( n -- timestamp )\r
+ >r unix-1970 r> seconds time+ ;\r
+\r
+: file-http-date ( filename -- string )\r
+ file-modified unix-time>timestamp timestamp>http-string ;\r
+\r
+: last-modified-matches? ( filename -- ? )\r
+ file-http-date dup [\r
+ request get "if-modified-since" header =\r
+ ] when ;\r
+\r
+: <304> ( -- response )\r
+ 304 "Not modified" <trivial-response> ;\r
+\r
+: <file-responder> ( root hook -- responder )\r
+ H{ } clone file-responder construct-boa ;\r
+\r
+: <static> ( root -- responder )\r
+ [\r
+ <content>\r
+ swap\r
+ [ file-length "content-length" set-header ]\r
+ [ file-http-date "last-modified" set-header ]\r
+ [ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
+ tri\r
+ ] <file-responder> ;\r
+\r
+: serve-static ( filename mime-type -- response )\r
+ over last-modified-matches?\r
+ [ 2drop <304> ] [ file-responder get hook>> call ] if ;\r
+\r
+: serving-path ( filename -- filename )\r
+ "" or file-responder get root>> swap path+ ;\r
+\r
+: serve-file ( filename -- response )\r
+ dup mime-type\r
+ dup file-responder get special>> at\r
+ [ call ] [ serve-static ] ?if ;\r
+\r
+\ serve-file NOTICE add-input-logging\r
+\r
+: file. ( name dirp -- )\r
+ [ "/" append ] when\r
+ dup <a =href a> write </a> ;\r
+\r
+: directory. ( path -- )\r
+ dup file-name [\r
+ [ <h1> file-name write </h1> ]\r
+ [\r
+ <ul>\r
+ directory sort-keys\r
+ [ <li> file. </li> ] assoc-each\r
+ </ul>\r
+ ] bi\r
+ ] simple-html-document ;\r
+\r
+: list-directory ( directory -- response )\r
+ "text/html" <content>\r
+ swap '[ , directory. ] >>body ;\r
+\r
+: find-index ( filename -- path )\r
+ { "index.html" "index.fhtml" } [ path+ ] with map\r
+ [ exists? ] find nip ;\r
+\r
+: serve-directory ( filename -- response )\r
+ dup "/" tail? [\r
+ dup find-index\r
+ [ serve-file ] [ list-directory ] ?if\r
+ ] [\r
+ drop request get redirect-with-/\r
+ ] if ;\r
+\r
+: serve-object ( filename -- response )\r
+ serving-path dup exists? [\r
+ dup directory? [ serve-directory ] [ serve-file ] if\r
+ ] [\r
+ drop <404>\r
+ ] if ;\r
+\r
+M: file-responder call-responder ( path responder -- response )\r
+ file-responder set\r
+ dup [\r
+ ".." over subseq? [\r
+ drop <400>\r
+ ] [\r
+ serve-object\r
+ ] if\r
+ ] [\r
+ drop redirect-with-/\r
+ ] if ;\r
+++ /dev/null
-Slava Pestov
-Matthew Willis
--- /dev/null
+Slava Pestov
+Matthew Willis
--- /dev/null
+USING: io io.files io.streams.string io.encodings.utf8
+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/"
+ swap append
+ [
+ ".fhtml" append [ run-template ] with-string-writer
+ ] keep
+ ".html" append ?resource-path utf8 file-contents = ;
+
+[ t ] [ "example" test-template ] unit-test
+[ t ] [ "bug" test-template ] unit-test
+[ t ] [ "stack" test-template ] unit-test
+
+[
+ [ ] [ "<%\n%>" parse-template drop ] unit-test
+] with-file-vocabs
--- /dev/null
+! Copyright (C) 2005 Alex Chapman
+! Copyright (C) 2006, 2007 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 ;
+
+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 ;
+
+: <template-lexer> ( lines -- lexer )
+ <lexer> template-lexer construct-delegate ;
+
+M: template-lexer skip-word
+ [
+ {
+ { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
+ { [ t ] [ f skip ] }
+ } cond
+ ] change-column ;
+
+DEFER: <% delimiter
+
+: check-<% ( lexer -- col )
+ "<%" over lexer-line-text rot lexer-column start* ;
+
+: found-<% ( accum lexer col -- accum )
+ [
+ over lexer-line-text
+ >r >r lexer-column r> r> subseq parsed
+ \ write-html parsed
+ ] 2keep 2 + swap set-lexer-column ;
+
+: still-looking ( accum lexer -- accum )
+ [
+ dup lexer-line-text swap lexer-column tail
+ parsed \ print-html parsed
+ ] keep next-line ;
+
+: parse-%> ( accum lexer -- accum )
+ dup still-parsing? [
+ dup check-<%
+ [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
+ ] [
+ drop
+ ] if ;
+
+: %> lexer get parse-%> ; parsing
+
+: parse-template-lines ( lines -- quot )
+ <template-lexer> [
+ V{ } clone lexer get parse-%> f (parse-until)
+ ] with-parser ;
+
+: parse-template ( string -- quot )
+ [
+ use [ clone ] change
+ templating-vocab use+
+ string-lines parse-template-lines
+ ] with-scope ;
+
+: eval-template ( string -- ) parse-template call ;
+
+: html-error. ( error -- )
+ <pre> error. </pre> ;
+
+: run-template ( filename -- )
+ '[
+ , [
+ "quiet" on
+ parser-notes off
+ templating-vocab use+
+ ! so that reload works properly
+ dup source-file file set
+ ?resource-path utf8 file-contents
+ [ eval-template ] [ html-error. drop ] recover
+ ] 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 ]
+ "application/x-factor-server-page"
+ pick special>> set-at ;
--- /dev/null
+<%
+ USING: prettyprint ;
+ ! Hello world
+ 5 pprint
+%>
--- /dev/null
+<% USING: math ; %>
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <% 5 [ %><p>I like repetition</p><% ] times %>
+ </body>
+</html>
--- /dev/null
+
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
+ </body>
+</html>
+
--- /dev/null
+The stack: <% USING: prettyprint ; .s %>
--- /dev/null
+The stack:
+
+++ /dev/null
-USING: io io.files io.streams.string http.server.templating kernel tools.test
- sequences ;
-IN: temporary
-
-: test-template ( path -- ? )
- "extra/http/server/templating/test/" swap append
- [
- ".fhtml" append resource-path
- [ run-template-file ] with-string-writer
- ] keep
- ".html" append resource-path file-contents = ;
-
-[ t ] [ "example" test-template ] unit-test
-[ t ] [ "bug" test-template ] unit-test
-[ t ] [ "stack" test-template ] unit-test
-
-[ ] [ "<%\n%>" parse-template drop ] unit-test
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel parser namespaces io
-io.files io.streams.lines io.streams.string html html.elements
-source-files debugger combinators math quotations generic
-strings splitting ;
-
-IN: http.server.templating
-
-: templating-vocab ( -- vocab-name ) "http.server.templating" ;
-
-! 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 ;
-
-: <template-lexer> ( lines -- lexer )
- <lexer> template-lexer construct-delegate ;
-
-M: template-lexer skip-word
- [
- {
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
- { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- { [ t ] [ f skip ] }
- } cond
- ] change-column ;
-
-DEFER: <% delimiter
-
-: check-<% ( lexer -- col )
- "<%" over lexer-line-text rot lexer-column start* ;
-
-: found-<% ( accum lexer col -- accum )
- [
- over lexer-line-text
- >r >r lexer-column r> r> subseq parsed
- \ write-html parsed
- ] 2keep 2 + swap set-lexer-column ;
-
-: still-looking ( accum lexer -- accum )
- [
- dup lexer-line-text swap lexer-column tail
- parsed \ print-html parsed
- ] keep next-line ;
-
-: parse-%> ( accum lexer -- accum )
- dup still-parsing? [
- dup check-<%
- [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
- ] [
- drop
- ] if ;
-
-: %> lexer get parse-%> ; parsing
-
-: parse-template-lines ( lines -- quot )
- <template-lexer> [
- V{ } clone lexer get parse-%> f (parse-until)
- ] with-parser ;
-
-: parse-template ( string -- quot )
- [
- use [ clone ] change
- templating-vocab use+
- string-lines parse-template-lines
- ] with-scope ;
-
-: eval-template ( string -- ) parse-template call ;
-
-: html-error. ( error -- )
- <pre> error. </pre> ;
-
-: run-template-file ( filename -- )
- [
- [
- "quiet" on
- parser-notes off
- templating-vocab use+
- dup source-file file set ! so that reload works properly
- [
- ?resource-path file-contents
- [ eval-template ] [ html-error. drop ] recover
- ] keep
- ] with-file-vocabs
- ] assert-depth drop ;
-
-: run-relative-template-file ( filename -- )
- file get source-file-path parent-directory
- swap path+ run-template-file ;
-
-: template-convert ( infile outfile -- )
- [ run-template-file ] with-file-writer ;
+++ /dev/null
-<%
- USING: prettyprint ;
- ! Hello world
- 5 pprint
-%>
+++ /dev/null
-<% USING: math ; %>
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <% 5 [ %><p>I like repetition</p><% ] times %>
- </body>
-</html>
+++ /dev/null
-
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
- </body>
-</html>
-
+++ /dev/null
-The stack: <% USING: prettyprint ; .s %>
+++ /dev/null
-The stack:
-
--- /dev/null
+IN: http.server.validators.tests
+USING: kernel sequences tools.test http.server.validators
+accessors ;
+
+[ "foo" v-number ] [ validation-error? ] must-fail-with
+
+[ "slava@factorcode.org" ] [
+ "slava@factorcode.org" v-email
+] unit-test
+
+[ "slava+foo@factorcode.org" ] [
+ "slava+foo@factorcode.org" v-email
+] unit-test
+
+[ "slava@factorcode.o" v-email ]
+[ reason>> "invalid e-mail" = ] must-fail-with
+
+[ "sla@@factorcode.o" v-email ]
+[ reason>> "invalid e-mail" = ] must-fail-with
+
+[ "slava@factorcodeorg" v-email ]
+[ reason>> "invalid e-mail" = ] must-fail-with
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences math namespaces
+math.parser assocs new-slots regexp fry unicode.categories
+combinators.cleave sequences ;
+IN: http.server.validators
+
+TUPLE: validation-error value reason ;
+
+: validation-error ( value reason -- * )
+ \ validation-error construct-boa throw ;
+
+: v-default ( str def -- str )
+ over empty? spin ? ;
+
+: v-required ( str -- str )
+ dup empty? [ "required" validation-error ] when ;
+
+: v-min-length ( str n -- str )
+ over length over < [
+ [ "must be at least " % # " characters" % ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-max-length ( str n -- str )
+ over length over > [
+ [ "must be no more than " % # " characters" % ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-number ( str -- n )
+ dup string>number [ ] [
+ "must be a number" validation-error
+ ] ?if ;
+
+: v-min-value ( x n -- x )
+ 2dup < [
+ [ "must be at least " % # ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-max-value ( x n -- x )
+ 2dup > [
+ [ "must be no more than " % # ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-regexp ( str what regexp -- str )
+ >r over r> matches?
+ [ drop ] [ "invalid " swap append validation-error ] if ;
+
+: v-email ( str -- str )
+ #! From http://www.regular-expressions.info/email.html
+ "e-mail"
+ R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
+ v-regexp ;
+
+: v-captcha ( str -- str )
+ dup empty? [ "must remain blank" validation-error ] unless ;
+
+: v-one-line ( str -- str )
+ dup "\r\n" seq-intersect empty?
+ [ "must be a single line" validation-error ] unless ;
+
+: v-one-word ( str -- str )
+ dup [ alpha? ] all?
+ [ "must be a single word" validation-error ] unless ;
--- /dev/null
+<html><head><title>Hello</title></head><body>HTTPd test</body></html>
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences kernel.private namespaces arrays io
io.files splitting io.binary math.functions vectors quotations
-combinators ;
+combinators io.encodings.binary ;
IN: icfp.2006
SYMBOL: regs
[ run-op exec-loop ] unless ;
: load-platters ( path -- )
- file-contents 4 group [ be> ] map
+ binary file-contents 4 group [ be> ] map
0 arrays get set-nth ;
: init ( path -- )
-USING: help.markup help.syntax strings alien ;
+USING: help.markup help.syntax byte-arrays alien ;
IN: io.buffers
ARTICLE: "buffers" "Locked I/O buffers"
-"I/O buffers are first-in-first-out queues of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
+"I/O buffers are first-in-first-out queues of bytes. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are used to implement native I/O backends."
$nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer }
{ $subsection buffer-until }
"Writing to the buffer:"
{ $subsection extend-buffer }
-{ $subsection ch>buffer }
+{ $subsection byte>buffer }
{ $subsection >buffer }
{ $subsection n>buffer } ;
ABOUT: "buffers"
HELP: buffer
-{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimize for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually."
+{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimized for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually."
$nl
"Buffers have two internal pointers:"
{ $list
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: (buffer>>)
-{ $values { "buffer" buffer } { "string" "a string" } }
+{ $values { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects the entire contents of the buffer into a string." } ;
HELP: buffer-reset
{ $description "Outputs the memory address of the current fill-pointer." } ;
HELP: (buffer>)
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" string } }
+{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "string" "a string" } }
+{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
HELP: buffer>>
-{ $values { "buffer" buffer } { "string" "a string" } }
+{ $values { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
HELP: buffer-length
{ $errors "Throws an error if the buffer contains unread data, and the new data does not fit." } ;
HELP: >buffer
-{ $values { "string" "a string" } { "buffer" buffer } }
+{ $values { "byte-array" byte-array } { "buffer" buffer } }
{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
-HELP: ch>buffer
-{ $values { "ch" "a character" } { "buffer" buffer } }
+HELP: byte>buffer
+{ $values { "byte" "a byte" } { "buffer" buffer } }
{ $description "Appends a single byte to a buffer." } ;
HELP: n>buffer
{ $errors "Throws an error if the buffer does not contain " { $snippet "n" } " bytes of data." } ;
HELP: buffer-peek
-{ $values { "buffer" buffer } { "ch" "a character" } }
+{ $values { "buffer" buffer } { "byte" "a byte" } }
{ $description "Outputs the byte at the buffer position." } ;
HELP: buffer-pop
-{ $values { "buffer" buffer } { "ch" "a character" } }
+{ $values { "buffer" buffer } { "byte" "a byte" } }
{ $description "Outputs the byte at the buffer position and advances the position." } ;
HELP: buffer-until
-{ $values { "separators" string } { "buffer" buffer } { "string" string } { "separator" "a character or " { $link f } } }
-{ $description "Searches the buffer for a character appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
+{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } }
+{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
-IN: temporary
+IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc
-sequences tools.test namespaces ;
+sequences tools.test namespaces byte-arrays strings ;
: buffer-set ( string buffer -- )
- 2dup buffer-ptr string>char-memory
+ over >byte-array over buffer-ptr byte-array>memory
>r length r> buffer-reset ;
: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;
-[ "" 65536 ] [
+[ B{ } 65536 ] [
65536 <buffer>
dup (buffer>>)
over buffer-capacity
[ "hello world" "" ] [
"hello world" string>buffer
- dup (buffer>>)
+ dup (buffer>>) >string
0 pick buffer-reset
- over (buffer>>)
+ over (buffer>>) >string
rot buffer-free
] unit-test
[ "hello" ] [
"hello world" string>buffer
- 5 over buffer> swap buffer-free
+ 5 over buffer> >string swap buffer-free
] unit-test
[ 11 ] [
[ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep
- " world" over >buffer
- dup (buffer>>) swap buffer-free
+ " world" >byte-array over >buffer
+ dup (buffer>>) >string swap buffer-free
] unit-test
[ CHAR: e ] [
[ "hello" CHAR: \r ] [
"hello\rworld" string>buffer
- "\r" over buffer-until
+ "\r" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello" CHAR: \r ] [
"hello\rworld" string>buffer
- "\n\r" over buffer-until
+ "\n\r" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello\rworld" f ] [
"hello\rworld" string>buffer
- "X" over buffer-until
+ "X" over buffer-until >r >string r>
rot buffer-free
] unit-test
[ "hello" CHAR: \r "world" CHAR: \n ] [
"hello\rworld\n" string>buffer
- [ "\r\n" swap buffer-until ] keep
- [ "\r\n" swap buffer-until ] keep
+ [ "\r\n" swap buffer-until >r >string r> ] keep
+ [ "\r\n" swap buffer-until >r >string r> ] keep
buffer-free
] unit-test
"hello world" string>buffer "b" set
-[ "hello world" ] [ 1000 "b" get buffer> ] unit-test
+[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test
"b" get buffer-free
100 <buffer> "b" set
-[ 1000 "b" get n>buffer ] must-fail
+[ 1000 "b" get n>buffer >string ] must-fail
"b" get buffer-free
! See http://factorcode.org/license.txt for BSD license.
IN: io.buffers
USING: alien alien.accessors alien.c-types alien.syntax kernel
-kernel.private libc math sequences strings hints ;
+kernel.private libc math sequences byte-arrays strings hints ;
TUPLE: buffer size ptr fill pos ;
: buffer-end ( buffer -- alien )
dup buffer-fill swap buffer-ptr <displaced-alien> ;
-: buffer-peek ( buffer -- ch )
+: buffer-peek ( buffer -- byte )
buffer@ 0 alien-unsigned-1 ;
-: buffer-pop ( buffer -- ch )
+: buffer-pop ( buffer -- byte )
dup buffer-peek 1 rot buffer-consume ;
-: (buffer>) ( n buffer -- string )
+: (buffer>) ( n buffer -- byte-array )
[ dup buffer-fill swap buffer-pos - min ] keep
- buffer@ swap memory>char-string ;
+ buffer@ swap memory>byte-array ;
-: buffer> ( n buffer -- string )
+: buffer> ( n buffer -- byte-array )
[ (buffer>) ] 2keep buffer-consume ;
-: (buffer>>) ( buffer -- string )
+: (buffer>>) ( buffer -- byte-array )
dup buffer-pos over buffer-ptr <displaced-alien>
- over buffer-fill rot buffer-pos - memory>char-string ;
+ over buffer-fill rot buffer-pos - memory>byte-array ;
-: buffer>> ( buffer -- string )
+: buffer>> ( buffer -- byte-array )
dup (buffer>>) 0 rot buffer-reset ;
: search-buffer-until ( start end alien separators -- n )
HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
-: finish-buffer-until ( buffer n -- string separator )
+: finish-buffer-until ( buffer n -- byte-array separator )
[
over buffer-pos -
over buffer>
buffer>> f
] if* ;
-: buffer-until ( separators buffer -- string separator )
+: buffer-until ( separators buffer -- byte-array separator )
tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll
search-buffer-until finish-buffer-until ;
: check-overflow ( n buffer -- )
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
-: >buffer ( string buffer -- )
+: >buffer ( byte-array buffer -- )
over length over check-overflow
- [ buffer-end string>char-memory ] 2keep
+ [ buffer-end byte-array>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ;
-: ch>buffer ( ch buffer -- )
+: byte>buffer ( byte buffer -- )
1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep
[ buffer-fill 1+ ] keep set-buffer-fill ;
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
+IN: io.encodings.ascii
+
+: encode-check<= ( string stream max -- )
+ [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
+
+TUPLE: ascii ;
+
+M: ascii stream-write-encoded ( string stream encoding -- )
+ drop 128 encode-check<= ;
+
+M: ascii decode-step
+ drop dup 128 >= [ decode-error ] [ swap push ] if ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+ASCII encoding for streams
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup ;
+IN: io.encodings.latin1
+
+HELP: latin1
+{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.encodings strings kernel io.encodings.ascii sequences math ;
+IN: io.encodings.latin1
+
+TUPLE: latin1 ;
+
+M: latin1 stream-write-encoded
+ drop 256 encode-check<= ;
+
+M: latin1 decode-step
+ drop swap push ;
--- /dev/null
+ISO 8859-1 encoding/decoding
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding/decoding
--- /dev/null
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf16
+
+ARTICLE: "utf16" "Working with UTF-16-encoded data"
+"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
+{ $subsection utf16le }
+{ $subsection utf16be }
+{ $subsection utf16 }
+"All of these conform to the " { $link "encodings-protocol" } "." ;
+
+ABOUT: "utf16"
+
+HELP: utf16le
+{ $class-description "The encoding protocol for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ;
+
+HELP: utf16be
+{ $class-description "The encoding protocol for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ;
+
+HELP: utf16
+{ $class-description "The encoding protocol for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } ;
+
+{ utf16 utf16le utf16be } related-words
--- /dev/null
+USING: kernel tools.test io.encodings.utf16 arrays sbufs
+sequences io.encodings io unicode io.encodings.string ;
+
+[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
+
+[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
+
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
+
+[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel sequences sbufs vectors namespaces io.binary
+io.encodings combinators splitting io byte-arrays ;
+IN: io.encodings.utf16
+
+! UTF-16BE decoding
+
+TUPLE: utf16be ch state ;
+
+SYMBOL: double
+SYMBOL: quad1
+SYMBOL: quad2
+SYMBOL: quad3
+SYMBOL: ignore
+
+: do-ignore ( -- ch state ) 0 ignore ;
+
+: append-nums ( byte ch -- ch )
+ 8 shift bitor ;
+
+: end-multibyte ( buf byte ch -- buf ch state )
+ append-nums push-decoded ;
+
+: begin-utf16be ( buf byte -- buf ch state )
+ dup -3 shift BIN: 11011 number= [
+ dup BIN: 00000100 bitand zero?
+ [ BIN: 11 bitand quad1 ]
+ [ drop do-ignore ] if
+ ] [ double ] if ;
+
+: handle-quad2be ( byte ch -- ch state )
+ swap dup -2 shift BIN: 110111 number= [
+ >r 2 shift r> BIN: 11 bitand bitor quad3
+ ] [ 2drop do-ignore ] if ;
+
+: decode-utf16be-step ( buf byte ch state -- buf ch state )
+ {
+ { begin [ drop begin-utf16be ] }
+ { double [ end-multibyte ] }
+ { quad1 [ append-nums quad2 ] }
+ { quad2 [ handle-quad2be ] }
+ { quad3 [ append-nums HEX: 10000 + push-decoded ] }
+ { ignore [ 2drop push-replacement ] }
+ } case ;
+
+: unpack-state-be ( encoding -- ch state )
+ { utf16be-ch utf16be-state } get-slots ;
+
+: pack-state-be ( ch state encoding -- )
+ { set-utf16be-ch set-utf16be-state } set-slots ;
+
+M: utf16be decode-step
+ [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ;
+
+M: utf16be init-decoder nip begin over set-utf16be-state ;
+
+! UTF-16LE decoding
+
+TUPLE: utf16le ch state ;
+
+: handle-double ( buf byte ch -- buf ch state )
+ swap dup -3 shift BIN: 11011 = [
+ dup BIN: 100 bitand 0 number=
+ [ BIN: 11 bitand 8 shift bitor quad2 ]
+ [ 2drop push-replacement ] if
+ ] [ end-multibyte ] if ;
+
+: handle-quad3le ( buf byte ch -- buf ch state )
+ swap dup -2 shift BIN: 110111 = [
+ BIN: 11 bitand append-nums HEX: 10000 + push-decoded
+ ] [ 2drop push-replacement ] if ;
+
+: decode-utf16le-step ( buf byte ch state -- buf ch state )
+ {
+ { begin [ drop double ] }
+ { double [ handle-double ] }
+ { quad1 [ append-nums quad2 ] }
+ { quad2 [ 10 shift bitor quad3 ] }
+ { quad3 [ handle-quad3le ] }
+ } case ;
+
+: unpack-state-le ( encoding -- ch state )
+ { utf16le-ch utf16le-state } get-slots ;
+
+: pack-state-le ( ch state encoding -- )
+ { set-utf16le-ch set-utf16le-state } set-slots ;
+
+M: utf16le decode-step
+ [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ;
+
+M: utf16le init-decoder nip begin over set-utf16le-state ;
+
+! UTF-16LE/BE encoding
+
+: encode-first
+ -10 shift
+ dup -8 shift BIN: 11011000 bitor
+ swap HEX: FF bitand ;
+
+: encode-second
+ BIN: 1111111111 bitand
+ dup -8 shift BIN: 11011100 bitor
+ swap BIN: 11111111 bitand ;
+
+: char>utf16be ( char -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ dup encode-first swap write1 write1
+ encode-second swap write1 write1
+ ] [ h>b/b write1 write1 ] if ;
+
+: stream-write-utf16be ( string stream -- )
+ [ [ char>utf16be ] each ] with-stream* ;
+
+M: utf16be stream-write-encoded ( string stream encoding -- )
+ drop stream-write-utf16be ;
+
+: char>utf16le ( char -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ dup encode-first write1 write1
+ encode-second write1 write1
+ ] [ h>b/b swap write1 write1 ] if ;
+
+: stream-write-utf16le ( string stream -- )
+ [ [ char>utf16le ] each ] with-stream* ;
+
+M: utf16le stream-write-encoded ( string stream encoding -- )
+ drop stream-write-utf16le ;
+
+! UTF-16
+
+: bom-le B{ HEX: ff HEX: fe } ; inline
+
+: bom-be B{ HEX: fe HEX: ff } ; inline
+
+: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
+
+: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
+
+TUPLE: utf16 started? ;
+
+M: utf16 stream-write-encoded
+ dup utf16-started? [ drop ]
+ [ t swap set-utf16-started? bom-le over stream-write ] if
+ stream-write-utf16le ;
+
+: bom>le/be ( bom -- le/be )
+ dup bom-le sequence= [ drop utf16le ] [
+ bom-be sequence= [ utf16be ] [ decode-error ] if
+ ] if ;
+
+M: utf16 init-decoder ( stream encoding -- newencoding )
+ 2 rot stream-read bom>le/be construct-empty init-decoder ;
--- /dev/null
+USING: io.backend ;
+IN: io.files.unique.backend
+
+HOOK: (make-unique-file) io-backend ( path -- stream )
+HOOK: temporary-path io-backend ( -- path )
--- /dev/null
+USING: help.markup help.syntax io io.nonblocking kernel math
+io.files.unique.private math.parser io.files ;
+IN: io.files.unique
+
+ARTICLE: "unique" "Making and using unique files"
+"Files:"
+{ $subsection make-unique-file }
+{ $subsection with-unique-file }
+{ $subsection with-temporary-file }
+"Directories:"
+{ $subsection make-unique-directory }
+{ $subsection with-unique-directory }
+{ $subsection with-temporary-directory } ;
+
+ABOUT: "unique"
+
+HELP: make-unique-file ( prefix suffix -- path stream )
+{ $values { "prefix" "a string" } { "suffix" "a string" }
+{ "path" "a pathname string" } { "stream" "an output stream" } }
+{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link <writer> } " stream." }
+{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
+{ $see-also with-unique-file } ;
+
+HELP: make-unique-directory ( -- path )
+{ $values { "path" "a pathname string" } }
+{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
+{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
+{ $see-also with-unique-directory } ;
+
+HELP: with-unique-file ( quot -- path )
+{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
+{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." }
+{ $notes "The unique file will remain after calling this word." }
+{ $see-also with-temporary-file } ;
+
+HELP: with-unique-directory ( quot -- path )
+{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
+{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." }
+{ $notes "The directory will remain after calling this word." }
+{ $see-also with-temporary-directory } ;
+
+HELP: with-temporary-file ( quot -- )
+{ $values { "quot" "a quotation" } }
+{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." }
+{ $see-also with-unique-file } ;
+
+HELP: with-temporary-directory ( quot -- )
+{ $values { "quot" "a quotation" } }
+{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." }
+{ $see-also with-unique-directory } ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.bitfields combinators.lib math.parser
+random sequences sequences.lib continuations namespaces
+io.files io.backend io.nonblocking io arrays
+io.files.unique.backend system combinators vocabs.loader ;
+IN: io.files.unique
+
+<PRIVATE
+: random-letter ( -- ch )
+ 26 random { CHAR: a CHAR: A } random + ;
+
+: random-ch ( -- ch )
+ { t f } random
+ [ 10 random CHAR: 0 + ] [ random-letter ] if ;
+
+: random-name ( n -- string )
+ [ drop random-ch ] "" map-as ;
+
+: unique-length ( -- n ) 10 ; inline
+: unique-retries ( -- n ) 10 ; inline
+PRIVATE>
+
+: make-unique-file ( prefix suffix -- path stream )
+ temporary-path -rot
+ [
+ unique-length random-name swap 3append path+
+ dup (make-unique-file)
+ ] 3curry unique-retries retry ;
+
+: with-unique-file ( quot -- path )
+ >r f f make-unique-file r> rot [ with-stream ] dip ; inline
+
+: with-temporary-file ( quot -- )
+ with-unique-file delete-file ; inline
+
+: make-unique-directory ( -- path )
+ [
+ temporary-path unique-length random-name path+
+ dup make-directory
+ ] unique-retries retry ;
+
+: with-unique-directory ( quot -- path )
+ >r make-unique-directory r>
+ [ with-directory ] curry keep ; inline
+
+: with-temporary-directory ( quot -- )
+ with-unique-directory delete-tree ; inline
+
+{
+ { [ unix? ] [ "io.unix.files.unique" ] }
+ { [ windows? ] [ "io.windows.files.unique" ] }
+} cond require
Doug Coleman
+Slava Pestov
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations kernel io math ;
+USING: help.markup help.syntax quotations kernel io math
+calendar ;
IN: io.launcher
-HELP: +command+
-{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
+ARTICLE: "io.launcher.command" "Specifying a command"
+"The " { $snippet "command" } " slot of a " { $link process } " can contain either a string or a sequence of strings. In the first case, the string is processed in an operating system-specific manner. In the second case, the first element is a program name and the remaining elements are passed to the program as command-line arguments." ;
-HELP: +arguments+
-{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ;
+ARTICLE: "io.launcher.detached" "Running processes in the background"
+"By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:"
+{ $subsection run-detached } ;
-HELP: +detached+
-{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
+ARTICLE: "io.launcher.environment" "Setting environment variables"
+"The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific."
$nl
-"Default value is " { $link f } "." }
-{ $notes "Cannot be used with " { $link <process-stream> } "." }
-{ $see-also run-detached } ;
-
-HELP: +environment+
-{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key."
+"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:"
+{ $subsection +prepend-environment+ }
+{ $subsection +replace-environment+ }
+{ $subsection +append-environment+ }
+"The default value is " { $link +append-environment+ } "." ;
+
+ARTICLE: "io.launcher.redirection" "Input/output redirection"
+"On all operating systems except for Windows CE, the default input/output/error streams can be redirected."
$nl
-"Default value is an empty association." } ;
-
-HELP: +environment-mode+
-{ $description "Launch descriptor key. Must equal of the following:"
- { $list
- { $link +prepend-environment+ }
- { $link +replace-environment+ }
- { $link +append-environment+ }
- }
-"Default value is " { $link +append-environment+ } "."
-} ;
-
-HELP: +stdin+
-{ $description "Launch descriptor key. Must equal one of the following:"
- { $list
- { { $link f } " - standard input is inherited" }
- { { $link +closed+ } " - standard input is closed" }
- { "a path name - standard input is read from the given file, which must exist" }
- }
+"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:"
+{ $list
+ { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
+ { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link <process-stream> } " pipe" }
+ { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" }
+ { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" }
+ { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" }
+ { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
} ;
-HELP: +stdout+
-{ $description "Launch descriptor key. Must equal one of the following:"
- { $list
- { { $link f } " - standard output is inherited" }
- { { $link +closed+ } " - standard output is closed" }
- { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
- }
-} ;
+HELP: +closed+
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
-HELP: +stderr+
-{ $description "Launch descriptor key. Must equal one of the following:"
- { $list
- { { $link f } " - standard error is inherited" }
- { { $link +closed+ } " - standard error is closed" }
- { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
- }
-} ;
+HELP: +inherit+
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
-HELP: +closed+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+HELP: +stdout+
+{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ;
HELP: +prepend-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"If this value is set, the child process environment consists of the value of the " { $snippet "environment" } " slot together with the current environment, with entries from the current environment taking precedence."
$nl
"This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ;
HELP: +replace-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the value of the " { $snippet "environment" } " slot."
$nl
"This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ;
HELP: +append-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the current environment together with the value of the " { $snippet "environment" } " key, with entries from the " { $snippet "environment" } " key taking precedence."
$nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
-HELP: +timeout+
-{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
-
-HELP: default-descriptor
-{ $description "Association storing default values for launch descriptor keys." } ;
-
-HELP: with-descriptor
-{ $values { "desc" "a launch descriptor" } { "quot" quotation } }
-{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ;
+ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
+"The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." ;
HELP: get-environment
-{ $values { "env" "an association" } }
-{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
+{ $values { "process" process } { "env" "an association" } }
+{ $description "Combines the current environment with the value of the " { $snippet "environment" } " slot of the " { $link process } " using the " { $snippet "environment-mode" } " slot." } ;
HELP: current-process-handle
{ $values { "handle" "a process handle" } }
{ $description "Returns the handle of the current process." } ;
HELP: run-process*
-{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } }
-{ $contract "Launches a process using the launch descriptor." }
+{ $values { "process" process } { "handle" "a process handle" } }
+{ $contract "Launches a process." }
{ $notes "User code should call " { $link run-process } " instead." } ;
-HELP: >descriptor
-{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
-{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
-
HELP: run-process
{ $values { "desc" "a launch descriptor" } { "process" process } }
-{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached
{ $values { "desc" "a launch descriptor" } { "process" process } }
-{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
{ $notes
- "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
+ "This word is functionally identical to passing a " { $link process } " to " { $link run-process } " having the " { $snippet "detached" } " slot set."
$nl
"The output value can be passed to " { $link wait-for-process } " to get an exit code."
} ;
{ $notes "User code should call " { $link kill-process } " intead." } ;
HELP: process
-{ $class-description "A class representing an active or finished process."
-$nl
-"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances."
-$nl
-"Processes can be passed to " { $link wait-for-process } "." } ;
+{ $class-description "A class representing a process. Instances are created by calling " { $link <process> } "." } ;
+
+HELP: <process>
+{ $values { "process" process } }
+{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
HELP: process-stream
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
HELP: <process-stream>
{ $values
{ "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
{ "stream" "a bidirectional stream" } }
-{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
-{ $notes "Closing the stream will block until the process exits." } ;
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
HELP: with-process-stream
{ $values
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
-"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
-{ $list
- { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
- { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
- { "associations can be passed in, which allows finer control over launch parameters" }
-}
-"The associations can contain the following keys:"
-{ $subsection +command+ }
-{ $subsection +arguments+ }
-{ $subsection +detached+ }
-{ $subsection +environment+ }
-{ $subsection +environment-mode+ }
-{ $subsection +timeout+ }
-{ $subsection +stdin+ }
-{ $subsection +stdout+ }
-{ $subsection +stderr+ } ;
-
-ARTICLE: "io.launcher" "Launching OS processes"
-"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
-{ $subsection "io.launcher.descriptors" }
-"The following words are used to launch processes:"
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
+$nl
+"Strings and string arrays are wrapped in a new empty " { $link process } " with the " { $snippet "command" } " slot set. This covers basic use-cases where no launch parameters need to be set."
+$nl
+"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ;
+
+ARTICLE: "io.launcher.lifecycle" "The process lifecycle"
+"A freshly instantiated " { $link process } " represents a set of launch parameters."
+{ $subsection process }
+{ $subsection <process> }
+"Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
+{ $subsection process-started? }
+"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running."
+{ $subsection process-running? }
+"It is possible to wait for a process to exit:"
+{ $subsection wait-for-process }
+"A running process can also be killed:"
+{ $subsection kill-process } ;
+
+ARTICLE: "io.launcher.launch" "Launching processes"
+"Launching processes:"
{ $subsection run-process }
-{ $subsection run-detached }
{ $subsection try-process }
-"Stopping processes:"
-{ $subsection kill-process }
-"Finding the current process handle:"
-{ $subsection current-process-handle }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
-{ $subsection with-process-stream }
-"A class representing an active or finished process:"
-{ $subsection process }
-"Waiting for a process to end, or getting the exit code of a finished process:"
-{ $subsection wait-for-process }
-"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
+{ $subsection with-process-stream } ;
+
+ARTICLE: "io.launcher.examples" "Launcher examples"
+"Starting a command and waiting for it to finish:"
+{ $code
+ "\"ls /etc\" run-process"
+}
+"Starting a program in the background:"
+{ $code
+ "{ \"emacs\" \"foo.txt\" } run-detached"
+}
+"Running a command, throwing an exception if it exits unsuccessfully:"
+{ $code
+ "\"make clean all\" try-process"
+}
+"Running a command, throwing an exception if it exits unsuccessfully or if it takes too long to run:"
+{ $code
+ "<process>"
+ " \"make test\" >>command"
+ " 5 minutes >>timeout"
+ "try-process"
+}
+"Running a command, throwing an exception if it exits unsuccessfully, and redirecting output and error messages to a log file:"
+{ $code
+ "<process>"
+ " \"make clean all\" >>command"
+ " \"log.txt\" >>stdout"
+ " +stdout+ >>stderr"
+ "try-process"
+}
+"Running a command, appending error messages to a log file, and reading the output for further processing:"
+{ $code
+ "\"log.txt\" <file-appender> ["
+ " <process>"
+ " swap >>stderr"
+ " \"report\" >>command"
+ " ascii <process-stream> lines sort reverse [ print ] each"
+ "] with-disposal"
+} ;
+
+ARTICLE: "io.launcher" "Operating system processes"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+{ $subsection "io.launcher.examples" }
+{ $subsection "io.launcher.descriptors" }
+{ $subsection "io.launcher.launch" }
+"Advanced topics:"
+{ $subsection "io.launcher.lifecycle" }
+{ $subsection "io.launcher.command" }
+{ $subsection "io.launcher.detached" }
+{ $subsection "io.launcher.environment" }
+{ $subsection "io.launcher.redirection" }
+{ $subsection "io.launcher.timeouts" } ;
ABOUT: "io.launcher"
-IN: temporary
+IN: io.launcher.tests
USING: tools.test io.launcher ;
\ <process-stream> must-infer
! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
-init threads continuations math ;
+init threads continuations math io.encodings io.streams.duplex
+io.nonblocking new-slots accessors ;
IN: io.launcher
+
+TUPLE: process
+
+command
+detached
+
+environment
+environment-mode
+
+stdin
+stdout
+stderr
+
+timeout
+
+handle status
+killed ;
+
+SYMBOL: +closed+
+SYMBOL: +inherit+
+SYMBOL: +stdout+
+
+SYMBOL: +prepend-environment+
+SYMBOL: +replace-environment+
+SYMBOL: +append-environment+
+
+: <process> ( -- process )
+ process construct-empty
+ H{ } clone >>environment
+ +append-environment+ >>environment-mode ;
+
+: process-started? ( process -- ? )
+ dup handle>> swap status>> or ;
+
+: process-running? ( process -- ? )
+ process-handle >boolean ;
+
! Non-blocking process exit notification facility
SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-TUPLE: process handle status killed? lapse ;
-
HOOK: register-process io-backend ( process -- )
M: object register-process drop ;
-: <process> ( handle -- process )
- f f <lapse> process construct-boa
+: process-started ( process handle -- )
+ >>handle
V{ } clone over processes get set-at
- dup register-process ;
+ register-process ;
M: process equal? 2drop f ;
M: process hashcode* process-handle hashcode* ;
-: process-running? ( process -- ? ) process-status not ;
+: pass-environment? ( process -- ? )
+ dup environment>> assoc-empty? not
+ swap environment-mode>> +replace-environment+ eq? or ;
-SYMBOL: +command+
-SYMBOL: +arguments+
-SYMBOL: +detached+
-SYMBOL: +environment+
-SYMBOL: +environment-mode+
-SYMBOL: +stdin+
-SYMBOL: +stdout+
-SYMBOL: +stderr+
-SYMBOL: +closed+
-SYMBOL: +timeout+
-
-SYMBOL: +prepend-environment+
-SYMBOL: +replace-environment+
-SYMBOL: +append-environment+
-
-: default-descriptor
- H{
- { +command+ f }
- { +arguments+ f }
- { +detached+ f }
- { +environment+ H{ } }
- { +environment-mode+ +append-environment+ }
- } ;
-
-: with-descriptor ( desc quot -- )
- default-descriptor [ >r clone r> bind ] bind ; inline
-
-: pass-environment? ( -- ? )
- +environment+ get assoc-empty? not
- +environment-mode+ get +replace-environment+ eq? or ;
-
-: get-environment ( -- env )
- +environment+ get
- +environment-mode+ get {
+: get-environment ( process -- env )
+ dup environment>>
+ swap environment-mode>> {
{ +prepend-environment+ [ os-envs union ] }
{ +append-environment+ [ os-envs swap union ] }
{ +replace-environment+ [ ] }
: string-array? ( obj -- ? )
dup sequence? [ [ string? ] all? ] [ drop f ] if ;
-: >descriptor ( desc -- desc )
- {
- { [ dup string? ] [ +command+ associate ] }
- { [ dup string-array? ] [ +arguments+ associate ] }
- { [ dup assoc? ] [ >hashtable ] }
- } cond ;
+GENERIC: >process ( obj -- process )
+
+M: process >process
+ dup process-started? [
+ "Process has already been started once" throw
+ ] when
+ clone ;
+
+M: object >process <process> swap >>command ;
HOOK: current-process-handle io-backend ( -- handle )
-HOOK: run-process* io-backend ( desc -- handle )
+HOOK: run-process* io-backend ( process -- handle )
: wait-for-process ( process -- status )
[
- dup process-handle
+ dup handle>>
[
dup [ processes get at push ] curry
"process" suspend drop
] when
- dup process-killed?
- [ "Process was killed" throw ] [ process-status ] if
+ dup killed>>
+ [ "Process was killed" throw ] [ status>> ] if
] with-timeout ;
-: run-process ( desc -- process )
- >descriptor
- dup run-process*
- +timeout+ pick at [ over set-timeout ] when*
- +detached+ rot at [ dup wait-for-process drop ] unless ;
-
: run-detached ( desc -- process )
- >descriptor H{ { +detached+ t } } union run-process ;
+ >process
+ dup dup run-process* process-started
+ dup timeout>> [ over set-timeout ] when* ;
+
+: run-process ( desc -- process )
+ run-detached
+ dup detached>> [ dup wait-for-process drop ] unless ;
TUPLE: process-failed code ;
HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- )
- t over set-process-killed?
- process-handle [ kill-process* ] when* ;
+ t >>killed
+ handle>> [ kill-process* ] when* ;
-M: process get-lapse process-lapse ;
+M: process timeout timeout>> ;
+
+M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;
-HOOK: process-stream* io-backend ( desc -- stream process )
+HOOK: (process-stream) io-backend ( process -- handle in out )
TUPLE: process-stream process ;
-: <process-stream> ( desc -- stream )
- >descriptor
- [ process-stream* ] keep
- +timeout+ swap at [ over set-timeout ] when*
- { set-delegate set-process-stream-process }
- process-stream construct ;
+: <process-stream> ( desc encoding -- stream )
+ >r >process dup dup (process-stream)
+ >r >r process-started process-stream construct-boa
+ r> r> <reader&writer> r> <encoder-duplex>
+ over set-delegate ;
: with-process-stream ( desc quot -- status )
swap <process-stream>
[ swap with-stream ] keep
- process-stream-process wait-for-process ; inline
+ process>> wait-for-process ; inline
-: notify-exit ( status process -- )
- [ set-process-status ] keep
+: notify-exit ( process status -- )
+ >>status
[ processes get delete-at* drop [ resume ] each ] keep
- f swap set-process-handle ;
+ f >>handle
+ drop ;
+
+GENERIC: underlying-handle ( stream -- handle )
+
+M: port underlying-handle port-handle ;
+
+M: duplex-stream underlying-handle
+ dup duplex-stream-in underlying-handle
+ swap duplex-stream-out underlying-handle tuck =
+ [ "Invalid duplex stream" throw ] when ;
-Support for launching OS processes
+Launching operating system processes
-USING: io io.mmap io.files kernel tools.test continuations sequences ;
-IN: temporary
+USING: io io.mmap io.files kernel tools.test continuations
+sequences io.encodings.ascii ;
+IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
-[ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-file-writer ] unit-test
+[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
-[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test
+[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
USING: help.markup help.syntax continuations ;\r
\r
HELP: <monitor>\r
-{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } }\r
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }\r
{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."\r
$nl\r
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;\r
\r
HELP: next-change\r
-{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } }\r
+{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }\r
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;\r
\r
HELP: with-monitor\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: io.backend kernel continuations namespaces sequences\r
-assocs hashtables sorting arrays threads boxes ;\r
+assocs hashtables sorting arrays threads boxes io.timeouts ;\r
IN: io.monitors\r
\r
<PRIVATE\r
\r
! Simple monitor; used on Linux and Mac OS X. On Windows,\r
! monitors are full-fledged ports.\r
-TUPLE: simple-monitor handle callback ;\r
+TUPLE: simple-monitor handle callback timeout ;\r
+\r
+M: simple-monitor timeout simple-monitor-timeout ;\r
+\r
+M: simple-monitor set-timeout set-simple-monitor-timeout ;\r
\r
: <simple-monitor> ( handle -- simple-monitor )\r
f (monitor) <box> {\r
>r <simple-monitor> r> construct-delegate ; inline\r
\r
: notify-callback ( simple-monitor -- )\r
- simple-monitor-callback ?box [ resume ] [ drop ] if ;\r
+ simple-monitor-callback [ resume ] if-box? ;\r
+\r
+M: simple-monitor timed-out\r
+ notify-callback ;\r
\r
M: simple-monitor fill-queue ( monitor -- )\r
- [ swap simple-monitor-callback >box ]\r
- "monitor" suspend drop\r
+ [\r
+ [ swap simple-monitor-callback >box ]\r
+ "monitor" suspend drop\r
+ ] with-timeout\r
check-monitor ;\r
\r
M: simple-monitor dispose ( monitor -- )\r
USING: io io.buffers io.backend help.markup help.syntax kernel
-strings sbufs words continuations ;
+byte-arrays sbufs words continuations byte-vectors ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
$low-level-note ;
HELP: <buffered-port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "port" "a new " { $link port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
$low-level-note ;
HELP: <reader>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "stream" "a new " { $link input-port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } }
{ $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ;
HELP: <writer>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "stream" "a new " { $link output-port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } }
{ $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ;
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
HELP: read-until-step
-{ $values { "separators" string } { "port" input-port } { "string/f" "a string or " { $link f } } { "separator/f" "a character or " { $link f } } }
+{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } }
{ $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ;
HELP: read-until-loop
-{ $values { "seps" string } { "port" input-port } { "sbuf" sbuf } { "separator/f" "a character or " { $link f } } }
-{ $description "Accumulates data in the string buffer, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
+{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } }
+{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
HELP: can-write?
{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
! See http://factorcode.org/license.txt for BSD license.
IN: io.nonblocking
USING: math kernel io sequences io.buffers io.timeouts generic
-sbufs system io.streams.lines io.streams.plain io.streams.duplex
+byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces
-splitting dlists assocs ;
+splitting dlists assocs io.encodings.binary ;
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
TUPLE: port
handle
error
-lapse
+timeout
type eof? ;
-! Ports support the lapse protocol
-M: port get-lapse port-lapse ;
+M: port timeout port-timeout ;
+
+M: port set-timeout set-port-timeout ;
SYMBOL: closed
GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port )
- pick init-handle
- <lapse> {
+ pick init-handle {
set-port-handle
set-delegate
set-port-type
- set-port-lapse
} port construct ;
: <buffered-port> ( handle type -- port )
default-buffer-size get <buffer> swap <port> ;
-: <reader> ( handle -- stream )
- input-port <buffered-port> <line-reader> ;
+: <reader> ( handle -- input-port )
+ input-port <buffered-port> ;
-: <writer> ( handle -- stream )
- output-port <buffered-port> <plain-writer> ;
+: <writer> ( handle -- output-port )
+ output-port <buffered-port> ;
-: handle>duplex-stream ( in-handle out-handle -- stream )
- <writer>
- [ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
- cleanup ;
+: <reader&writer> ( read-handle write-handle -- input-port output-port )
+ swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ;
M: input-port stream-read1
dup wait-to-read1 [ buffer-pop ] unless-eof ;
-: read-step ( count port -- string/f )
+: read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep
[ dupd buffer> ] unless-eof nip ;
-: read-loop ( count port sbuf -- )
+: read-loop ( count port accum -- )
pick over length - dup 0 > [
pick read-step dup [
over push-all read-loop
>r 0 max >fixnum r>
2dup read-step dup [
pick over length > [
- pick <sbuf>
+ pick <byte-vector>
[ push-all ] keep
[ read-loop ] keep
- "" like
+ B{ } like
] [
2nip
] if
2nip
] if ;
-: read-until-step ( separators port -- string/f separator/f )
+: read-until-step ( separators port -- byte-array/f separator/f )
dup wait-to-read1
dup port-eof? [
f swap set-port-eof? drop f f
buffer-until
] if ;
-: read-until-loop ( seps port sbuf -- separator/f )
+: read-until-loop ( seps port accum -- separator/f )
2over read-until-step over [
>r over push-all r> dup [
>r 3drop r>
>r 2drop 2drop r>
] if ;
-M: input-port stream-read-until ( seps port -- str/f sep/f )
+M: input-port stream-read-until ( seps port -- byte-array/f sep/f )
2dup read-until-step dup [
>r 2nip r>
] [
over [
- drop >sbuf [ read-until-loop ] keep "" like swap
+ drop BV{ } like
+ [ read-until-loop ] keep
+ B{ } like swap
] [
>r 2nip r>
] if
] if ;
-M: input-port stream-read-partial ( max stream -- string/f )
+M: input-port stream-read-partial ( max stream -- byte-array/f )
>r 0 max >fixnum r> read-step ;
: can-write? ( len writer -- ? )
tuck can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
- 1 over wait-to-write ch>buffer ;
+ 1 over wait-to-write byte>buffer ;
M: output-port stream-write
over length over buffer-size > [
[ dup port-type >r closed over set-port-type r> close-port ]
if ;
-TUPLE: server-port addr client ;
+TUPLE: server-port addr client client-addr encoding ;
-: <server-port> ( handle addr -- server )
- >r f server-port <port> r>
- { set-delegate set-server-port-addr }
+: <server-port> ( handle addr encoding -- server )
+ rot f server-port <port>
+ { set-server-port-addr set-server-port-encoding set-delegate }
server-port construct ;
: check-server-port ( port -- )
-USING: arrays assocs combinators.lib dlists io.files
-kernel namespaces sequences shuffle vectors ;
+USING: io.files kernel sequences new-slots accessors
+dlists arrays sequences.lib ;
IN: io.paths
-! HOOK: library-roots io-backend ( -- seq )
-! HOOK: binary-roots io-backend ( -- seq )
+TUPLE: directory-iterator path bfs queue ;
-<PRIVATE
-: append-path ( path files -- paths )
- [ >r path+ r> ] with* assoc-map ;
+: qualified-directory ( path -- seq )
+ dup directory [ first2 >r path+ r> 2array ] with map ;
-: get-paths ( dir -- paths )
- dup directory append-path ;
+: push-directory ( path iter -- )
+ >r qualified-directory r> [
+ dup queue>> swap bfs>>
+ [ push-front ] [ push-back ] if
+ ] curry each ;
-: (walk-dir) ( path -- )
- first2 [
- get-paths dup keys % [ (walk-dir) ] each
- ] [
- drop
- ] if ;
-PRIVATE>
-
-: walk-dir ( path -- seq )
- dup directory? 2array [ (walk-dir) ] { } make ;
-
-GENERIC# find-file* 1 ( obj quot -- path/f )
+: <directory-iterator> ( path bfs? -- iterator )
+ <dlist> directory-iterator construct-boa
+ dup path>> over push-directory ;
-M: dlist find-file* ( dlist quot -- path/f )
- over dlist-empty? [ 2drop f ] [
- 2dup >r pop-front get-paths dup r> assoc-find
- [ drop 3nip ]
- [ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if
+: next-file ( iter -- file/f )
+ dup queue>> dlist-empty? [ drop f ] [
+ dup queue>> pop-back first2
+ [ over push-directory next-file ] [ nip ] if
] if ;
-M: vector find-file* ( vector quot -- path/f )
- over empty? [ 2drop f ] [
- 2dup >r pop get-paths dup r> assoc-find
- [ drop 3nip ]
- [ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if
- ] if ;
+: iterate-directory ( iter quot -- obj )
+ 2dup >r >r >r next-file dup [
+ r> call dup [
+ r> r> 2drop
+ ] [
+ drop r> r> iterate-directory
+ ] if
+ ] [
+ drop r> r> r> 3drop f
+ ] if ; inline
+
+: find-file ( path bfs? quot -- path/f )
+ >r <directory-iterator> r>
+ [ keep and ] curry iterate-directory ; inline
-: prepare-find-file ( quot -- quot )
- [ drop ] swap compose ;
+: each-file ( path bfs? quot -- )
+ >r <directory-iterator> r>
+ [ f ] compose iterate-directory drop ; inline
-: find-file-depth ( path quot -- path/f )
- prepare-find-file >r 1vector r> find-file* ;
+: find-all-files ( path bfs? quot -- paths )
+ >r <directory-iterator> r>
+ pusher >r iterate-directory drop r> ; inline
-: find-file-breadth ( path quot -- path/f )
- prepare-find-file >r 1dlist r> find-file* ;
+: recursive-directory ( path bfs? -- paths )
+ [ ] accumulator >r each-file r> ;
USING: help help.syntax help.markup io ;
IN: io.server
-HELP: with-client
-{ $values { "quot" "a quotation" } { "client" "a client socket stream" } }
-{ $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ;
-
HELP: with-server
-{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
+{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being the " { $link stdio } " stream. Client connections are logged to the " { $link stdio } " stream at the time the server was started." } ;
HELP: with-datagrams
-IN: temporary
-USING: tools.test io.server ;
+IN: io.server.tests
+USING: tools.test io.server io.server.private ;
-{ 1 0 } [ [ ] spawn-server ] must-infer-as
+{ 2 0 } [ [ ] server-loop ] must-infer-as
<PRIVATE
-: spawn-vars ( quot vars name -- )
- >r [ dup get ] H{ } map>assoc [ swap bind ] 2curry r>
- spawn drop ;
-
LOG: accepted-connection NOTICE
: with-client ( client quot -- )
: accept-loop ( server quot -- )
[
- >r accept r> [ with-client ] 2curry
- { log-service servers } "Client" spawn-vars
+ >r accept r> [ with-client ] 2curry "Client" spawn drop
] 2keep accept-loop ; inline
-: server-loop ( addrspec quot -- )
+: server-loop ( addrspec encoding quot -- )
>r <server> dup servers get push r>
[ accept-loop ] curry with-disposal ; inline
: internet-server ( port -- seq )
f swap t resolve-host ;
-: with-server ( seq service quot -- )
- V{ } clone [
- servers [
- [ server-loop ] curry with-logging
- ] with-variable
- ] 3curry parallel-each ; inline
+: with-server ( seq service encoding quot -- )
+ V{ } clone servers [
+ [
+ [ server-loop ] 2curry with-logging
+ ] 3curry parallel-each
+ ] with-variable ; inline
: stop-server ( -- )
servers get [ dispose ] each ;
--- /dev/null
+TCP/IP and UDP/IP servers
+++ /dev/null
-Doug Coleman
-Elie Chaftari
+++ /dev/null
-Doug Coleman
-Elie Chaftari
+++ /dev/null
-USING: io.backend kernel system vocabs.loader ;
-IN: io.sniffer.backend
-
-SYMBOL: sniffer-type
-TUPLE: sniffer ;
-HOOK: <sniffer> io-backend ( obj -- sniffer )
+++ /dev/null
-Doug Coleman
-Elie Chaftari
+++ /dev/null
-! Copyright (C) 2007 Elie Chaftari, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax destructors hexdump io
-io.buffers io.nonblocking io.sockets io.streams.lines
-io.unix.backend io.unix.files kernel libc locals math qualified
-sequences io.sniffer.backend ;
-QUALIFIED: unix
-IN: io.sniffer.bsd
-
-M: unix-io destruct-handle ( obj -- ) unix:close drop ;
-
-C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
-C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;
-
-TUPLE: sniffer-spec path ifname ;
-
-C: <sniffer-spec> sniffer-spec
-
-: IOCPARM_MASK HEX: 1fff ; inline
-: IOCPARM_MAX IOCPARM_MASK 1+ ; inline
-: IOC_VOID HEX: 20000000 ; inline
-: IOC_OUT HEX: 40000000 ; inline
-: IOC_IN HEX: 80000000 ; inline
-: IOC_INOUT IOC_IN IOC_OUT bitor ; inline
-: IOC_DIRMASK HEX: e0000000 ; inline
-
-:: ioc | inout group num len |
- group first 8 shift num bitor
- len IOCPARM_MASK bitand 16 shift bitor
- inout bitor ;
-
-: io-len ( type -- n )
- dup zero? [ heap-size ] unless ;
-
-: io ( group num -- n )
- IOC_VOID -rot 0 io-len ioc ;
-
-: ior ( group num type -- n )
- IOC_OUT -roll io-len ioc ;
-
-: iow ( group num type -- n )
- IOC_IN -roll io-len ioc ;
-
-: iowr ( group num type -- n )
- IOC_INOUT -roll io-len ioc ;
-
-: BIOCGBLEN ( -- n ) "B" 102 "uint" ior ; inline
-: BIOCSETIF ( -- n ) "B" 108 "ifreq" iow ; inline
-: BIOCPROMISC ( -- n ) "B" 105 io ; inline
-: BIOCIMMEDIATE ( -- n ) "B" 112 "uint" iow ; inline
-
-: make-ifreq-props ( ifname -- ifreq )
- "ifreq" <c-object>
- 12 <short> 16 0 pad-right over set-ifreq-props
- swap malloc-char-string dup free-always
- over set-ifreq-name ;
-
-: make-ioctl-buffer ( fd -- buffer )
- BIOCGBLEN "char*" <c-object>
- [ unix:ioctl io-error ] keep
- *int <buffer> ;
-
-: ioctl-BIOSETIF ( fd ifreq -- )
- >r BIOCSETIF r> unix:ioctl io-error ;
-
-: ioctl-BIOPROMISC ( fd -- )
- BIOCPROMISC f unix:ioctl io-error ;
-
-: ioctl-BIOCIMMEDIATE
- BIOCIMMEDIATE 1 <int> unix:ioctl io-error ;
-
-: ioctl-sniffer-fd ( fd ifname -- )
- dupd make-ifreq-props ioctl-BIOSETIF
- dup ioctl-BIOPROMISC
- ioctl-BIOCIMMEDIATE ;
-
-M: unix-io <sniffer> ( obj -- sniffer )
- [
- [
- sniffer-spec-path
- open-read
- dup close-later
- ] keep
- dupd sniffer-spec-ifname ioctl-sniffer-fd
- dup make-ioctl-buffer
- input-port <port> <line-reader>
- \ sniffer construct-delegate
- ] with-destructors ;
-
+++ /dev/null
-Doug Coleman
-Elie Chaftari
+++ /dev/null
-Doug Coleman
-Elie Chaftari
+++ /dev/null
-USING: byte-arrays combinators io io.backend
-io.sockets.headers io.sniffer.backend kernel
-prettyprint sequences ;
-IN: io.sniffer.filter.backend
-
-HOOK: sniffer-loop io-backend ( stream -- )
-HOOK: packet. io-backend ( string -- )
-
-: (packet.) ( string -- )
- dup 14 head >byte-array
- "--Ethernet Header--" print
- dup etherneth.
- dup etherneth-type {
- ! HEX: 800 [ ] ! IP
- ! HEX: 806 [ ] ! ARP
- [ "Unknown type: " write .h ]
- } case 2drop ;
+++ /dev/null
-Doug Coleman
-Elie Chaftari
+++ /dev/null
-USING: alien.c-types hexdump io io.backend io.sockets.headers
-io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
-io.streams.string io.unix.backend math
-sequences system byte-arrays io.sniffer.filter.backend
-io.sniffer.filter.backend io.sniffer.backend ;
-IN: io.sniffer.filter.bsd
-
-! http://www.iana.org/assignments/ethernet-numbers
-
-: bpf-align ( n -- n' )
- #! Align to next higher word size
- "long" heap-size align ;
-
-M: unix-io packet. ( string -- )
- 18 cut swap >byte-array bpfh.
- (packet.) ;
-
-M: unix-io sniffer-loop ( stream -- )
- nl nl
- 4096 over stream-read-partial
- dup hexdump.
- packet.
- sniffer-loop ;
-
-
-! Mac
-: sniff-wired ( -- )
- "/dev/bpf0" "en0" <sniffer-spec> <sniffer> sniffer-loop ;
-
-! Macbook
-: sniff-wireless ( -- )
- "/dev/bpf0" "en1" <sniffer-spec> <sniffer> sniffer-loop ;
-
+++ /dev/null
-USING: alien.c-types byte-arrays combinators hexdump io
-io.backend io.streams.string io.sockets.headers kernel math
-prettyprint io.sniffer sequences system vocabs.loader
-io.sniffer.filter.backend ;
-IN: io.sniffer.filter
-
-
-bsd? [ "io.sniffer.filter.bsd" require ] when
+++ /dev/null
-USING: io.backend kernel system vocabs.loader ;
-IN: io.sniffer
-
-bsd? [ "io.sniffer.bsd" require ] when
Slava Pestov
+Daniel Ehrenberg
USING: io.sockets.impl io.sockets kernel tools.test ;
-IN: temporary
+IN: io.sockets.impl.tests
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
SYMBOL: port-override
-: (port) port-override get [ ] [ ] ?if ;
+: (port) port-override get swap or ;
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
} ;
HELP: <client>
-{ $values { "addrspec" "an address specifier" } { "stream" "a bidirectional stream" } }
-{ $description "Opens a network connection and outputs a bidirectional stream." }
+{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } }
+{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." }
{ $errors "Throws an error if the connection cannot be established." }
{ $examples
- { $code "\"www.apple.com\" \"http\" <inet> <client>" }
+ { $code "\"www.apple.com\" \"http\" <inet> utf8 <client>" }
} ;
HELP: <server>
-{ $values { "addrspec" "an address specifier" } { "server" "a handle" } }
+{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } }
{ $description
"Begins listening for network connections to a local address. Server objects responds to two words:"
{ $list
{ { $link dispose } " - stops listening on the port and frees all associated resources" }
- { { $link accept } " - blocks until there is a connection" }
+ { { $link accept } " - blocks until there is a connection, and returns a stream of the encoding passed to the constructor" }
}
}
{ $notes
HELP: accept
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
-{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established."
+{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
$nl
"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
"To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
{ $code "\"localhost\" 1234 t resolve-host" }
"Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
+ "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
}
{ $errors "Throws an error if the port is already in use, or if the OS forbids access." } ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.sockets
USING: generic kernel io.backend namespaces continuations
-sequences arrays ;
+sequences arrays io.encodings io.nonblocking ;
+IN: io.sockets
TUPLE: local path ;
{ set-client-stream-addr set-delegate }
client-stream construct ;
-HOOK: (client) io-backend ( addrspec -- stream )
+HOOK: (client) io-backend ( addrspec -- client-in client-out )
+
+GENERIC: client* ( addrspec -- client-in client-out )
+M: array client* [ (client) 2array ] attempt-all first2 ;
+M: object client* (client) ;
-GENERIC: <client> ( addrspec -- stream )
+: <client> ( addrspec encoding -- stream )
+ >r client* r> <encoder-duplex> ;
-M: array <client> [ (client) ] attempt-all ;
+HOOK: (server) io-backend ( addrspec -- handle )
-M: object <client> (client) ;
+: <server> ( addrspec encoding -- server )
+ >r [ (server) ] keep r> <server-port> ;
-HOOK: <server> io-backend ( addrspec -- server )
+HOOK: (accept) io-backend ( server -- addrspec handle )
-HOOK: accept io-backend ( server -- client )
+: accept ( server -- client )
+ [ (accept) dup <reader&writer> ] keep
+ server-port-encoding <encoder-duplex>
+ <client-stream> ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
HOOK: host-name io-backend ( -- string )
-M: inet <client>
+M: inet client*
dup inet-host swap inet-port f resolve-host
dup empty? [ "Host name lookup failed" throw ] when
- <client> ;
+ client* ;
--- /dev/null
+Low-level support for setting timeouts on I/O operations
IN: io.timeouts\r
-USING: help.markup help.syntax math kernel ;\r
+USING: help.markup help.syntax math kernel calendar ;\r
\r
-HELP: get-lapse\r
-{ $values { "obj" object } { "lapse" lapse } }\r
-{ $contract "Outputs an object's timeout lapse descriptor." } ;\r
+HELP: timeout\r
+{ $values { "obj" object } { "dt/f" "a " { $link duration } " or " { $link f } } }\r
+{ $contract "Outputs an object's timeout." } ;\r
\r
HELP: set-timeout\r
-{ $values { "ms" integer } { "obj" object } }\r
-{ $contract "Sets an object's timeout, in milliseconds." }\r
-{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;\r
+{ $values { "dt/f" "a " { $link duration } " or " { $link f } } { "obj" object } }\r
+{ $contract "Sets an object's timeout." } ;\r
\r
HELP: timed-out\r
{ $values { "obj" object } }\r
\r
ARTICLE: "io.timeouts" "I/O timeout protocol"\r
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
+{ $subsection timeout }\r
{ $subsection set-timeout }\r
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."\r
-{ $subsection get-lapse }\r
{ $subsection timed-out }\r
"A combinator to be used in operations which can time out:"\r
{ $subsection with-timeout }\r
-{ $see-also "stream-protocol" "io.launcher" }\r
-;\r
+{ $see-also "stream-protocol" "io.launcher" } ;\r
\r
ABOUT: "io.timeouts"\r
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel math system dlists namespaces assocs init\r
-threads io.streams.duplex ;\r
+USING: kernel calendar alarms io.streams.duplex ;\r
IN: io.timeouts\r
\r
-TUPLE: lapse entry timeout cutoff ;\r
-\r
-: <lapse> f 0 0 \ lapse construct-boa ;\r
-\r
! Won't need this with new slot accessors\r
-GENERIC: get-lapse ( obj -- lapse )\r
-\r
-GENERIC: set-timeout ( ms obj -- )\r
-\r
-M: object set-timeout get-lapse set-timeout ;\r
-\r
-M: lapse set-timeout set-lapse-timeout ;\r
+GENERIC: timeout ( obj -- dt/f )\r
+GENERIC: set-timeout ( dt/f obj -- )\r
\r
-: timeout ( obj -- ms ) get-lapse lapse-timeout ;\r
-: entry ( obj -- dlist-node ) get-lapse lapse-entry ;\r
-: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;\r
-: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;\r
-: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;\r
-\r
-! Won't need this with inheritance\r
-TUPLE: duplex-stream-lapse stream ;\r
-\r
-M: duplex-stream-lapse set-timeout\r
- duplex-stream-lapse-stream 2dup\r
+M: duplex-stream set-timeout\r
+ 2dup\r
duplex-stream-in set-timeout\r
duplex-stream-out set-timeout ;\r
\r
-M: duplex-stream get-lapse duplex-stream-lapse construct-boa ;\r
-\r
-SYMBOL: timeout-queue\r
-\r
-: timeout? ( lapse -- ? )\r
- cutoff dup zero? not swap millis < and ;\r
-\r
-timeout-queue global [ [ <dlist> ] unless* ] change-at\r
-\r
-: unqueue-timeout ( obj -- )\r
- entry [\r
- timeout-queue get-global swap delete-node\r
- ] when* ;\r
-\r
-: queue-timeout ( obj -- )\r
- dup timeout-queue get-global push-front*\r
- swap set-entry ;\r
-\r
GENERIC: timed-out ( obj -- )\r
\r
M: object timed-out drop ;\r
\r
-: expire-timeouts ( -- )\r
- timeout-queue get-global dup dlist-empty? [ drop ] [\r
- dup peek-back timeout?\r
- [ pop-back timed-out expire-timeouts ] [ drop ] if\r
- ] if ;\r
-\r
-: begin-timeout ( obj -- )\r
- dup timeout dup zero? [\r
- 2drop\r
- ] [\r
- millis + over set-cutoff\r
- dup unqueue-timeout queue-timeout\r
- ] if ;\r
+: queue-timeout ( obj timeout -- alarm )\r
+ >r [ timed-out ] curry r> later ;\r
\r
: with-timeout ( obj quot -- )\r
- over begin-timeout keep unqueue-timeout ; inline\r
-\r
-: expiry-thread ( -- )\r
- expire-timeouts 5000 sleep expiry-thread ;\r
-\r
-: start-expiry-thread ( -- )\r
- [ expiry-thread ] "I/O expiry" spawn drop ;\r
-\r
-[ start-expiry-thread ] "io.timeouts" add-init-hook\r
+ over dup timeout dup [\r
+ queue-timeout slip cancel-alarm\r
+ ] [\r
+ 2drop call\r
+ ] if ; inline\r
! See http://factorcode.org/license.txt for BSD license.
USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs
-threads unix vectors io.buffers io.backend
+threads unix vectors io.buffers io.backend io.encodings
io.streams.duplex math.parser continuations system libc
-qualified namespaces io.timeouts ;
+qualified namespaces io.timeouts io.encodings.utf8 ;
QUALIFIED: io
IN: io.unix.backend
: add-write-io-task ( port continuation -- )
over port-handle mx get-global mx-writes at*
- [ io-task-callbacks push ]
+ [ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
-M: unix-io io-multiplex ( ms -- )
+M: unix-io io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
-M: unix-io init-stdio ( -- )
- 0 1 handle>duplex-stream io:stdio set-global
- 2 <writer> io:stderr set-global ;
+M: unix-io (init-stdio) ( -- )
+ 0 <reader>
+ 1 <writer>
+ 2 <writer> ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port mx ;
USING: tools.test io.files ;
-IN: temporary
+IN: io.unix.files.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.nonblocking io.unix.backend io.files io
-unix kernel math continuations math.bitfields byte-arrays
-alien ;
+unix unix.stat unix.time kernel math continuations math.bitfields
+byte-arrays alien combinators combinators.cleave calendar
+io.encodings.binary ;
+
IN: io.unix.files
M: unix-io cwd
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
-M: unix-io <file-reader> ( path -- stream )
+M: unix-io (file-reader) ( path -- stream )
open-read <reader> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
: open-write ( path -- fd )
write-flags file-mode open dup io-error ;
-M: unix-io <file-writer> ( path -- stream )
+M: unix-io (file-writer) ( path -- stream )
open-write <writer> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
append-flags file-mode open dup io-error
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
-M: unix-io <file-appender> ( path -- stream )
+M: unix-io (file-appender) ( path -- stream )
open-append <writer> ;
-M: unix-io rename-file ( from to -- )
+: touch-mode
+ { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
+
+M: unix-io touch-file ( path -- )
+ touch-mode file-mode open
+ dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
+ close ;
+
+M: unix-io move-file ( from to -- )
rename io-error ;
M: unix-io delete-file ( path -- )
M: unix-io delete-directory ( path -- )
rmdir io-error ;
+
+: (copy-file) ( from to -- )
+ dup parent-directory make-directories
+ binary <file-writer> [
+ swap binary <file-reader> [
+ swap stream-copy
+ ] with-disposal
+ ] with-disposal ;
+
+M: unix-io copy-file ( from to -- )
+ [ (copy-file) ] 2keep swap file-permissions chmod io-error ;
+
+: stat>type ( stat -- type )
+ stat-st_mode {
+ { [ dup S_ISREG ] [ +regular-file+ ] }
+ { [ dup S_ISDIR ] [ +directory+ ] }
+ { [ dup S_ISCHR ] [ +character-device+ ] }
+ { [ dup S_ISBLK ] [ +block-device+ ] }
+ { [ dup S_ISFIFO ] [ +fifo+ ] }
+ { [ dup S_ISLNK ] [ +symbolic-link+ ] }
+ { [ dup S_ISSOCK ] [ +socket+ ] }
+ { [ t ] [ +unknown+ ] }
+ } cond nip ;
+
+M: unix-io file-info ( path -- info )
+ stat* {
+ [ stat>type ]
+ [ stat-st_size ]
+ [ stat-st_mode ]
+ [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
+ } cleave
+ \ file-info construct-boa ;
+
+M: unix-io link-info ( path -- info )
+ lstat* {
+ [ stat>type ]
+ [ stat-st_size ]
+ [ stat-st_mode ]
+ [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
+ } cleave
+ \ file-info construct-boa ;
--- /dev/null
+USING: kernel io.nonblocking io.unix.backend math.bitfields
+unix io.files.unique.backend ;
+IN: io.unix.files.unique
+
+: open-unique-flags ( -- flags )
+ { O_RDWR O_CREAT O_EXCL } flags ;
+
+M: unix-io (make-unique-file) ( path -- duplex-stream )
+ open-unique-flags file-mode open dup io-error
+ <writer> ;
+
+M: unix-io temporary-path ( -- path ) "/tmp" ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
-sequences assocs unix unix.kqueue unix.process math namespaces
+sequences assocs unix unix.time unix.kqueue unix.process math namespaces
combinators threads vectors io.launcher
io.unix.launcher ;
IN: io.unix.kqueue
swap io-task-filter over set-kevent-filter ;
: register-kevent ( kevent mx -- )
- mx-fd swap 1 f 0 f kevent io-error ;
+ mx-fd swap 1 f 0 f kevent
+ 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
M: kqueue-mx register-io-task ( task mx -- )
over EV_ADD make-kevent over register-kevent
: kevent-proc-task ( pid -- )
dup wait-for-pid swap find-process
- dup [ notify-exit ] [ 2drop ] if ;
+ dup [ swap notify-exit ] [ 2drop ] if ;
: handle-kevent ( mx kevent -- )
dup kevent-ident swap kevent-filter {
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( ms mx -- )
- swap make-timespec dupd wait-kevent handle-kevents ;
+ swap dup [ make-timespec ] when
+ dupd wait-kevent handle-kevents ;
: make-proc-kevent ( pid -- kevent )
"kevent" <c-object>
-IN: temporary
-USING: io.unix.launcher tools.test ;
-
-[ "" tokenize-command ] must-fail
-[ " " tokenize-command ] must-fail
-[ { "a" } ] [ "a" tokenize-command ] unit-test
-[ { "abc" } ] [ "abc" tokenize-command ] unit-test
-[ { "abc" } ] [ "abc " tokenize-command ] unit-test
-[ { "abc" } ] [ " abc" tokenize-command ] unit-test
-[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
-[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
-[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
-[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
-[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
-[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
-[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
-[ "'abc def' \"hey" tokenize-command ] must-fail
-[ "'abc def" tokenize-command ] must-fail
-[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
-
-[
- {
- "Hello world.app/Contents/MacOS/hello-ui"
- "-i=boot.macosx-ppc.image"
- "-include= math compiler ui"
- "-deploy-vocab=hello-ui"
- "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
- "-no-stack-traces"
- "-no-user-init"
- }
-] [
- "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
+IN: io.unix.launcher.tests
+USING: io.files tools.test io.launcher arrays io namespaces
+continuations math io.encodings.ascii io.encodings.latin1
+accessors kernel sequences ;
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ "touch"
+ "launcher-test-1" temp-file
+ 2array
+ try-process
+] unit-test
+
+[ t ] [ "launcher-test-1" temp-file exists? ] unit-test
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ <process>
+ "echo Hello" >>command
+ "launcher-test-1" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "Hello\n" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-stream> contents
+] unit-test
+
+[ "" ] [
+ <process>
+ "cat"
+ "launcher-test-1" temp-file
+ 2array >>command
+ +inherit+ >>stdout
+ ascii <process-stream> contents
+] unit-test
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ <process>
+ "cat" >>command
+ +closed+ >>stdin
+ "launcher-test-1" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-stream> contents
+] unit-test
+
+[ ] [
+ 2 [
+ "launcher-test-1" temp-file ascii <file-appender> [
+ <process>
+ swap >>stdout
+ "echo Hello" >>command
+ try-process
+ ] with-disposal
+ ] times
+] unit-test
+
+[ "Hello\nHello\n" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-stream> contents
+] unit-test
+
+[ t ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ latin1 <process-stream> lines
+ "A=B" swap member?
+] unit-test
+
+[ { "A=B" } ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ +replace-environment+ >>environment-mode
+ latin1 <process-stream> lines
] unit-test
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.backend io.launcher io.unix.backend io.unix.files
-io.nonblocking sequences kernel namespaces math system
- alien.c-types debugger continuations arrays assocs
-combinators unix.process parser-combinators memoize
-promises strings threads unix ;
+USING: io io.backend io.launcher io.nonblocking io.unix.backend
+io.unix.files io.nonblocking sequences kernel namespaces math
+system alien.c-types debugger continuations arrays assocs
+combinators unix.process strings threads unix
+io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
IN: io.unix.launcher
! Search unix first
USE: unix
-! Our command line parser. Supported syntax:
-! foo bar baz -- simple tokens
-! foo\ bar -- escaping the space
-! 'foo bar' -- quotation
-! "foo bar" -- quotation
-LAZY: 'escaped-char' "\\" token any-char-parser &> ;
+: get-arguments ( process -- seq )
+ command>> dup string? [ tokenize-command ] when ;
-LAZY: 'quoted-char' ( delimiter -- parser' )
- 'escaped-char'
- swap [ member? not ] curry satisfy
- <|> ; inline
-
-LAZY: 'quoted' ( delimiter -- parser )
- dup 'quoted-char' <!*> swap dup surrounded-by ;
-
-LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' <!+> ;
+: assoc>env ( assoc -- env )
+ [ "=" swap 3append ] { } assoc>map ;
-LAZY: 'argument' ( -- parser )
- "\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|>
- [ >string ] <@ ;
+: redirect-fd ( oldfd fd -- )
+ 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
-MEMO: 'arguments' ( -- parser )
- 'argument' " " token <!+> nonempty-list-of ;
+: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ;
-: tokenize-command ( command -- arguments )
- 'arguments' just parse-1 ;
+: redirect-inherit ( obj mode fd -- )
+ 2nip reset-fd ;
-: get-arguments ( -- seq )
- +command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
+: redirect-file ( obj mode fd -- )
+ >r file-mode open dup io-error r> redirect-fd ;
-: assoc>env ( assoc -- env )
- [ "=" swap 3append ] { } assoc>map ;
+: redirect-closed ( obj mode fd -- )
+ >r >r drop "/dev/null" r> r> redirect-file ;
-: (redirect) ( path mode fd -- )
- >r file-mode open dup io-error dup
- r> dup2 io-error close ;
+: redirect-stream ( obj mode fd -- )
+ >r drop underlying-handle dup reset-fd r> redirect-fd ;
: redirect ( obj mode fd -- )
{
- { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] }
- { [ pick string? ] [ (redirect) ] }
+ { [ pick not ] [ redirect-inherit ] }
+ { [ pick string? ] [ redirect-file ] }
+ { [ pick +closed+ eq? ] [ redirect-closed ] }
+ { [ pick +inherit+ eq? ] [ redirect-closed ] }
+ { [ t ] [ redirect-stream ] }
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
-: setup-redirection ( -- )
- +stdin+ get ?closed read-flags 0 redirect
- +stdout+ get ?closed write-flags 1 redirect
- +stderr+ get dup +stdout+ eq?
+: setup-redirection ( process -- process )
+ dup stdin>> ?closed read-flags 0 redirect
+ dup stdout>> ?closed write-flags 1 redirect
+ dup stderr>> dup +stdout+ eq?
[ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
-: spawn-process ( -- )
+: spawn-process ( process -- * )
[
setup-redirection
- get-arguments
- pass-environment?
- [ get-environment assoc>env exec-args-with-env ]
- [ exec-args-with-path ] if
- io-error
- ] [ error. :c flush ] recover 1 exit ;
+ dup pass-environment? [
+ dup get-environment set-os-envs
+ ] when
+
+ get-arguments exec-args-with-path
+ (io-error)
+ ] [ 255 exit ] recover ;
M: unix-io current-process-handle ( -- handle ) getpid ;
-M: unix-io run-process* ( desc -- pid )
- [
- [ spawn-process ] [ ] with-fork <process>
- ] with-descriptor ;
+M: unix-io run-process* ( process -- pid )
+ [ spawn-process ] curry [ ] with-fork ;
M: unix-io kill-process* ( pid -- )
SIGTERM kill io-error ;
2dup first close second close
>r first 0 dup2 drop r> second 1 dup2 drop ;
-: spawn-process-stream ( -- in out pid )
- open-pipe open-pipe [
- setup-stdio-pipe
- spawn-process
- ] [
- -rot 2dup second close first close
- ] with-fork first swap second rot <process> ;
-
-M: unix-io process-stream*
- [
- spawn-process-stream >r handle>duplex-stream r>
- ] with-descriptor ;
+M: unix-io (process-stream)
+ >r open-pipe open-pipe r>
+ [ >r setup-stdio-pipe r> spawn-process ] curry
+ [ -rot 2dup second close first close ]
+ with-fork
+ first swap second ;
: find-process ( handle -- process )
- processes get swap [ nip swap process-handle = ] curry
+ processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ;
! Inefficient process wait polling, used on Linux and Solaris.
2drop t
] [
find-process dup [
- >r *int WEXITSTATUS r> notify-exit f
+ swap *int WEXITSTATUS notify-exit f
] [
2drop f
] if
--- /dev/null
+IN: io.unix.launcher.parser.tests
+USING: io.unix.launcher.parser tools.test ;
+
+[ "" tokenize-command ] must-fail
+[ " " tokenize-command ] must-fail
+[ V{ "a" } ] [ "a" tokenize-command ] unit-test
+[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test
+[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test
+[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test
+[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
+[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
+[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
+[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
+[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
+[ "'abc def' \"hey" tokenize-command ] must-fail
+[ "'abc def" tokenize-command ] must-fail
+[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
+
+[
+ V{
+ "Hello world.app/Contents/MacOS/hello-ui"
+ "-i=boot.macosx-ppc.image"
+ "-include= math compiler ui"
+ "-deploy-vocab=hello-ui"
+ "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
+ "-no-stack-traces"
+ "-no-user-init"
+ }
+] [
+ "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.parsers kernel sequences strings words
+memoize ;
+IN: io.unix.launcher.parser
+
+! Our command line parser. Supported syntax:
+! foo bar baz -- simple tokens
+! foo\ bar -- escaping the space
+! 'foo bar' -- quotation
+! "foo bar" -- quotation
+MEMO: 'escaped-char' ( -- parser )
+ "\\" token [ drop t ] satisfy 2seq [ second ] action ;
+
+MEMO: 'quoted-char' ( delimiter -- parser' )
+ 'escaped-char'
+ swap [ member? not ] curry satisfy
+ 2choice ; inline
+
+MEMO: 'quoted' ( delimiter -- parser )
+ dup 'quoted-char' repeat0 swap dup surrounded-by ;
+
+MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
+
+MEMO: 'argument' ( -- parser )
+ "\"" 'quoted'
+ "'" 'quoted'
+ 'unquoted' 3choice
+ [ >string ] action ;
+
+PEG: tokenize-command ( command -- ast/f )
+ 'argument' " " token repeat1 list-of
+ " " token repeat0 swap over pack
+ just ;
: wd>monitor ( wd -- monitor ) watches at ;
-: <inotify> ( -- port )
+: <inotify> ( -- port/f )
H{ } clone
- inotify_init dup io-error inotify <buffered-port>
- { set-inotify-watches set-delegate } inotify construct ;
+ inotify_init dup 0 < [ 2drop f ] [
+ inotify <buffered-port>
+ { set-inotify-watches set-delegate } inotify construct
+ ] if ;
: inotify-fd inotify get-global port-handle ;
dup simple-monitor-handle watches delete-at
simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
+: check-inotify
+ inotify get [
+ "inotify is not supported by this Linux release" throw
+ ] unless ;
+
M: linux-io <monitor> ( path recursive? -- monitor )
+ check-inotify
drop IN_CHANGE_EVENTS add-watch ;
M: linux-monitor dispose ( monitor -- )
f inotify-task <input-task> ;
: init-inotify ( mx -- )
- <inotify>
- dup inotify set-global
+ <inotify> dup inotify set-global
<inotify-task> swap register-io-task ;
M: inotify-task do-io-task ( task -- )
f ;
M: select-mx wait-for-events ( ms mx -- )
- swap >r dup init-fdsets r> make-timeval
+ swap >r dup init-fdsets r> dup [ make-timeval ] when
select multiplexer-error
dup read-fdset/tasks pick handle-fdset
dup write-fdset/tasks rot handle-fdset ;
-! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
+! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
! We need to fiddle with the exact search order here, since
! unix::accept shadows streams::accept.
-IN: io.unix.sockets
USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
combinators ;
+IN: io.unix.sockets
: pending-init-error ( port -- )
#! We close it here to avoid a resource leak; callers of
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
-M: unix-io (client) ( addrspec -- stream )
+M: unix-io (client) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
zero? err_no EINPROGRESS = or [
dup init-client-socket
- dup handle>duplex-stream
- dup duplex-stream-out
+ dup <reader&writer>
dup wait-to-connect
- pending-init-error
+ dup pending-init-error
] [
dup close (io-error)
] if ;
dup <c-object> [ swap heap-size <int> accept ] keep ; inline
: do-accept ( port fd sockaddr -- )
- rot [
- server-port-addr parse-sockaddr
- swap dup handle>duplex-stream <client-stream>
- ] keep set-server-port-client ;
+ rot
+ [ server-port-addr parse-sockaddr ] keep
+ [ set-server-port-client-addr ] keep
+ set-server-port-client ;
M: accept-task do-io-task
io-task-port dup accept-sockaddr
dup rot make-sockaddr/size bind
zero? [ dup close (io-error) ] unless ;
-M: unix-io <server> ( addrspec -- stream )
- [
- SOCK_STREAM server-fd
- dup 10 listen zero? [ dup close (io-error) ] unless
- ] keep <server-port> ;
+M: unix-io (server) ( addrspec -- handle )
+ SOCK_STREAM server-fd
+ dup 10 listen zero? [ dup close (io-error) ] unless ;
-M: unix-io accept ( server -- client )
+M: unix-io (accept) ( server -- addrspec handle )
#! Wait for a client connection.
dup check-server-port
dup wait-to-accept
dup pending-error
- server-port-client ;
+ dup server-port-client-addr
+ swap server-port-client ;
! Datagram sockets - UDP and Unix domain
M: unix-io <datagram>
USING: io.files io.sockets io kernel threads
namespaces tools.test continuations strings byte-arrays
-sequences prettyprint system ;
-IN: temporary
+sequences prettyprint system io.encodings.binary io.encodings.ascii ;
+IN: io.unix.tests
! Unix domain stream sockets
+: socket-server "unix-domain-socket-test" temp-file ;
+
[
- [
- "unix-domain-socket-test" resource-path delete-file
- ] ignore-errors
+ [ socket-server delete-file ] ignore-errors
- "unix-domain-socket-test" resource-path <local>
- <server> [
- stdio get accept [
+ socket-server <local>
+ ascii <server> [
+ accept [
"Hello world" print flush
readln "XYZ" = "FOO" "BAR" ? print flush
] with-stream
- ] with-stream
+ ] with-disposal
- "unix-domain-socket-test" resource-path delete-file
+ socket-server delete-file
] "Test" spawn drop
yield
[ { "Hello world" "FOO" } ] [
[
- "unix-domain-socket-test" resource-path <local> <client>
+ socket-server <local> ascii <client>
[
readln ,
"XYZ" print flush
] { } make
] unit-test
-! Unix domain datagram sockets
-[
- "unix-domain-datagram-test" resource-path delete-file
-] ignore-errors
+: datagram-server "unix-domain-datagram-test" temp-file ;
+: datagram-client "unix-domain-datagram-test-2" temp-file ;
-: server-addr "unix-domain-datagram-test" resource-path <local> ;
-: client-addr "unix-domain-datagram-test-2" resource-path <local> ;
+! Unix domain datagram sockets
+[ datagram-server delete-file ] ignore-errors
+[ datagram-client delete-file ] ignore-errors
[
[
- server-addr <datagram> "d" set
+ datagram-server <local> <datagram> "d" set
"Receive 1" print
"Done" print
- "unix-domain-datagram-test" resource-path delete-file
+ datagram-server delete-file
] with-scope
] "Test" spawn drop
yield
-[
- "unix-domain-datagram-test-2" resource-path delete-file
-] ignore-errors
+[ datagram-client delete-file ] ignore-errors
-client-addr <datagram>
+datagram-client <local> <datagram>
"d" set
[ ] [
"hello" >byte-array
- server-addr
+ datagram-server <local>
"d" get send
] unit-test
[ "olleh" t ] [
"d" get receive
- server-addr =
+ datagram-server <local> =
>r >string r>
] unit-test
[ ] [
"hello" >byte-array
- server-addr
+ datagram-server <local>
"d" get send
] unit-test
[ "hello world" t ] [
"d" get receive
- server-addr =
+ datagram-server <local> =
>r >string r>
] unit-test
[ ] [ "d" get dispose ] unit-test
! Test error behavior
+: another-datagram "unix-domain-datagram-test-3" temp-file ;
-[
- "unix-domain-datagram-test-3" resource-path delete-file
-] ignore-errors
+[ another-datagram delete-file ] ignore-errors
-"unix-domain-datagram-test-2" resource-path delete-file
+datagram-client delete-file
-[ ] [ client-addr <datagram> "d" set ] unit-test
+[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
-[
- B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
-] must-fail
+[ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
[ ] [ "d" get dispose ] unit-test
[ "d" get receive ] must-fail
-[ B{ 1 2 } server-addr "d" get send ] must-fail
+[ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
! Invalid parameter tests
[
- image [ stdio get accept ] with-file-reader
+ image binary [ stdio get accept ] with-file-reader
] must-fail
[
- image [ stdio get receive ] with-file-reader
+ image binary [ stdio get receive ] with-file-reader
] must-fail
[
- image [
- B{ 1 2 } server-addr
+ image binary [
+ B{ 1 2 } datagram-server <local>
stdio get send
] with-file-reader
] must-fail
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
-io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences ;
+io.unix.launcher io.unix.mmap io.backend
+combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
USING: io.nonblocking io.windows threads.private kernel
io.backend windows.winsock windows.kernel32 windows
io.streams.duplex io namespaces alien.syntax system combinators
-io.buffers ;
+io.buffers io.encodings io.encodings.utf8 combinators.lib ;
IN: io.windows.ce.backend
: port-errored ( port -- )
win32-error-string swap set-port-error ;
-M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
+M: windows-ce-io io-multiplex ( ms -- )
+ 60 60 * 1000 * or (sleep) ;
+
M: windows-ce-io add-completion ( handle -- ) drop ;
GENERIC: wince-read ( port port-handle -- )
FUNCTION: void* _getstdfilex int fd ;
FUNCTION: void* _fileno void* file ;
-M: windows-ce-io init-stdio ( -- )
+M: windows-ce-io (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
winnt? [
STD_INPUT_HANDLE GetStdHandle
STD_OUTPUT_HANDLE GetStdHandle
+ STD_ERROR_HANDLE GetStdHandle
] [
0 _getstdfilex _fileno
1 _getstdfilex _fileno
- ] if <win32-duplex-stream>
- ] with-variable stdio set-global ;
+ 2 _getstdfilex _fileno
+ ] if [ f <win32-file> ] 3apply
+ rot <reader> -rot [ <writer> ] 2apply
+ ] with-variable ;
namespaces io.windows.mmap ;
IN: io.windows.ce
+USE: io.windows.files
T{ windows-ce-io } set-io-backend
windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ;
-M: windows-ce-io (client) ( addrspec -- duplex-stream )
- do-connect <win32-socket> dup handle>duplex-stream ;
+M: windows-ce-io (client) ( addrspec -- reader writer )
+ do-connect <win32-socket> dup <reader&writer> ;
-M: windows-ce-io <server> ( addrspec -- duplex-stream )
- [
- windows.winsock:SOCK_STREAM server-fd
- dup listen-on-socket
- <win32-socket>
- ] keep <server-port> ;
+M: windows-ce-io (server) ( addrspec -- handle )
+ windows.winsock:SOCK_STREAM server-fd
+ dup listen-on-socket
+ <win32-socket> ;
-M: windows-ce-io accept ( server -- client )
+M: windows-ce-io (accept) ( server -- client )
[
dup check-server-port
[
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
- <win32-socket> dup handle>duplex-stream <client-stream>
+ <win32-socket> <reader&writer>
] with-timeout ;
M: windows-ce-io <datagram> ( addrspec -- datagram )
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.files io.windows kernel
+math windows windows.kernel32 combinators.cleave
+windows.time calendar combinators math.functions
+sequences combinators.lib namespaces words symbols ;
+IN: io.windows.files
+
+SYMBOLS: +read-only+ +hidden+ +system+
++directory+ +archive+ +device+ +normal+ +temporary+
++sparse-file+ +reparse-point+ +compressed+ +offline+
++not-content-indexed+ +encrypted+ ;
+
+: expand-constants ( word/obj -- obj'/obj )
+ dup word? [ execute ] when ;
+
+: get-flags ( n seq -- seq' )
+ [
+ [
+ first2 expand-constants
+ [ swapd mask? [ , ] [ drop ] if ] 2curry
+ ] map call-with
+ ] { } make ;
+
+: win32-file-attributes ( n -- seq )
+ {
+ { +read-only+ FILE_ATTRIBUTE_READONLY }
+ { +hidden+ FILE_ATTRIBUTE_HIDDEN }
+ { +system+ FILE_ATTRIBUTE_SYSTEM }
+ { +directory+ FILE_ATTRIBUTE_DIRECTORY }
+ { +archive+ FILE_ATTRIBUTE_ARCHIVE }
+ { +device+ FILE_ATTRIBUTE_DEVICE }
+ { +normal+ FILE_ATTRIBUTE_NORMAL }
+ { +temporary+ FILE_ATTRIBUTE_TEMPORARY }
+ { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
+ { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
+ { +compressed+ FILE_ATTRIBUTE_COMPRESSED }
+ { +offline+ FILE_ATTRIBUTE_OFFLINE }
+ { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
+ { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
+ } get-flags ;
+
+: win32-file-type ( n -- symbol )
+ FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
+
+: WIN32_FIND_DATA>file-info
+ {
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+ [
+ [ WIN32_FIND_DATA-nFileSizeLow ]
+ [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
+ ]
+ [ WIN32_FIND_DATA-dwFileAttributes ]
+ ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
+ [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
+ ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
+ } cleave
+ \ file-info construct-boa ;
+
+: find-first-file-stat ( path -- WIN32_FIND_DATA )
+ "WIN32_FIND_DATA" <c-object> [
+ FindFirstFile
+ [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
+ FindClose win32-error=0/f
+ ] keep ;
+
+: BY_HANDLE_FILE_INFORMATION>file-info
+ {
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
+ [
+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
+ ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
+ ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
+ [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
+ ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
+ } cleave
+ \ file-info construct-boa ;
+
+: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
+ [
+ "BY_HANDLE_FILE_INFORMATION" <c-object>
+ [ GetFileInformationByHandle win32-error=0/f ] keep
+ ] keep CloseHandle win32-error=0/f ;
+
+: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
+ dup
+ GENERIC_READ FILE_SHARE_READ f
+ OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
+ CreateFileW dup INVALID_HANDLE_VALUE = [
+ drop find-first-file-stat WIN32_FIND_DATA>file-info
+ ] [
+ nip
+ get-file-information BY_HANDLE_FILE_INFORMATION>file-info
+ ] if ;
+
+M: windows-nt-io file-info ( path -- info )
+ get-file-information-stat ;
+
--- /dev/null
+USING: kernel system io.files.unique.backend
+windows.kernel32 io.windows io.nonblocking ;
+IN: io.windows.files.unique
+
+M: windows-io (make-unique-file) ( path -- stream )
+ GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ;
+
+M: windows-io temporary-path ( -- path )
+ "TEMP" os-env ;
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
-io.backend ;
+io.backend new-slots accessors ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
stdout-pipe stdin-pipe ;
: default-CreateProcess-args ( -- obj )
- 0
+ CreateProcess-args construct-empty
+ 0 >>dwCreateFlags
"STARTUPINFO" <c-object>
- "STARTUPINFO" heap-size over set-STARTUPINFO-cb
- "PROCESS_INFORMATION" <c-object>
- TRUE
- {
- set-CreateProcess-args-dwCreateFlags
- set-CreateProcess-args-lpStartupInfo
- set-CreateProcess-args-lpProcessInformation
- set-CreateProcess-args-bInheritHandles
- } \ CreateProcess-args construct ;
+ "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
+ "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
+ TRUE >>bInheritHandles ;
: call-CreateProcess ( CreateProcess-args -- )
{
- CreateProcess-args-lpApplicationName
- CreateProcess-args-lpCommandLine
- CreateProcess-args-lpProcessAttributes
- CreateProcess-args-lpThreadAttributes
- CreateProcess-args-bInheritHandles
- CreateProcess-args-dwCreateFlags
- CreateProcess-args-lpEnvironment
- CreateProcess-args-lpCurrentDirectory
- CreateProcess-args-lpStartupInfo
- CreateProcess-args-lpProcessInformation
+ lpApplicationName>>
+ lpCommandLine>>
+ lpProcessAttributes>>
+ lpThreadAttributes>>
+ bInheritHandles>>
+ dwCreateFlags>>
+ lpEnvironment>>
+ lpCurrentDirectory>>
+ lpStartupInfo>>
+ lpProcessInformation>>
} get-slots CreateProcess win32-error=0/f ;
: escape-argument ( str -- newstr )
: join-arguments ( args -- cmd-line )
[ escape-argument ] map " " join ;
-: app-name/cmd-line ( -- app-name cmd-line )
- +command+ get [
+: app-name/cmd-line ( process -- app-name cmd-line )
+ command>> dup string? [
" " split1
] [
- +arguments+ get unclip swap join-arguments
- ] if* ;
+ unclip swap join-arguments
+ ] if ;
-: cmd-line ( -- cmd-line )
- +command+ get [ +arguments+ get join-arguments ] unless* ;
+: cmd-line ( process -- cmd-line )
+ command>> dup string? [ join-arguments ] unless ;
-: fill-lpApplicationName
- app-name/cmd-line
- pick set-CreateProcess-args-lpCommandLine
- over set-CreateProcess-args-lpApplicationName ;
+: fill-lpApplicationName ( process args -- process args )
+ over app-name/cmd-line
+ >r >>lpApplicationName
+ r> >>lpCommandLine ;
-: fill-lpCommandLine
- cmd-line over set-CreateProcess-args-lpCommandLine ;
+: fill-lpCommandLine ( process args -- process args )
+ over cmd-line >>lpCommandLine ;
-: fill-dwCreateFlags
+: fill-dwCreateFlags ( process args -- process args )
0
- pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
- +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when
- over set-CreateProcess-args-dwCreateFlags ;
+ pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+ pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
+ >>dwCreateFlags ;
-: fill-lpEnvironment
- pass-environment? [
+: fill-lpEnvironment ( process args -- process args )
+ over pass-environment? [
[
- get-environment
- [ "=" swap 3append string>u16-alien % ] assoc-each
+ over get-environment
+ [ swap % "=" % % "\0" % ] assoc-each
"\0" %
- ] { } make >c-ushort-array
- over set-CreateProcess-args-lpEnvironment
+ ] "" make >c-ushort-array
+ >>lpEnvironment
] when ;
-: fill-startup-info
- dup CreateProcess-args-lpStartupInfo
- STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
+: fill-startup-info ( process args -- process args )
+ STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
-HOOK: fill-redirection io-backend ( args -- args )
+HOOK: fill-redirection io-backend ( process args -- )
-M: windows-ce-io fill-redirection ;
+M: windows-ce-io fill-redirection 2drop ;
-: make-CreateProcess-args ( -- args )
+: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment
- fill-startup-info ;
+ fill-startup-info
+ nip ;
M: windows-io current-process-handle ( -- handle )
GetCurrentProcessId ;
-M: windows-io run-process* ( desc -- handle )
+M: windows-io run-process* ( process -- handle )
[
- [
- make-CreateProcess-args
- fill-redirection
- dup call-CreateProcess
- CreateProcess-args-lpProcessInformation <process>
- ] with-descriptor
+ dup make-CreateProcess-args
+ tuck fill-redirection
+ dup call-CreateProcess
+ lpProcessInformation>>
] with-destructors ;
M: windows-io kill-process* ( handle -- )
: process-exited ( process -- )
dup process-handle exit-code
over process-handle dispose-process
- swap notify-exit ;
+ notify-exit ;
: wait-for-processes ( processes -- ? )
keys dup
: wait-loop ( -- )
processes get dup assoc-empty?
- [ drop t ] [ wait-for-processes ] if
- [ 250 sleep ] when ;
+ [ drop f sleep-until ]
+ [ wait-for-processes [ 100 sleep ] when ] if ;
+
+SYMBOL: wait-thread
: start-wait-thread ( -- )
- [ wait-loop t ] "Process wait" spawn-server drop ;
+ [ wait-loop t ] "Process wait" spawn-server
+ wait-thread set-global ;
+
+M: windows-io register-process
+ drop wait-thread get-global interrupt ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook
] "I/O" suspend 3drop ;
: wait-for-overlapped ( ms -- overlapped ? )
- >r master-completion-port get-global r> ! port ms
+ >r master-completion-port get-global
+ r> INFINITE or ! timeout
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
} cond ;
M: windows-nt-io normalize-pathname ( string -- string )
- dup string? [ "pathname must be a string" throw ] unless
+ dup string? [ "Pathname must be a string" throw ] unless
+ dup empty? [ "Empty pathname" throw ] when
{ { CHAR: / CHAR: \\ } } substitute
cwd swap windows-path+
[ "/\\." member? ] right-trim
--- /dev/null
+IN: io.windows.launcher.nt.tests\r
+USING: io.launcher tools.test calendar accessors\r
+namespaces kernel system arrays io io.files io.encodings.ascii\r
+sequences parser assocs hashtables ;\r
+\r
+[ ] [\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ "notepad" set\r
+] unit-test\r
+\r
+[ f ] [ "notepad" get process-running? ] unit-test\r
+\r
+[ f ] [ "notepad" get process-started? ] unit-test\r
+\r
+[ ] [ "notepad" [ run-detached ] change ] unit-test\r
+\r
+[ "notepad" get wait-for-process ] must-fail\r
+\r
+[ t ] [ "notepad" get killed>> ] unit-test\r
+\r
+[ f ] [ "notepad" get process-running? ] unit-test\r
+\r
+[ ] [\r
+ <process>\r
+ vm "-quiet" "-run=hello-world" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ try-process\r
+] unit-test\r
+\r
+[ "Hello world" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ ] [\r
+ <process>\r
+ vm "-run=listener" 2array >>command\r
+ +closed+ >>stdin\r
+ try-process\r
+] unit-test\r
+\r
+[ ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "stderr.factor" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ "err.txt" temp-file >>stderr\r
+ try-process\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "output" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "error" ] [\r
+ "err.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "stderr.factor" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ +stdout+ >>stderr\r
+ try-process\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "outputerror" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "output" ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "stderr.factor" 3array >>command\r
+ "err2.txt" temp-file >>stderr\r
+ ascii <process-stream> lines first\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "error" ] [\r
+ "err2.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ t ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "env.factor" 3array >>command\r
+ ascii <process-stream> contents\r
+ ] with-directory eval\r
+\r
+ os-envs =\r
+] unit-test\r
+\r
+[ t ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "env.factor" 3array >>command\r
+ +replace-environment+ >>environment-mode\r
+ os-envs >>environment\r
+ ascii <process-stream> contents\r
+ ] with-directory eval\r
+ \r
+ os-envs =\r
+] unit-test\r
+\r
+[ "B" ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "env.factor" 3array >>command\r
+ { { "A" "B" } } >>environment\r
+ ascii <process-stream> contents\r
+ ] with-directory eval\r
+\r
+ "A" swap at\r
+] unit-test\r
+\r
+[ f ] [\r
+ "extra/io/windows/nt/launcher/test" resource-path [\r
+ <process>\r
+ vm "-script" "env.factor" 3array >>command\r
+ { { "HOME" "XXX" } } >>environment\r
+ +prepend-environment+ >>environment-mode\r
+ ascii <process-stream> contents\r
+ ] with-directory eval\r
+\r
+ "HOME" swap at "XXX" =\r
+] unit-test\r
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend
-combinators ;
+combinators shuffle accessors locals ;
IN: io.windows.nt.launcher
+: duplicate-handle ( handle -- handle' )
+ GetCurrentProcess ! source process
+ swap ! handle
+ GetCurrentProcess ! target process
+ f <void*> [ ! target handle
+ DUPLICATE_SAME_ACCESS ! desired access
+ TRUE ! inherit handle
+ DUPLICATE_CLOSE_SOURCE ! options
+ DuplicateHandle win32-error=0/f
+ ] keep *void* ;
+
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
-: (redirect) ( path access-mode create-mode -- handle )
- >r >r
- normalize-pathname
- r> ! access-mode
+: redirect-default ( default obj access-mode create-mode -- handle )
+ 3drop ;
+
+: redirect-inherit ( default obj access-mode create-mode -- handle )
+ 4drop f ;
+
+: redirect-closed ( default obj access-mode create-mode -- handle )
+ drop 2nip null-pipe ;
+
+:: redirect-file ( default path access-mode create-mode -- handle )
+ path normalize-pathname
+ access-mode
share-mode
security-attributes-inherit
- r> ! create-mode
+ create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile dup invalid-handle? dup close-later ;
-: redirect ( obj access-mode create-mode -- handle )
- {
- { [ pick not ] [ 3drop f ] }
- { [ pick +closed+ eq? ] [ drop nip null-pipe ] }
- { [ pick string? ] [ (redirect) ] }
- } cond ;
-
-: ?closed or dup t eq? [ drop f ] when ;
-
-: inherited-stdout ( args -- handle )
- CreateProcess-args-stdout-pipe
- [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
+: set-inherit ( handle ? -- )
+ >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
-: redirect-stdout ( args -- handle )
- +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
- swap inherited-stdout ?closed ;
+: redirect-stream ( default stream access-mode create-mode -- handle )
+ 2drop nip
+ underlying-handle win32-file-handle
+ duplicate-handle dup t set-inherit ;
-: inherited-stderr ( args -- handle )
- drop STD_ERROR_HANDLE GetStdHandle ;
+: redirect ( default obj access-mode create-mode -- handle )
+ {
+ { [ pick not ] [ redirect-default ] }
+ { [ pick +inherit+ eq? ] [ redirect-inherit ] }
+ { [ pick +closed+ eq? ] [ redirect-closed ] }
+ { [ pick string? ] [ redirect-file ] }
+ { [ t ] [ redirect-stream ] }
+ } cond ;
-: redirect-stderr ( args -- handle )
- +stderr+ get
- dup +stdout+ eq? [
- drop
- CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
+: default-stdout ( args -- handle )
+ stdout-pipe>> dup [ pipe-out ] when ;
+
+: redirect-stdout ( process args -- handle )
+ default-stdout
+ swap stdout>>
+ GENERIC_WRITE
+ CREATE_ALWAYS
+ redirect
+ STD_OUTPUT_HANDLE GetStdHandle or ;
+
+: redirect-stderr ( process args -- handle )
+ over stderr>> +stdout+ eq? [
+ lpStartupInfo>>
+ STARTUPINFO-hStdOutput
+ nip
] [
- GENERIC_WRITE CREATE_ALWAYS redirect
- swap inherited-stderr ?closed
+ drop
+ f
+ swap stderr>>
+ GENERIC_WRITE
+ CREATE_ALWAYS
+ redirect
+ STD_ERROR_HANDLE GetStdHandle or
] if ;
-: inherited-stdin ( args -- handle )
- CreateProcess-args-stdin-pipe
- [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
+: default-stdin ( args -- handle )
+ stdin-pipe>> dup [ pipe-in ] when ;
-: redirect-stdin ( args -- handle )
- +stdin+ get GENERIC_READ OPEN_EXISTING redirect
- swap inherited-stdin ?closed ;
-
-: set-inherit ( handle ? -- )
- >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
+: redirect-stdin ( process args -- handle )
+ default-stdin
+ swap stdin>>
+ GENERIC_READ
+ OPEN_EXISTING
+ redirect
+ STD_INPUT_HANDLE GetStdHandle or ;
: add-pipe-dtors ( pipe -- )
dup
- pipe-in close-later
- pipe-out close-later ;
+ in>> close-later
+ out>> close-later ;
-: fill-stdout-pipe
+: fill-stdout-pipe ( args -- args )
<unique-incoming-pipe>
dup add-pipe-dtors
dup pipe-in f set-inherit
- over set-CreateProcess-args-stdout-pipe ;
+ >>stdout-pipe ;
-: fill-stdin-pipe
+: fill-stdin-pipe ( args -- args )
<unique-outgoing-pipe>
dup add-pipe-dtors
dup pipe-out f set-inherit
- over set-CreateProcess-args-stdin-pipe ;
+ >>stdin-pipe ;
-M: windows-nt-io fill-redirection
- dup CreateProcess-args-lpStartupInfo
- over redirect-stdout over set-STARTUPINFO-hStdOutput
- over redirect-stderr over set-STARTUPINFO-hStdError
- over redirect-stdin over set-STARTUPINFO-hStdInput
- drop ;
+M: windows-nt-io fill-redirection ( process args -- )
+ [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
+ [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
+ [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
+ 2drop ;
-M: windows-nt-io process-stream*
+M: windows-nt-io (process-stream)
[
- [
- make-CreateProcess-args
-
- fill-stdout-pipe
- fill-stdin-pipe
+ dup make-CreateProcess-args
- fill-redirection
+ fill-stdout-pipe
+ fill-stdin-pipe
- dup call-CreateProcess
+ tuck fill-redirection
- dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
- dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
+ dup call-CreateProcess
- dup CreateProcess-args-stdout-pipe pipe-in
- over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
+ dup stdin-pipe>> pipe-in CloseHandle drop
+ dup stdout-pipe>> pipe-out CloseHandle drop
- swap CreateProcess-args-lpProcessInformation <process>
- ] with-destructors
- ] with-descriptor ;
+ dup lpProcessInformation>>
+ over stdout-pipe>> in>> f <win32-file>
+ rot stdin-pipe>> out>> f <win32-file>
+ ] with-destructors ;
--- /dev/null
+USE: system\r
+USE: prettyprint\r
+os-envs .\r
--- /dev/null
+USE: io\r
+USE: namespaces\r
+\r
+"output" write flush\r
+"error" stderr get stream-write stderr get stream-flush\r
windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays
-combinators ;
+combinators math.bitfields strings ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
share-mode
f
OPEN_EXISTING
- FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor
+ { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
f
CreateFile
dup invalid-handle?
{ [ t ] [ +modify-file+ ] }
} cond nip ;
+: memory>u16-string ( alien len -- string )
+ [ memory>byte-array ] keep 2/ c-ushort-array> >string ;
+
: parse-file-notify ( buffer -- changed path )
{
FILE_NOTIFY_INFORMATION-FileName
USING: io.files kernel tools.test io.backend
io.windows.nt.files splitting ;
-IN: temporary
+IN: io.windows.nt.tests
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
USE: io.windows.nt.monitors
USE: io.windows.nt.sockets
USE: io.windows.mmap
+USE: io.windows.files
USE: io.backend
T{ windows-nt-io } set-io-backend
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random
-combinators ;
+combinators new-slots accessors ;
IN: io.windows.nt.pipes
! This code is based on
: close-pipe ( pipe -- )
dup
- pipe-in CloseHandle drop
- pipe-out CloseHandle drop ;
+ in>> CloseHandle drop
+ out>> CloseHandle drop ;
: <incoming-pipe> ( name -- pipe )
PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
! /dev/null simulation
: null-input ( -- pipe )
<unique-outgoing-pipe>
- dup pipe-out CloseHandle drop
- pipe-in ;
+ dup out>> CloseHandle drop
+ in>> ;
: null-output ( -- pipe )
<unique-incoming-pipe>
- dup pipe-in CloseHandle drop
- pipe-out ;
+ dup in>> CloseHandle drop
+ out>> ;
: null-pipe ( mode -- pipe )
{
"stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ;
-: connect-continuation ( ConnectEx -- )
- dup ConnectEx-args-lpOverlapped*
- swap ConnectEx-args-port duplex-stream-in
- [ save-callback ] 2keep
+: connect-continuation ( ConnectEx port -- )
+ >r ConnectEx-args-lpOverlapped* r>
+ 2dup save-callback
get-overlapped-result drop ;
-M: windows-nt-io (client) ( addrspec -- duplex-stream )
+M: windows-nt-io (client) ( addrspec -- client-in client-out )
[
\ ConnectEx-args construct-empty
over make-sockaddr/size pick init-connect
dup ConnectEx-args-s* INADDR_ANY roll bind-socket
dup (ConnectEx)
- dup ConnectEx-args-s* <win32-socket> dup handle>duplex-stream
- over set-ConnectEx-args-port
-
- dup connect-continuation
- ConnectEx-args-port
- [ duplex-stream-in pending-error ] keep
- [ duplex-stream-out pending-error ] keep
+ dup ConnectEx-args-s* <win32-socket> dup <reader&writer>
+ >r [ connect-continuation ] keep [ pending-error ] keep r>
] with-destructors ;
TUPLE: AcceptEx-args port
f over set-AcceptEx-args-lpdwBytesReceived*
(make-overlapped) swap set-AcceptEx-args-lpOverlapped* ;
-: (accept) ( AcceptEx -- )
+: ((accept)) ( AcceptEx -- )
\ AcceptEx-args >tuple*<
AcceptEx drop
winsock-error-string [ throw ] when* ;
] keep *void*
] keep AcceptEx-args-port server-port-addr parse-sockaddr ;
-: accept-continuation ( AcceptEx -- client )
+: accept-continuation ( AcceptEx -- addrspec client )
[ make-accept-continuation ] keep
[ check-accept-error ] keep
[ extract-remote-host ] keep
! addrspec AcceptEx
- [
- AcceptEx-args-sAcceptSocket* add-completion
- ] keep
- AcceptEx-args-sAcceptSocket* <win32-socket> dup handle>duplex-stream
- <client-stream> ;
+ [ AcceptEx-args-sAcceptSocket* add-completion ] keep
+ AcceptEx-args-sAcceptSocket* <win32-socket> ;
-M: windows-nt-io accept ( server -- client )
+M: windows-nt-io (accept) ( server -- addrspec handle )
[
[
dup check-server-port
\ AcceptEx-args construct-empty
[ init-accept ] keep
- [ (accept) ] keep
+ [ ((accept)) ] keep
[ accept-continuation ] keep
AcceptEx-args-port pending-error
- dup duplex-stream-in pending-error
- dup duplex-stream-out pending-error
] with-timeout
] with-destructors ;
-M: windows-nt-io <server> ( addrspec -- server )
+M: windows-nt-io (server) ( addrspec -- handle )
[
- [
- SOCK_STREAM server-fd dup listen-on-socket
- dup add-completion
- <win32-socket>
- ] keep <server-port>
+ SOCK_STREAM server-fd dup listen-on-socket
+ dup add-completion
+ <win32-socket>
] with-destructors ;
M: windows-nt-io <datagram> ( addrspec -- datagram )
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
-io.sockets.impl windows.errors strings io.streams.duplex kernel
-math namespaces sequences windows windows.kernel32
+io.sockets.impl windows.errors strings io.streams.duplex
+kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields ;
IN: io.windows
C: <win32-file> win32-file
-: <win32-duplex-stream> ( in out -- stream )
- >r f <win32-file> r> f <win32-file> handle>duplex-stream ;
-
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
M: windows-io normalize-directory ( string -- string )
- "\\" ?tail drop "\\*" append ;
+ normalize-pathname "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
{
: open-file ( path access-mode create-mode flags -- handle )
[
>r >r >r normalize-pathname r>
- share-mode f r> r> CreateFile-flags f CreateFile
+ share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
[ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ;
-M: windows-io <file-reader> ( path -- stream )
+M: windows-io (file-reader) ( path -- stream )
open-read <win32-file> <reader> ;
-M: windows-io <file-writer> ( path -- stream )
+M: windows-io (file-writer) ( path -- stream )
open-write <win32-file> <writer> ;
-M: windows-io <file-appender> ( path -- stream )
+M: windows-io (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
-M: windows-io rename-file ( from to -- )
+M: windows-io move-file ( from to -- )
[ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar io io.sockets kernel match namespaces
-sequences splitting strings continuations threads ascii ;
+sequences splitting strings continuations threads ascii
+io.encodings.utf8 ;
IN: irc
! "setup" objects
" hostname servername :irc.factor" irc-print ;
: connect* ( server port -- )
- <inet> <client> irc-client get set-irc-client-stream ;
+ <inet> utf8 <client> irc-client get set-irc-client-stream ;
: connect ( server -- ) 6667 connect* ;
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ;
IN: jamshred.game
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types colors jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.vectors opengl
opengl.gl opengl.glu sequences ;
-USING: arrays jamshred.game jamshred.gl kernel math math.constants
-namespaces sequences timers ui ui.gadgets ui.gestures ui.render
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
+math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
math.vectors ;
IN: jamshred
-TUPLE: jamshred-gadget jamshred last-hand-loc ;
+TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
: <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
-M: jamshred-gadget tick ( gadget -- )
+: tick ( gadget -- )
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
M: jamshred-gadget graft* ( gadget -- )
- 10 1 add-timer ;
+ [
+ [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
+ ] keep set-jamshred-gadget-alarm ;
-M: jamshred-gadget ungraft* ( gadget -- ) remove-timer ;
+M: jamshred-gadget ungraft* ( gadget -- )
+ [ jamshred-gadget-alarm cancel-alarm f ] keep
+ set-jamshred-gadget-alarm ;
: jamshred-restart ( jamshred-gadget -- )
<jamshred> swap set-jamshred-gadget-jamshred ;
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
IN: jamshred.oint
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
IN: jamshred.player
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
-IN: temporary
+IN: jamshred.tunnel.tests
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
T{ segment T{ oint f { 1 1 1 } } 1 }
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays float-arrays kernel jamshred.oint math math.functions
math.ranges math.vectors math.constants random sequences vectors ;
IN: jamshred.tunnel
-USING: koszul tools.test kernel sequences assocs namespaces ;
-IN: temporary
+USING: koszul tools.test kernel sequences assocs namespaces
+symbols ;
+IN: koszul.tests
[
{ V{ { } } V{ { 1 } } V{ { 2 3 } { 7 8 } } V{ { 4 5 6 } } }
USING: arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle ;
+splitting sorting shuffle symbols ;
IN: koszul
! Utilities
-: SYMBOLS:
- ";" parse-tokens [ create-in define-symbol ] each ;
- parsing
-
: -1^ odd? -1 1 ? ;
: >alt ( obj -- vec )
USING: lazy-lists.examples lazy-lists tools.test ;
-IN: temporary
+IN: lazy-lists.examples.tests
[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
{ $values { "cons" "a cons object" } { "?" "a boolean" } }
{ $description "Return true if the cons object is the nil cons." } ;
-HELP: list?
+HELP: list? ( object -- ? )
{ $values { "object" "an object" } { "?" "a boolean" } }
{ $description "Returns true if the object conforms to the list protocol." } ;
{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
{ $description "Return the result of merging the two lists in a lazy manner." }
{ $examples
- { $example "USE: lazy-lists" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+ { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
} ;
HELP: lcontents
! See http://factorcode.org/license.txt for BSD license.
!
USING: lazy-lists tools.test kernel math io sequences ;
-IN: temporary
+IN: lazy-lists.tests
[ { 1 2 3 4 } ] [
{ 1 2 3 4 } >list list>array
[ { 5 6 7 8 } ] [
{ 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
] unit-test
+
+[ { 4 5 6 } ] [
+ 3 { 1 2 3 } >list [ + ] lmap-with list>array
+] unit-test
M: lazy-map nil? ( lazy-map -- bool )
lazy-map-cons nil? ;
-TUPLE: lazy-map-with value cons quot ;
-
-C: <lazy-map-with> lazy-map-with
-
: lmap-with ( value list quot -- result )
- over nil? [ 3drop nil ] [ <lazy-map-with> <memoized-cons> ] if ;
-
-M: lazy-map-with car ( lazy-map-with -- car )
- [ lazy-map-with-value ] keep
- [ lazy-map-with-cons car ] keep
- lazy-map-with-quot call ;
-
-M: lazy-map-with cdr ( lazy-map-with -- cdr )
- [ lazy-map-with-value ] keep
- [ lazy-map-with-cons cdr ] keep
- lazy-map-with-quot lmap-with ;
-
-M: lazy-map-with nil? ( lazy-map-with -- bool )
- lazy-map-with-cons nil? ;
+ with lmap ;
TUPLE: lazy-take n cons ;
INSTANCE: lazy-concat list
INSTANCE: lazy-cons list
INSTANCE: lazy-map list
-INSTANCE: lazy-map-with list
INSTANCE: lazy-take list
INSTANCE: lazy-append list
INSTANCE: lazy-from-by list
-USING: sequences kernel math io ;
+USING: sequences kernel math io calendar calendar.format
+calendar.model arrays models namespaces ui.gadgets
+ui.gadgets.labels
+ui.gadgets.theme ui ;
IN: lcd
: lcd-digit ( row digit -- str )
" _ _ _ _ _ _ _ _ "
" | | | _| _| |_| |_ |_ | |_| |_| * "
" |_| | |_ _| | _| |_| | |_| | * "
+ " "
} nth >r 4 * dup 4 + r> subseq ;
: lcd-row ( num row -- string )
[ swap lcd-digit ] curry { } map-as concat ;
: lcd ( digit-str -- string )
- 3 [ lcd-row ] with map "\n" join ;
+ 4 [ lcd-row ] with map "\n" join ;
-: lcd-demo ( -- ) "31337" lcd print ;
+: hh:mm:ss ( timestamp -- string )
+ {
+ timestamp-hour timestamp-minute timestamp-second
+ } get-slots >fixnum 3array [ pad-00 ] map ":" join ;
-MAIN: lcd-demo
+: <time-display> ( timestamp -- gadget )
+ [ hh:mm:ss lcd ] <filter> <label-control>
+ "99:99:99" lcd over set-label-string
+ monospace-font over set-label-font ;
+
+: time-window ( -- )
+ [ time get <time-display> "Time" open-window ] with-ui ;
+
+MAIN: time-window
-7-segment numeric display demo
+7-segment LCD clock demo
-USING: alien alien.c-types io kernel ldap ldap.libldap namespaces prettyprint
-tools.test ;
+USING: alien alien.c-types io kernel ldap ldap.libldap
+namespaces prettyprint tools.test ;
+IN: ldap.tests
"void*" <c-object> "ldap://localhost:389" initialize
get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 <int> set-option
-[ B{ 0 0 0 3 } ] [
+[ 3 ] [
get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
+ *int
] unit-test
-get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
+[
+ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
- ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
- ! "void*" <c-object> [ search-s ] keep *int .
+ ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
+ ! "void*" <c-object> [ search-s ] keep *int .
- [ 2 ] [
- get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0
- search
- ] unit-test
+ [ 2 ] [
+ get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0
+ search
+ ] unit-test
- ! get-ldp LDAP_RES_ANY 0 f "void*" <c-object> result .
+ ! get-ldp LDAP_RES_ANY 0 f "void*" <c-object> result .
- get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" <c-object> result
+ get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" <c-object> result
- ! get-message *int .
+ ! get-message *int .
- "Message ID: " write
+ "Message ID: " write
- get-message msgid .
+ get-message msgid .
- get-ldp get-message get-dn .
+ get-ldp get-message get-dn .
- "Entries count: " write
+ "Entries count: " write
- get-ldp get-message count-entries .
+ get-ldp get-message count-entries .
- SYMBOL: entry
- SYMBOL: attr
+ SYMBOL: entry
+ SYMBOL: attr
- "Attribute: " write
+ "Attribute: " write
- get-ldp get-message first-entry entry set get-ldp entry get
- "void*" <c-object> first-attribute dup . attr set
+ get-ldp get-message first-entry entry set get-ldp entry get
+ "void*" <c-object> first-attribute dup . attr set
- "Value: " write
+ "Value: " write
- get-ldp entry get attr get get-values *char* .
+ get-ldp entry get attr get get-values *char* .
- get-ldp get-message first-message msgtype result-type
+ get-ldp get-message first-message msgtype result-type
- get-ldp get-message next-message msgtype result-type
+ get-ldp get-message next-message msgtype result-type
-] with-bind
+ ] with-bind
+] drop
IN: ldap.libldap
-"libldap" {
+<< "libldap" {
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
-} cond add-library
+} cond add-library >>
: LDAP_VERSION1 1 ; inline
: LDAP_VERSION2 2 ; inline
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: temporary
+IN: levenshtein.tests
USING: tools.test levenshtein ;
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
USING: io lint kernel math tools.test ;
-IN: temporary
+IN: lint.tests
! Don't write code like this
: lint1
{ $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." }
{ $examples
{ $example
- "USE: locals"
- ":: adder | n | [| m | m n + ] ;"
+ "USING: kernel locals math prettyprint ;"
+ ":: adder ( n -- quot ) [| m | m n + ] ;"
"3 5 adder call ."
"8"
}
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
{ $examples
{ $example
- "USING: locals math.functions ;"
- ":: frobnicate | n seq |"
+ "USING: kernel locals math math.functions prettyprint sequences ;"
+ ":: frobnicate ( n seq -- newseq )"
" [let | n' [ n 6 * ] |"
" seq [ n' gcd nip ] map ] ;"
"6 { 36 14 } frobnicate ."
{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." }
{ $examples
{ $example
- "USE: locals"
- ":: quuxify | n seq |"
+ "USING: locals math prettyprint sequences ;"
+ ":: quuxify ( n seq -- newseq )"
" [wlet | add-n [| m | m n + ] |"
" seq [ add-n ] map ] ;"
"2 { 1 2 3 } quuxify ."
{ $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ;
HELP: ::
-{ $syntax ":: word | bindings... | body... ;" }
+{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
{ $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
HELP: MACRO::
-{ $syntax "MACRO:: word | bindings... | body... ;" }
-{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ;
+{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
+{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
$nl
"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
{ $code
- ":: counter | |"
+ ":: counter ( -- )"
" [let | value! [ 0 ] |"
" [ value 1+ dup value! ]"
" [ value 1- dup value! ] ] ;"
$nl
"Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
{ $code
- ":: bad-cond-usage | a |"
+ ":: bad-cond-usage ( a -- ... )"
" { [ a 0 < ] [ ... ] }"
" { [ a 0 > ] [ ... ] }"
" { [ a 0 = ] [ ... ] } ;"
USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays ;
-IN: temporary
+namespaces arrays strings prettyprint ;
+IN: locals.tests
-:: foo | a b | a a ;
+:: foo ( a b -- a a ) a a ;
[ 1 1 ] [ 1 2 foo ] unit-test
-:: add-test | a b | a b + ;
+:: add-test ( a b -- c ) a b + ;
[ 3 ] [ 1 2 add-test ] unit-test
-:: sub-test | a b | a b - ;
+:: sub-test ( a b -- c ) a b - ;
[ -1 ] [ 1 2 sub-test ] unit-test
-:: map-test | a b | a [ b + ] map ;
+:: map-test ( a b -- seq ) a [ b + ] map ;
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
-:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ;
+:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
-:: let-test | c |
+:: let-test ( c -- d )
[let | a [ 1 ] b [ 2 ] | a b + c + ] ;
[ 7 ] [ 4 let-test ] unit-test
-:: let-test-2 | |
- [let | a [ ] | [let | b [ a ] | a ] ] ;
+:: let-test-2 ( a -- a )
+ a [let | a [ ] | [let | b [ a ] | a ] ] ;
[ 3 ] [ 3 let-test-2 ] unit-test
-:: let-test-3 | |
- [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
+:: let-test-3 ( a -- a )
+ a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
-:: let-test-4 | |
- [let | a [ 1 ] b [ ] | a b 2array ] ;
+:: let-test-4 ( a -- b )
+ a [let | a [ 1 ] b [ ] | a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
-:: let-test-5 | |
- [let | a [ ] b [ ] | a b 2array ] ;
+:: let-test-5 ( a -- b )
+ a [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
-:: let-test-6 | |
- [let | a [ ] b [ 1 ] | a b 2array ] ;
+:: let-test-6 ( a -- b )
+ a [let | a [ ] b [ 1 ] | a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
with-locals
] unit-test
-:: wlet-test-2 | a b |
+:: wlet-test-2 ( a b -- seq )
[wlet | add-b [ b + ] |
a [ add-b ] map ] ;
[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
-:: wlet-test-3 | a |
+:: wlet-test-3 ( a -- b )
[wlet | add-a [ a + ] | [ add-a ] ]
[let | a [ 3 ] | a swap call ] ;
[ 5 ] [ 2 wlet-test-3 ] unit-test
-:: wlet-test-4 | a |
+:: wlet-test-4 ( a -- b )
[wlet | sub-a [| b | b a - ] |
3 sub-a ] ;
[ -7 ] [ 10 wlet-test-4 ] unit-test
-:: write-test-1 | n! |
+:: write-test-1 ( n! -- q )
[| i | n i + dup n! ] ;
0 write-test-1 "q" set
[ 5 ] [ 2 "q" get call ] unit-test
-:: write-test-2 | |
+:: write-test-2 ( -- q )
[let | n! [ 0 ] |
[| i | n i + dup n! ] ] ;
20 10 [| a! | [| b! | a b ] ] with-locals call call
] unit-test
-:: write-test-3 | a! | [| b | b a! ] ;
+:: write-test-3 ( a! -- q ) [| b | b a! ] ;
[ ] [ 1 2 write-test-3 call ] unit-test
-:: write-test-4 | x! | [ [let | y! [ 0 ] | f x! ] ] ;
+:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
[ ] [ 5 write-test-4 drop ] unit-test
+! Not really a write test; just enforcing consistency
+:: write-test-5 ( x -- y )
+ [wlet | fun! [ x + ] | 5 fun! ] ;
+
+[ 9 ] [ 4 write-test-5 ] unit-test
+
SYMBOL: a
-:: use-test | a b c |
+:: use-test ( a b c -- a b c )
USE: kernel ;
[ t ] [ a symbol? ] unit-test
+
+:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
+
+[ 13 ] [ 10 let-let-test ] unit-test
+
+GENERIC: lambda-generic ( a b -- c )
+
+GENERIC# lambda-generic-1 1 ( a b -- c )
+
+M:: integer lambda-generic-1 ( a b -- c ) a b * ;
+
+M:: string lambda-generic-1 ( a b -- c )
+ a b CHAR: x <string> lambda-generic ;
+
+M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
+
+GENERIC# lambda-generic-2 1 ( a b -- c )
+
+M:: integer lambda-generic-2 ( a b -- c )
+ a CHAR: x <string> b lambda-generic ;
+
+M:: string lambda-generic-2 ( a b -- c ) a b append ;
+
+M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
+
+[ 10 ] [ 5 2 lambda-generic ] unit-test
+
+[ "abab" ] [ "aba" "b" lambda-generic ] unit-test
+
+[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
+
+[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
+
+[ ] [ \ lambda-generic-1 see ] unit-test
+
+[ ] [ \ lambda-generic-2 see ] unit-test
+
+[ ] [ \ lambda-generic see ] unit-test
+
+[ "[let | a! [ ] | ]" ] [
+ [let | a! [ ] | ] unparse
+] unit-test
+
+[ "[wlet | a! [ ] | ]" ] [
+ [wlet | a! [ ] | ] unparse
+] unit-test
+
+[ "[| a! | ]" ] [
+ [| a! | ] unparse
+] unit-test
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private ;
+prettyprint.sections sequences.private effects generic
+compiler.units ;
IN: locals
! Inspired by
: push-locals ( assoc -- )
use get push ;
-: parse-locals ( -- words assoc )
- "|" parse-tokens make-locals ;
-
: pop-locals ( assoc -- )
use get delete ;
over push-locals parse-until >quotation swap pop-locals ;
: parse-lambda ( -- lambda )
- parse-locals \ ] (parse-lambda) <lambda> ;
+ "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
: (parse-bindings) ( -- )
scan dup "|" = [
dup wlet-bindings values over wlet-vars rot wlet-body
<lambda> [ call ] curry compose local-rewrite* \ call , ;
-: (::) ( prop -- word quot n )
- >r CREATE dup reset-generic
- scan "|" assert= parse-locals \ ; (parse-lambda) <lambda>
- 2dup r> set-word-prop
- [ lambda-rewrite first ] keep lambda-vars length ;
+: parse-locals
+ parse-effect
+ word [ over "declared-effect" set-word-prop ] when*
+ effect-in make-locals ;
+
+: ((::)) ( word -- word quot )
+ scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
+ 2dup "lambda" set-word-prop
+ lambda-rewrite first ;
+
+: (::) ( -- word quot )
+ CREATE dup reset-generic ((::)) ;
PRIVATE>
MACRO: with-locals ( form -- quot ) lambda-rewrite ;
-: :: "lambda" (::) drop define ; parsing
+: :: (::) define ; parsing
+
+! This will be cleaned up when method tuples and method words
+! are unified
+: create-method ( class generic -- method )
+ 2dup method dup
+ [ 2nip ]
+ [ drop 2dup [ ] -rot define-method create-method ] if ;
-: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing
+: CREATE-METHOD ( -- class generic body )
+ scan-word bootstrap-word scan-word 2dup
+ create-method f set-word dup save-location ;
+
+: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
+
+: MACRO:: (::) define-macro ; parsing
<PRIVATE
\ | pprint-word
t <inset
<block
- values [ <block >r pprint-word r> pprint* block> ] 2each
+ values [ <block >r pprint-var r> pprint* block> ] 2each
block>
\ | pprint-word
<block pprint-elements block>
\ ] pprint-word ;
M: wlet pprint*
- \ [let pprint-word
+ \ [wlet pprint-word
{ wlet-body wlet-vars wlet-bindings } get-slots pprint-let
\ ] pprint-word ;
M: lambda-word definition
"lambda" word-prop lambda-body ;
-: lambda-word-synopsis ( word prop -- )
- over definer.
- over seeing-word
- over pprint-word
- \ | pprint-word
- word-prop lambda-vars pprint-vars
- \ | pprint-word ;
+: lambda-word-synopsis ( word -- )
+ dup definer.
+ dup seeing-word
+ dup pprint-word
+ stack-effect. ;
-M: lambda-word synopsis*
- "lambda" lambda-word-synopsis ;
+M: lambda-word synopsis* lambda-word-synopsis ;
PREDICATE: macro lambda-macro
- "lambda-macro" word-prop >boolean ;
+ "lambda" word-prop >boolean ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
- "lambda-macro" word-prop lambda-body ;
+ "lambda" word-prop lambda-body ;
+
+M: lambda-macro synopsis* lambda-word-synopsis ;
+
+PREDICATE: method-body lambda-method
+ "lambda" word-prop >boolean ;
+
+M: lambda-method definer drop \ M:: \ ; ;
+
+M: lambda-method definition
+ "lambda" word-prop lambda-body ;
-M: lambda-macro synopsis*
- "lambda-macro" lambda-word-synopsis ;
+: method-stack-effect ( method -- effect )
+ dup "lambda" word-prop lambda-vars
+ swap "method-generic" word-prop stack-effect
+ dup [ effect-out ] when
+ <effect> ;
+
+M: lambda-method synopsis*
+ dup dup dup definer.
+ "method-specializer" word-prop pprint*
+ "method-generic" word-prop pprint*
+ method-stack-effect effect>string comment. ;
PRIVATE>
-USING: kernel io io.files io.monitors ;\r
+USING: kernel io io.files io.monitors io.encodings.utf8 ;\r
IN: log-viewer\r
\r
: read-lines ( stream -- )\r
dup next-change 2drop over read-lines tail-file-loop ;\r
\r
: tail-file ( file -- )\r
- dup <file-reader> dup read-lines\r
+ dup utf8 <file-reader> dup read-lines\r
swap parent-directory f <monitor>\r
tail-file-loop ;\r
{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ;
HELP: analyze-log
-{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } }
+{ $values { "lines" "a parsed log file" } { "word-names" "a sequence of strings" } }
{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
ARTICLE: "logging.analysis" "Log analysis"
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel sequences namespaces words assocs logging sorting\r
-prettyprint io io.styles strings logging.parser ;\r
+prettyprint io io.styles strings logging.parser calendar.format ;\r
IN: logging.analysis\r
\r
SYMBOL: word-names\r
] tabular-output ;\r
\r
: log-entry.\r
- [\r
- dup first [ write ] with-cell\r
- dup second [ pprint ] with-cell\r
- dup third [ write ] with-cell\r
- fourth "\n" join [ write ] with-cell\r
- ] with-row ;\r
+ "====== " write\r
+ dup first (timestamp>string) bl\r
+ dup second pprint bl\r
+ dup third write nl\r
+ fourth "\n" join print ;\r
\r
: errors. ( errors -- )\r
- standard-table-style\r
- [ [ log-entry. ] each ] tabular-output ;\r
+ [ log-entry. ] each ;\r
\r
: analysis. ( errors word-histogram message-histogram -- )\r
"==== INTERESTING MESSAGES:" print nl\r
logging.analysis smtp ;
IN: logging.insomniac
-HELP: insomniac-smtp-host
-{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ;
-
-HELP: insomniac-smtp-port
-{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ;
-
HELP: insomniac-sender
{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ;
HELP: ?analyze-log
-{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } }
+{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string/f" string } }
{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." }
{ $see-also analyze-log } ;
HELP: email-log-report
{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
-{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
+{ $description "E-mails a log report for the given log service. The " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ;
HELP: schedule-insomniac
-{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
+{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } }
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
-ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
+ARTICLE: "logging.insomniac" "Automated log analysis"
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
$nl
"Required configuration parameters:"
{ $subsection insomniac-sender }
{ $subsection insomniac-recipients }
-"Optional configuration parameters:"
-{ $subsection insomniac-smtp-host }
-{ $subsection insomniac-smtp-port }
"E-mailing a one-off report:"
{ $subsection email-log-report }
"E-mailing reports and rotating logs on a daily basis:"
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: logging.analysis logging.server logging smtp io.sockets\r
-kernel io.files io.streams.string namespaces raptor.cron assocs ;\r
+USING: logging.analysis logging.server logging smtp kernel\r
+io.files io.streams.string namespaces alarms assocs\r
+io.encodings.utf8 accessors calendar qualified ;\r
+QUALIFIED: io.sockets\r
IN: logging.insomniac\r
\r
-SYMBOL: insomniac-smtp-host\r
-SYMBOL: insomniac-smtp-port\r
SYMBOL: insomniac-sender\r
SYMBOL: insomniac-recipients\r
\r
: ?analyze-log ( service word-names -- string/f )\r
>r log-path 1 log# dup exists? [\r
- file-lines r> [ analyze-log ] with-string-writer\r
+ utf8 file-lines r> [ analyze-log ] with-string-writer\r
] [\r
r> 2drop f\r
] if ;\r
\r
-: with-insomniac-smtp ( quot -- )\r
- [\r
- insomniac-smtp-host get [ smtp-host set ] when*\r
- insomniac-smtp-port get [ smtp-port set ] when*\r
- call\r
- ] with-scope ; inline\r
-\r
: email-subject ( service -- string )\r
- [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ;\r
+ [\r
+ "[INSOMNIAC] " % % " on " % io.sockets:host-name %\r
+ ] "" make ;\r
\r
: (email-log-report) ( service word-names -- )\r
- [\r
- over >r\r
- ?analyze-log dup [\r
- r> email-subject\r
- insomniac-recipients get\r
- insomniac-sender get\r
- send-simple-message\r
- ] [ r> 2drop ] if\r
- ] with-insomniac-smtp ;\r
+ dupd ?analyze-log dup [\r
+ <email>\r
+ swap >>body\r
+ insomniac-recipients get >>to\r
+ insomniac-sender get >>from\r
+ swap email-subject >>subject\r
+ send-email\r
+ ] [ 2drop ] if ;\r
\r
\ (email-log-report) NOTICE add-error-logging\r
\r
"logging.insomniac" [ (email-log-report) ] with-logging ;\r
\r
: schedule-insomniac ( service word-names -- )\r
- { 25 } { 6 } f f f <when> -rot [\r
- [ email-log-report ] assoc-each rotate-logs\r
- ] 2curry schedule ;\r
+ [ [ email-log-report ] assoc-each rotate-logs ] 2curry\r
+ 1 days every drop ;\r
{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging
-{ $values { "word" word } }
+{ $values { "level" "a log level" } { "word" word } }
{ $description "Causes the word to log a message every time it is called." } ;
HELP: add-input-logging
-{ $values { "word" word } }
+{ $values { "level" "a log level" } { "word" word } }
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-output-logging
-{ $values { "word" word } }
+{ $values { "level" "a log level" } { "word" word } }
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-error-logging
-{ $values { "word" word } }
+{ $values { "level" "a log level" } { "word" word } }
{ $description "Causes the word to log its input values and any errors it throws."
$nl
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
{ $description "Logs an error." } ;
HELP: log-critical
-{ $values { "critical" "an critical" } { "word" word } }
+{ $values { "error" "an error" } { "word" word } }
{ $description "Logs a critical error." } ;
HELP: LOG:
"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ;
ARTICLE: "logging.server" "Log implementation"
-"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
+"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead it uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion."
$nl
"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:"
{ $subsection (log-message) }
{ $subsection "logging.levels" }
{ $subsection "logging.messages" }
{ $subsection "logging.rotation" }
-{ $subsection "logging.parser" }
-{ $subsection "logging.analysis" }
-{ $subsection "logging.insomniac" }
+{ $vocab-subsection "Log file parser" "logging.parser" }
+{ $vocab-subsection "Log analysis" "logging.analysis" }
+{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
{ $subsection "logging.server" } ;
ABOUT: "logging"
{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where"
{ $list
{ { $snippet "timestamp" } " is a " { $link timestamp } }
- { { $snippet "level" } " is a log level; see " { $link "logger.levels" } }
+ { { $snippet "level" } " is a log level; see " { $link "logging.levels" } }
{ { $snippet "word-name" } " is a string" }
{ { $snippet "message" } " is a string" }
}
USING: parser-combinators memoize kernel sequences\r
logging arrays words strings vectors io io.files\r
namespaces combinators combinators.lib logging.server\r
-calendar ;\r
+calendar calendar.format ;\r
IN: logging.parser\r
\r
: string-of satisfy <!*> [ >string ] <@ ;\r
USING: namespaces kernel io calendar sequences io.files\r
io.sockets continuations prettyprint assocs math.parser\r
words debugger math combinators concurrency.messaging\r
-threads arrays init math.ranges strings ;\r
+threads arrays init math.ranges strings calendar.format
+io.encodings.ascii ;\r
IN: logging.server\r
\r
: log-root ( -- string )\r
: open-log-stream ( service -- stream )\r
log-path\r
dup make-directories\r
- 1 log# <file-appender> ;\r
+ 1 log# ascii <file-appender> ;\r
\r
: log-stream ( service -- stream )\r
log-files get [ open-log-stream ] cache ;\r
\r
: delete-oldest keep-logs log# ?delete-file ;\r
\r
-: ?rename-file ( old new -- )\r
- over exists? [ rename-file ] [ 2drop ] if ;\r
+: ?move-file ( old new -- )\r
+ over exists? [ move-file ] [ 2drop ] if ;\r
\r
: advance-log ( path n -- )\r
- [ 1- log# ] 2keep log# ?rename-file ;\r
+ [ 1- log# ] 2keep log# ?move-file ;\r
\r
: rotate-log ( service -- )\r
dup close-log\r
-IN: temporary
+IN: macros.tests
USING: tools.test macros math kernel arrays
vectors ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-
-USING: parser kernel sequences words effects inference.transforms
-combinators assocs definitions quotations namespaces memoize ;
-
+USING: parser kernel sequences words effects
+inference.transforms combinators assocs definitions quotations
+namespaces memoize ;
IN: macros
-: (:) ( -- word definition effect-in )
- CREATE dup reset-generic parse-definition
- over "declared-effect" word-prop effect-in length ;
-
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop effect-in 1 <effect> ;
-: (MACRO:) ( word definition effect-in -- )
- >r 2dup "macro" set-word-prop
- 2dup over real-macro-effect memoize-quot
- [ call ] append define
+: define-macro ( word definition -- )
+ over "declared-effect" word-prop effect-in length >r
+ 2dup "macro" set-word-prop
+ 2dup over real-macro-effect memoize-quot [ call ] append define
r> define-transform ;
: MACRO:
- (:) (MACRO:) ; parsing
+ (:) define-macro ; parsing
PREDICATE: word macro "macro" word-prop >boolean ;
{ $description "Matches the " { $snippet "object" } " against " { $snippet "pattern1" } ". The pattern match variables in " { $snippet "pattern1" } " are assigned the values from the matching " { $snippet "object" } ". These are then replaced into the " { $snippet "pattern2" } " pattern match variables." }
{ $examples
{ $example
- "USE: match"
+ "USING: match prettyprint ;"
"MATCH-VARS: ?a ?b ;"
"{ 1 2 } { ?a ?b } { ?b ?a } match-replace ."
"{ 2 1 }"
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test match namespaces arrays ;
-IN: temporary
+IN: match.tests
MATCH-VARS: ?a ?b ;
USING: kernel math math.functions tools.test math.analysis
math.constants ;
-IN: temporary
+IN: math.analysis.tests
: eps
.00000001 ;
HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
-{ $examples { $example "4 factorial ." "24" } } ;
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
-{ $examples { $example "10 4 nPk ." "5040" } } ;
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
-{ $examples { $example "10 4 nCk ." "210" } } ;
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
-{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ;
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
-{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
-{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
+{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
IN: math.combinatorics.private
HELP: factoradic
-{ $values { "n" integer } { "seq" sequence } }
+{ $values { "n" integer } { "factoradic" sequence } }
{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." }
-{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ;
+{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ;
HELP: >permutation
{ $values { "factoradic" sequence } { "permutation" sequence } }
{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." }
{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
-{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
+{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
USING: math.combinatorics math.combinatorics.private tools.test ;
-IN: temporary
+IN: math.combinatorics.tests
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
USING: kernel math math.constants math.functions tools.test
prettyprint ;
-IN: temporary
+IN: math.complex.tests
[ 1 C{ 0 1 } rect> ] must-fail
[ C{ 0 1 } 1 rect> ] must-fail
-USING: help.markup help.syntax kernel layouts ;
+USING: help.markup help.syntax kernel ;
IN: math.constants
ARTICLE: "math-constants" "Constants"
{ $subsection euler }
{ $subsection phi }
{ $subsection pi }
-"Various limits:"
-{ $subsection most-positive-fixnum }
-{ $subsection most-negative-fixnum }
{ $subsection epsilon } ;
ABOUT: "math-constants"
HELP: lerato
{ $values { "n" "a positive number" } { "lazy-list" "a lazy prime numbers generator" } }
-{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive). Lazy lists are described in " { $link "lazy-lists" } "." } ;
+{ $description "Builds a lazy list containing the prime numbers between 2 and " { $snippet "n" } " (inclusive)." } ;
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists math.erato tools.test ;
-IN: temporary
+IN: math.erato.tests
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
{ $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
{ $errors "Throws an error if " { $snippet "n" } " is not invertible modulo " { $snippet "n" } "." }
{ $examples
- { $example "USE: math.functions" "173 1119 mod-inv ." "815" }
- { $example "USE: math.functions" "173 815 * 1119 mod ." "1" }
+ { $example "USING: math.functions prettyprint ;" "173 1119 mod-inv ." "815" }
+ { $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" }
} ;
HELP: each-bit
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } }
{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
{ $examples
- { $example "USE: math.functions" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
- { $example "USE: math.functions" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
+ { $example "USING: math.functions namespaces prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
+ { $example "USING: math.functions namespaces prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
} ;
HELP: ~
USING: kernel math math.constants math.functions math.private
math.libm tools.test ;
-IN: temporary
+IN: math.functions.tests
[ t ] [ 4 4 .00000001 ~ ] unit-test
[ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
+: unmask ( x n -- ? ) bitnot bitand ; foldable
+: unmask? ( x n -- ? ) unmask 0 > ; foldable
+: mask ( x n -- ? ) bitand ; foldable
+: mask? ( x n -- ? ) mask 0 > ; foldable
GENERIC: (^) ( x y -- z ) foldable
-IN: temporary
+IN: math.matrices.elimination.tests
USING: kernel math.matrices math.matrices.elimination
tools.test sequences ;
-IN: temporary
+IN: math.matrices.tests
USING: math.matrices math.vectors tools.test math ;
[
USING: math.miller-rabin tools.test ;
-IN: temporary
+IN: math.miller-rabin.tests
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
[ t ] [ 2 miller-rabin ] unit-test
#! factor an integer into s * 2^r
0 swap (factor-2s) ;
-:: (miller-rabin) | n prime?! |
+:: (miller-rabin) ( n prime?! -- ? )
n 1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
USING: kernel math.numerical-integration tools.test math
math.constants math.functions ;
-IN: temporary
+IN: math.numerical-integration.tests
[ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test
[ 1000/3 ] [ 0 10 [ sq ] integrate-simpson ] unit-test
-IN: temporary
+IN: math.polynomials.tests
USING: kernel math math.polynomials tools.test ;
! Tests
HELP: factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return an ordered list of a number's prime factors, possibly repeated." } }
-{ $examples { $example "300 factors ." "{ 2 2 3 5 5 }" } } ;
+{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 factors ." "{ 2 2 3 5 5 }" } } ;
HELP: group-factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return a sequence of pairs representing each prime factor in the number and its corresponding power (multiplicity)." } }
-{ $examples { $example "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ;
+{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 group-factors ." "{ { 2 2 } { 3 1 } { 5 2 } }" } } ;
HELP: unique-factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
{ $description { "Return an ordered list of a number's unique prime factors." } }
-{ $examples { $example "300 unique-factors ." "{ 2 3 5 }" } } ;
+{ $examples { $example "USING: math.primes.factors prettyprint ;" "300 unique-factors ." "{ 2 3 5 }" } } ;
HELP: totient
{ $values { "n" "a positive integer" } { "t" integer } }
primes-upto
>r 1- next-prime r>
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
+
+: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
-IN: temporary
+IN: math.quaternions.tests
USING: tools.test math.quaternions kernel math.vectors
math.constants ;
USING: math.ranges sequences tools.test arrays ;
-IN: temporary
+IN: math.ranges.tests
[ { } ] [ 1 1 (a,b) >array ] unit-test
[ { } ] [ 1 1 (a,b] >array ] unit-test
USING: kernel layouts math namespaces sequences sequences.private ;
IN: math.ranges
-: >integer ( n -- i )
- dup most-negative-fixnum most-positive-fixnum between?
- [ >fixnum ] [ >bignum ] if ;
-
TUPLE: range from length step ;
: <range> ( from to step -- range )
USING: kernel math math.parser math.ratios math.functions
tools.test ;
-IN: temporary
+IN: math.ratios.tests
[ 1 2 ] [ 1/2 >fraction ] unit-test
HELP: geometric-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
-{ $examples { $example "USE: math.statistics" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
+{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
-{ $examples { $example "USE: math.statistics" "{ 1 2 3 } harmonic-mean ." "6/11" } }
+{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: mean
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
-{ $examples { $example "USE: math.statistics" "{ 1 2 3 } mean ." "2" } }
+{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: median
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
{ $examples
- { $example "USE: math.statistics" "{ 1 2 3 } median ." "2" }
- { $example "USE: math.statistics" "{ 1 2 3 4 } median ." "5/2" } }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: range
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
{ $examples
- { $example "USE: math.statistics" "{ 1 2 3 } range ." "2" }
- { $example "USE: math.statistics" "{ 1 2 3 4 } range ." "3" } } ;
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ;
HELP: std
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard deviation of " { $snippet "seq" } " by squaring the variance of the sequence. It measures how widely spread the values in a sequence are about the mean." }
{ $examples
- { $example "USE: math.statistics" "{ 1 2 3 } std ." "1.0" }
- { $example "USE: math.statistics" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
HELP: ste
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
{ $examples
- { $example "USE: math.statistics" "{ -2 2 } ste ." "2.0" }
- { $example "USE: math.statistics" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
+ { $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" }
+ { $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
HELP: var
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
{ $examples
- { $example "USE: math.statistics" "{ 1 } var ." "0" }
- { $example "USE: math.statistics" "{ 1 2 3 } var ." "1" }
- { $example "USE: math.statistics" "{ 1 2 3 4 } var ." "5/3" } } ;
+ { $example "USING: math.statistics prettyprint ;" "{ 1 } var ." "0" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" }
+ { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ;
USING: kernel math math.functions math.statistics tools.test ;
-IN: temporary
+IN: math.statistics.tests
[ 1 ] [ { 1 } mean ] unit-test
[ 3/2 ] [ { 1 2 } mean ] unit-test
HELP: number>text
{ $values { "n" integer } { "str" string } }
{ $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." }
-{ $examples { $example "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ;
+{ $examples { $example "USING: math.text.english prettyprint ;" "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ;
USING: math.functions math.text.english tools.test ;
-IN: temporary
+IN: math.text.english.tests
[ "Zero" ] [ 0 number>text ] unit-test
[ "Twenty-One" ] [ 21 number>text ] unit-test
HELP: vmax
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." }
-{ $examples { $example "USE: math.vectors" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ;
+{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ;
HELP: vmin
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } }
{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." }
-{ $examples { $example "USE: math.vectors" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ;
+{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ;
HELP: v.
{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } }
HELP: set-axis
{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } }
{ $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." }
-{ $examples { $example "USE: math.vectors" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ;
+{ $examples { $example "USING: math.vectors prettyprint ;" "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ;
{ 2map v+ v- v* v/ } related-words
-IN: temporary
+IN: math.vectors.tests
USING: math.vectors tools.test ;
[ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
-USING: help.syntax help.markup kernel math classes tuples ;
+USING: help.syntax help.markup kernel math classes tuples
+calendar ;
IN: models
HELP: model
{ $examples
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
{ $code
- "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
+ "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget."
- "gadget-model 500 <delay> [ number>string ] <filter>"
+ "gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
"<label-control> gadget."
}
} ;
HELP: <delay>
-{ $values { "model" model } { "timeout" "a positive integer" } { "delay" delay } }
-{ $description "Creates a new instance of " { $link delay } ". A timer of " { $snippet "timeout" } " milliseconds must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
+{ $values { "model" model } { "timeout" duration } { "delay" delay } }
+{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
{ $examples "See the example in the documentation for " { $link delay } "." } ;
HELP: range-value
-IN: temporary
+IN: models.tests
USING: arrays generic kernel math models namespaces sequences assocs
tools.test ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: generic kernel math sequences timers arrays assocs ;
+USING: generic kernel math sequences arrays assocs alarms
+calendar ;
IN: models
TUPLE: model value connections dependencies ref locked? ;
dup history-forward delete-all
dup history-back (add-history) ;
-TUPLE: delay model timeout ;
+TUPLE: delay model timeout alarm ;
: update-delay-model ( delay -- )
dup delay-model model-value swap set-model ;
[ set-delay-model ] 2keep
[ add-dependency ] keep ;
-M: delay model-changed nip 0 over delay-timeout add-timer ;
+: cancel-delay ( delay -- )
+ delay-alarm [ cancel-alarm ] when* ;
-M: delay model-activated update-delay-model ;
+: start-delay ( delay -- )
+ dup [ f over set-delay-alarm update-delay-model ] curry
+ over delay-timeout later
+ swap set-delay-alarm ;
+
+M: delay model-changed nip dup cancel-delay start-delay ;
-M: delay tick dup remove-timer update-delay-model ;
+M: delay model-activated update-delay-model ;
GENERIC: range-value ( model -- value )
GENERIC: range-page-value ( model -- value )
USING: money parser tools.test ;
-IN: temporary
+IN: money.tests
[ -1/10 ] [ DECIMAL: -.1 ] unit-test
[ -1/10 ] [ DECIMAL: -0.1 ] unit-test
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: morse
+
+HELP: ch>morse
+{ $values
+ { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
+{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
+
+HELP: morse>ch
+{ $values
+ { "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
+{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
+
+HELP: >morse
+{ $values
+ { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
+{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
+{ $see-also morse> ch>morse } ;
+
+HELP: morse>
+{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
+{ $description "Translates morse code into ASCII text" }
+{ $see-also >morse morse>ch } ;
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays morse strings tools.test ;
+
+[ "" ] [ CHAR: \\ ch>morse ] unit-test
+[ "..." ] [ CHAR: s ch>morse ] unit-test
+[ CHAR: s ] [ "..." morse>ch ] unit-test
+[ f ] [ "..--..--.." morse>ch ] unit-test
+[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
+[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
+[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel lazy-lists namespaces openal
+parser-combinators promises sequences strings unicode.case ;
+IN: morse
+
+<PRIVATE
+: morse-codes ( -- array )
+ {
+ { CHAR: a ".-" }
+ { CHAR: b "-..." }
+ { CHAR: c "-.-." }
+ { CHAR: d "-.." }
+ { CHAR: e "." }
+ { CHAR: f "..-." }
+ { CHAR: g "--." }
+ { CHAR: h "...." }
+ { CHAR: i ".." }
+ { CHAR: j ".---" }
+ { CHAR: k "-.-" }
+ { CHAR: l ".-.." }
+ { CHAR: m "--" }
+ { CHAR: n "-." }
+ { CHAR: o "---" }
+ { CHAR: p ".--." }
+ { CHAR: q "--.-" }
+ { CHAR: r ".-." }
+ { CHAR: s "..." }
+ { CHAR: t "-" }
+ { CHAR: u "..-" }
+ { CHAR: v "...-" }
+ { CHAR: w ".--" }
+ { CHAR: x "-..-" }
+ { CHAR: y "-.--" }
+ { CHAR: z "--.." }
+ { CHAR: 1 ".----" }
+ { CHAR: 2 "..---" }
+ { CHAR: 3 "...--" }
+ { CHAR: 4 "....-" }
+ { CHAR: 5 "....." }
+ { CHAR: 6 "-...." }
+ { CHAR: 7 "--..." }
+ { CHAR: 8 "---.." }
+ { CHAR: 9 "----." }
+ { CHAR: 0 "-----" }
+ { CHAR: . ".-.-.-" }
+ { CHAR: , "--..--" }
+ { CHAR: ? "..--.." }
+ { CHAR: ' ".----." }
+ { CHAR: ! "-.-.--" }
+ { CHAR: / "-..-." }
+ { CHAR: ( "-.--." }
+ { CHAR: ) "-.--.-" }
+ { CHAR: & ".-..." }
+ { CHAR: : "---..." }
+ { CHAR: ; "-.-.-." }
+ { CHAR: = "-...- " }
+ { CHAR: + ".-.-." }
+ { CHAR: - "-....-" }
+ { CHAR: _ "..--.-" }
+ { CHAR: " ".-..-." }
+ { CHAR: $ "...-..-" }
+ { CHAR: @ ".--.-." }
+ { CHAR: \s "/" }
+ } ;
+
+: ch>morse-assoc ( -- assoc )
+ morse-codes >hashtable ;
+
+: morse>ch-assoc ( -- assoc )
+ morse-codes [ reverse ] map >hashtable ;
+
+PRIVATE>
+
+: ch>morse ( ch -- str )
+ ch>lower ch>morse-assoc at* swap "" ? ;
+
+: morse>ch ( str -- ch )
+ morse>ch-assoc at* swap f ? ;
+
+: >morse ( str -- str )
+ [
+ [ CHAR: \s , ] [ ch>morse % ] interleave
+ ] "" make ;
+
+<PRIVATE
+
+: dot ( -- ch ) CHAR: . ;
+: dash ( -- ch ) CHAR: - ;
+: char-gap ( -- ch ) CHAR: \s ;
+: word-gap ( -- ch ) CHAR: / ;
+
+: =parser ( obj -- parser )
+ [ = ] curry satisfy ;
+
+LAZY: 'dot' ( -- parser )
+ dot =parser ;
+
+LAZY: 'dash' ( -- parser )
+ dash =parser ;
+
+LAZY: 'char-gap' ( -- parser )
+ char-gap =parser ;
+
+LAZY: 'word-gap' ( -- parser )
+ word-gap =parser ;
+
+LAZY: 'morse-char' ( -- parser )
+ 'dot' 'dash' <|> <+> ;
+
+LAZY: 'morse-word' ( -- parser )
+ 'morse-char' 'char-gap' list-of ;
+
+LAZY: 'morse-words' ( -- parser )
+ 'morse-word' 'word-gap' list-of ;
+
+PRIVATE>
+
+: morse> ( str -- str )
+ 'morse-words' parse car parse-result-parsed [
+ [
+ >string morse>ch
+ ] map >string
+ ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
+
-USING: io io.files sequences xml xml.utilities ;
+USING: io io.files sequences xml xml.utilities
+io.encodings.ascii kernel ;
IN: msxml-to-csv
-: print-csv ( table -- ) [ "," join print ] each ;
-
: (msxml>csv) ( xml -- table )
"Worksheet" tag-named
"Table" tag-named
] map
] map ;
-: msxml>csv ( infile outfile -- )
- [
- file>xml (msxml>csv) print-csv
- ] with-file-writer ;
+: msxml>csv ( outfile infile -- )
+ file>xml (msxml>csv) [ "," join ] map
+ swap ascii set-file-lines ;
-IN: temporary
+IN: multi-methods.tests
USING: multi-methods tools.test kernel math arrays sequences
prettyprint strings classes hashtables assocs namespaces
debugger continuations ;
USING: multiline tools.test ;
+IN: multiline.tests
STRING: test-it
foo
: <"
"\">" parse-multiline-string parsed ; parsing
+
+: /* "*/" parse-multiline-string drop ; parsing
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib ;
+ assocs.lib math.parser math sequences.lib ;
IN: namespaces.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set* ( val var -- ) namestack* set-assoc-stack ;
+
+SYMBOL: building-seq
+: get-building-seq ( n -- seq )
+ building-seq get nth ;
+
+: n, get-building-seq push ;
+: n% get-building-seq push-all ;
+: n# >r number>string r> n% ;
+
+: 0, 0 n, ;
+: 0% 0 n% ;
+: 0# 0 n# ;
+: 1, 1 n, ;
+: 1% 1 n% ;
+: 1# 1 n# ;
+: 2, 2 n, ;
+: 2% 2 n% ;
+: 2# 2 n# ;
+: 3, 3 n, ;
+: 3% 3 n% ;
+: 3# 3 n# ;
+: 4, 4 n, ;
+: 4% 4 n% ;
+: 4# 4 n# ;
+
+: nmake ( quot exemplars -- seqs )
+ dup length dup zero? [ 1+ ] when
+ [
+ [
+ [ drop 1024 swap new-resizable ] 2map
+ [ building-seq set call ] keep
+ ] 2keep >r [ like ] 2map r> firstn
+ ] with-scope ;
[ \ over , swap writer-word , ] [ ] make define-inline
] [ 2drop ] if ;
-: changer-effect T{ effect f { "object" "quot" } } ; inline
+: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
: changer-word ( name -- word )
"change-" swap append changer-effect create-accessor ;
[
[ over >r >r ] %
over reader-word ,
- [ r> call r> ] %
- swap writer-word ,
- ] [ ] make define
+ [ r> call r> swap ] %
+ swap setter-word ,
+ ] [ ] make define-inline
] [ 2drop ] if ;
: define-new-slot ( class slot name -- )
sequences libc shuffle alien.c-types system openal math\r
namespaces threads shuffle opengl arrays ui.gadgets.worlds\r
combinators math.parser ui.gadgets ui.render opengl.gl ui\r
- continuations io.files hints combinators.lib sequences.lib ;\r
+ continuations io.files hints combinators.lib sequences.lib\r
+ io.encodings.binary debugger ;\r
\r
IN: ogg.player\r
\r
dup player-gadget [\r
dup { player-td player-yuv } get-slots theora_decode_YUVout drop\r
dup player-rgb over player-yuv yuv>rgb\r
- dup player-gadget find-world dup draw-world\r
+ dup player-gadget relayout-1 yield\r
] when ;\r
\r
: num-audio-buffers-processed ( player -- player n )\r
: append-audio ( player -- player bool )\r
num-audio-buffers-processed {\r
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
- { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }\r
+ { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }\r
{ [ t ] [ fill-processed-audio-buffer t ] }\r
} cond ;\r
\r
parse-remaining-headers\r
initialize-decoder\r
dup player-gadget [ initialize-gui ] when*\r
- [ decode ] [ drop ] recover\r
-! decode\r
+ [ decode ] try\r
wait-for-sound\r
cleanup\r
drop ;\r
<player> play-ogg ;\r
\r
: play-vorbis-file ( filename -- )\r
- <file-reader> play-vorbis-stream ;\r
+ binary <file-reader> play-vorbis-stream ;\r
\r
: play-theora-stream ( stream -- )\r
<player>\r
play-ogg ;\r
\r
: play-theora-file ( filename -- )\r
- <file-reader> play-theora-stream ;\r
+ binary <file-reader> play-theora-stream ;\r
\r
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
HELP: has-gl-version-or-extensions?
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
HELP: require-gl-extensions
: version-seq ( version-string -- version-seq )
"." split [ string>number ] map ;
-: version<=> ( version1 version2 -- n )
- swap version-seq swap version-seq <=> ;
+: version-before? ( version1 version2 -- ? )
+ swap version-seq swap version-seq before=? ;
: (gl-version) ( -- version vendor )
GL_VERSION glGetString " " split1 ;
: gl-vendor-version ( -- version )
(gl-version) nip ;
: has-gl-version? ( version -- ? )
- gl-version version<=> 0 <= ;
+ gl-version version-before? ;
: (make-gl-version-error) ( required-version -- )
"Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
: require-gl-version ( version -- )
: glsl-vendor-version ( -- version )
(glsl-version) nip ;
: has-glsl-version? ( version -- ? )
- glsl-version version<=> 0 <= ;
+ glsl-version version-before? ;
: require-glsl-version ( version -- )
[ has-glsl-version? ]
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
: reset-gl-function-pointers ( -- )
100 <hashtable> +gl-function-pointers+ set-global ;
-[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook
+[ reset-gl-function-pointers ] "opengl.gl" add-init-hook
reset-gl-function-pointers
reset-gl-function-number-counter
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
+opengl.gl multiline assocs strings ;
IN: opengl.shaders
HELP: gl-shader
} ;
HELP: <gl-shader>
-{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } }
+{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } }
{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
HELP: <vertex-shader>
-{ $values { "source" "The GLSL source code to compile" } }
+{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } }
{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
HELP: <fragment-shader>
-{ $values { "source" "The GLSL source code to compile" } }
+{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } }
{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
HELP: gl-shader-ok?
-{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } }
{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
HELP: check-gl-shader
{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
HELP: gl-shader-info-log
-{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
HELP: gl-program
} ;
HELP: <gl-program>
-{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
+{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } }
{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
HELP: <simple-gl-program>
-{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } }
+{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } }
{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
{ <gl-program> <simple-gl-program> } related-words
HELP: gl-program-ok?
-{ $values { "program" "A " { $link gl-program } " object" } }
+{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } }
{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
HELP: check-gl-program
{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
HELP: gl-program-info-log
-{ $values { "program" "A " { $link gl-program } " object" } }
+{ $values { "program" "A " { $link gl-program } " object" } { "log" string } }
{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
HELP: delete-gl-program
alien>char-string
] with-malloc ;
-: check-gl-shader ( shader -- shader* )
+: check-gl-shader ( shader -- shader )
dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
: delete-gl-shader ( shader -- ) glDeleteShader ; inline
alien>char-string
] with-malloc ;
-: check-gl-program ( program -- program* )
+: check-gl-program ( program -- program )
dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
: gl-program-shaders-length ( program -- shaders-length )
IN: openssl.libssl
-"libssl" {
+<< "libssl" {
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
-} cond add-library
+} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
: X509_FILETYPE_ASN1 2 ; inline
-USING: oracle oracle.liboci prettyprint tools.test ;
+USING: oracle oracle.liboci prettyprint tools.test
+kernel ;
-"testuser" "testpassword" "//localhost/test1" log-on .
+[
+ "testuser" "testpassword" "//localhost/test1" log-on .
-allocate-statement-handle
+ allocate-statement-handle
-"CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement
+ "CREATE TABLE TESTTABLE ( COL1 VARCHAR(40), COL2 NUMBER)" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement
+ "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hello', 50)" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement
+ "INSERT INTO TESTTABLE (COL1, COL2) VALUES('hi', 60)" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement
+ "INSERT INTO TESTTABLE (COL1, COL2) VALUES('bye', 70)" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"COMMIT" prepare-statement
+ "COMMIT" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"SELECT * FROM TESTTABLE" prepare-statement
+ "SELECT * FROM TESTTABLE" prepare-statement
-1 SQLT_STR define-by-position run-query
+ 1 SQLT_STR define-by-position run-query
-[ V{ "hello" "hi" "bye" "50" "60" "70" } ] [
-2 SQLT_STR define-by-position run-query gather-results
-] unit-test
+ [ V{ "hello" "hi" "bye" "50" "60" "70" } ] [
+ 2 SQLT_STR define-by-position run-query gather-results
+ ] unit-test
-clear-result
+ clear-result
-"UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement
+ "UPDATE TESTTABLE SET COL2 = 10 WHERE COL1='hi'" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"COMMIT" prepare-statement
+ "COMMIT" prepare-statement
-[ t ] [ execute-statement ] unit-test
+ [ t ] [ execute-statement ] unit-test
-"SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement
+ "SELECT * FROM TESTTABLE WHERE COL1 = 'hi'" prepare-statement
-[ V{ "10" } ] [
-2 SQLT_STR define-by-position run-query gather-results
-] unit-test
+ [ V{ "10" } ] [
+ 2 SQLT_STR define-by-position run-query gather-results
+ ] unit-test
-clear-result
+ clear-result
-"DROP TABLE TESTTABLE" prepare-statement
+ "DROP TABLE TESTTABLE" prepare-statement
-execute-statement
+ execute-statement
-free-statement-handle log-off clean-up terminate
+ free-statement-handle log-off clean-up terminate
+] drop
"'items' is a parser that can parse the individual elements. 'separator' "
"is a parser for the symbol that separatest them. The result tree of "
"the resulting parser is an array of the parsed elements." }
-{ $example "USE: parser-combinators" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" }
+{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' \",\" token list-of parse-1 ." "{ 1 2 3 4 }" }
{ $see-also list-of } ;
HELP: any-char-parser
"from the input string. The value consumed is the "
"result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
+{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel lazy-lists tools.test strings math
sequences parser-combinators arrays math.parser unicode.categories ;
-IN: scratchpad
+IN: parser-combinators.tests
! Testing <&>
{ { T{ parse-result f { "a" "b" } T{ slice f 2 4 "abcd" } } } } [
! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists promises kernel sequences strings math
arrays splitting quotations combinators namespaces
-unicode.case unicode.categories ;
+unicode.case unicode.categories sequences.deep ;
IN: parser-combinators
! Parser combinator protocol
LAZY: surrounded-by ( parser start end -- parser' )
[ token ] 2apply swapd pack ;
-: flatten* ( obj -- )
- dup array? [ [ flatten* ] each ] [ , ] if ;
-
-: flatten [ flatten* ] { } make ;
-
: exactly-n ( parser n -- parser' )
swap <repetition> <and-parser> [ flatten ] <@ ;
"the input string. The numeric value of the digit "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'digit' parse-1 ." "1" } } ;
+{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
HELP: 'integer'
{ $values
"the input string. The numeric value of the integer "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"123\" 'integer' parse-1 ." "123" } } ;
+{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
HELP: 'string'
{ $values
{ "parser" "a parser object" } }
"quotations from the input string. The string value "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
+{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
+
HELP: 'bold'
{ $values
{ "parser" "a parser object" } }
"the '*' character from the input string. This is "
"commonly used in markup languages to indicate bold "
"faced text." }
-{ $example "USE: parser-combinators" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
-{ $example "USE: parser-combinators" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
+{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
+
HELP: 'italic'
{ $values
{ "parser" "a parser object" } }
"commonly used in markup languages to indicate italic "
"faced text." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
-{ $example "USING: lazy-lists parser-combinators ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
+{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
HELP: comma-list
{ $values
{ "element" "a parser object" } { "parser" "a parser object" } }
"'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
+{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words
+++ /dev/null
-
-USING: kernel sequences quotations math parser
- shuffle combinators.cleave combinators.lib sequences.lib ;
-
-IN: partial-apply
-
-! Basic conceptual implementation. Todo: get it to compile.
-
-: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
-
-SYMBOL: _
-
-SYMBOL: ~
-
-: blank-positions ( quot -- seq )
- [ length 2 - ] [ _ indices ] bi [ - ] map-with ;
-
-: partial-apply ( pattern -- quot )
- [ blank-positions length nrev ]
- [ peek 1quotation ]
- [ blank-positions ]
- tri
- [ apply-n ] each ;
-
-: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing
-
USING: namespaces math partial-continuations tools.test
kernel sequences ;
-IN: temporary
+IN: partial-continuations.tests
SYMBOL: sum
IN: pdf.libhpdf
-"libhpdf" {
+<< "libhpdf" {
{ [ win32? ] [ "libhpdf.dll" "stdcall" ] }
{ [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
-} cond add-library
+} cond add-library >>
! compression mode
: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ;
+IN: pdf.tests
SYMBOL: font
] with-text
- "extra/pdf/test/font_test.pdf" resource-path save-to-file
+ "font_test.pdf" temp-file save-to-file
] with-pdf
+++ /dev/null
-%PDF-1.3
-%·¾Âª
-1 0 obj
-<<
-/Type /Catalog
-/Pages 2 0 R
->>
-endobj
-2 0 obj
-<<
-/Type /Pages
-/Kids [ 4 0 R ]
-/Count 1
->>
-endobj
-3 0 obj
-<<
-/Producer (Haru\040Free\040PDF\040Library\0402.0.8)
->>
-endobj
-4 0 obj
-<<
-/Type /Page
-/MediaBox [ 0 0 595 841 ]
-/Contents 5 0 R
-/Resources <<
-/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ]
-/Font <<
-/F1 7 0 R
-/F2 8 0 R
-/F3 9 0 R
-/F4 10 0 R
-/F5 11 0 R
-/F6 12 0 R
-/F7 13 0 R
-/F8 14 0 R
-/F9 15 0 R
-/F10 16 0 R
-/F11 17 0 R
-/F12 18 0 R
-/F13 19 0 R
-/F14 20 0 R
->>
->>
-/Parent 2 0 R
->>
-endobj
-5 0 obj
-<<
-/Length 6 0 R
->>
-stream\r
-1 w
-50 50 495 731 re
-S
-/F1 24 Tf
-BT
-238.148 791 Td
-(Font\040Demo) Tj
-ET
-BT
-/F1 16 Tf
-60 761 Td
-(\074Standard\040Type1\040font\040samples\076) Tj
-ET
-BT
-60 736 Td
-/F2 9 Tf
-(Courier) Tj
-0 -18 Td
-/F2 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F3 9 Tf
-(Courier-Bold) Tj
-0 -18 Td
-/F3 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F4 9 Tf
-(Courier-Oblique) Tj
-0 -18 Td
-/F4 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F5 9 Tf
-(Courier-BoldOblique) Tj
-0 -18 Td
-/F5 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F1 9 Tf
-(Helvetica) Tj
-0 -18 Td
-/F1 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F6 9 Tf
-(Helvetica-Bold) Tj
-0 -18 Td
-/F6 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F7 9 Tf
-(Helvetica-Oblique) Tj
-0 -18 Td
-/F7 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F8 9 Tf
-(Helvetica-BoldOblique) Tj
-0 -18 Td
-/F8 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F9 9 Tf
-(Times-Roman) Tj
-0 -18 Td
-/F9 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F10 9 Tf
-(Times-Bold) Tj
-0 -18 Td
-/F10 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F11 9 Tf
-(Times-Italic) Tj
-0 -18 Td
-/F11 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F12 9 Tf
-(Times-BoldItalic) Tj
-0 -18 Td
-/F12 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F13 9 Tf
-(Symbol) Tj
-0 -18 Td
-/F13 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F14 9 Tf
-(ZapfDingbats) Tj
-0 -18 Td
-/F14 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-ET
-
-endstream
-endobj
-6 0 obj
-1517
-endobj
-7 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-8 0 obj
-<<
-/Type /Font
-/BaseFont /Courier
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-9 0 obj
-<<
-/Type /Font
-/BaseFont /Courier-Bold
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-10 0 obj
-<<
-/Type /Font
-/BaseFont /Courier-Oblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-11 0 obj
-<<
-/Type /Font
-/BaseFont /Courier-BoldOblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-12 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica-Bold
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-13 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica-Oblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-14 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica-BoldOblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-15 0 obj
-<<
-/Type /Font
-/BaseFont /Times-Roman
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-16 0 obj
-<<
-/Type /Font
-/BaseFont /Times-Bold
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-17 0 obj
-<<
-/Type /Font
-/BaseFont /Times-Italic
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-18 0 obj
-<<
-/Type /Font
-/BaseFont /Times-BoldItalic
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-19 0 obj
-<<
-/Type /Font
-/BaseFont /Symbol
-/Subtype /Type1
->>
-endobj
-20 0 obj
-<<
-/Type /Font
-/BaseFont /ZapfDingbats
-/Subtype /Type1
->>
-endobj
-xref
-0 21
-0000000000 65535 f\r
-0000000015 00000 n\r
-0000000064 00000 n\r
-0000000123 00000 n\r
-0000000196 00000 n\r
-0000000518 00000 n\r
-0000002089 00000 n\r
-0000002109 00000 n\r
-0000002207 00000 n\r
-0000002303 00000 n\r
-0000002404 00000 n\r
-0000002509 00000 n\r
-0000002618 00000 n\r
-0000002722 00000 n\r
-0000002829 00000 n\r
-0000002940 00000 n\r
-0000003041 00000 n\r
-0000003141 00000 n\r
-0000003243 00000 n\r
-0000003349 00000 n\r
-0000003417 00000 n\r
-trailer
-<<
-/Root 1 0 R
-/Info 3 0 R
-/Size 21
->>
-startxref
-3491
-%%EOF
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf ;
-IN: temporary
+IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
"abc" 'non-terminal' parse parse-result-ast
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel parser words arrays strings math.parser sequences \r
quotations vectors namespaces math assocs continuations peg\r
- unicode.categories ;\r
+ peg.parsers unicode.categories ;\r
IN: peg.ebnf\r
\r
TUPLE: ebnf-non-terminal symbol ;\r
f\r
] if* ;\r
\r
-: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing
\ No newline at end of file
+: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing\r
--- /dev/null
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax peg peg.parsers.private
+unicode.categories ;
+IN: peg.parsers
+
+HELP: 1token
+{ $values
+ { "ch" "a character" }
+ { "parser" "a parser" }
+} { $description
+ "Calls 1string on a character and returns a parser that matches that character."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"a\" CHAR: a 1token parse parse-result-ast ." "\"a\"" }
+} { $see-also 'string' } ;
+
+HELP: (list-of)
+{ $values
+ { "items" "a sequence" }
+ { "separator" "a parser" }
+ { "repeat1?" "a boolean" }
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that returns a list of items separated by the separator parser. Does not hide the separators."
+} { $see-also list-of list-of-many } ;
+
+HELP: list-of
+{ $values
+ { "items" "a sequence" }
+ { "separator" "a parser" }
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items."
+} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." }
+{ $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also list-of-many } ;
+
+HELP: list-of-many
+{ $values
+ { "items" "a sequence" }
+ { "separator" "a parser" }
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items."
+} { $notes "Use " { $link list-of } " to return a list of only one item."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"a\" \"a\" token \",\" token list-of-many parse ." "f" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also list-of } ;
+
+HELP: epsilon
+{ $values
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that matches the empty sequence."
+} ;
+
+HELP: any-char
+{ $values
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that matches the any single character."
+} ;
+
+HELP: exactly-n
+{ $values
+ { "parser" "a parser" }
+ { "n" "an integer" }
+ { "parser'" "a parser" }
+} { $description
+ "Returns a parser that matches an exact repetition of the input parser."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 exactly-n parse ." "f" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also at-least-n at-most-n from-m-to-n } ;
+
+HELP: at-least-n
+{ $values
+ { "parser" "a parser" }
+ { "n" "an integer" }
+ { "parser'" "a parser" }
+} { $description
+ "Returns a parser that matches n or more repetitions of the input parser."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 4 at-least-n parse ." "f" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also exactly-n at-most-n from-m-to-n } ;
+
+HELP: at-most-n
+{ $values
+ { "parser" "a parser" }
+ { "n" "an integer" }
+ { "parser'" "a parser" }
+} { $description
+ "Returns a parser that matches n or fewer repetitions of the input parser."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also exactly-n at-least-n from-m-to-n } ;
+
+HELP: from-m-to-n
+{ $values
+ { "parser" "a parser" }
+ { "m" "an integer" }
+ { "n" "an integer" }
+ { "parser'" "a parser" }
+} { $description
+ "Returns a parser that matches between and including m to n repetitions of the input parser."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+ { $example "USING: peg peg.parsers prettyprint ;" "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" }
+} { $see-also exactly-n at-most-n at-least-n } ;
+
+HELP: pack
+{ $values
+ { "begin" "a parser" }
+ { "body" "a parser" }
+ { "end" "a parser" }
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" }
+} { $see-also surrounded-by } ;
+
+HELP: surrounded-by
+{ $values
+ { "parser" "a parser" }
+ { "begin" "a string" }
+ { "end" "a string" }
+ { "parser'" "a parser" }
+} { $description
+ "Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden."
+} { $examples
+ { $example "USING: peg peg.parsers prettyprint ;" "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" }
+} { $see-also pack } ;
+
+HELP: 'digit'
+{ $values
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that matches a single digit as defined by the " { $link digit? } " word."
+} { $see-also 'integer' } ;
+
+HELP: 'integer'
+{ $values
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that matches an integer composed of digits, as defined by the " { $link 'digit' } " word."
+} { $see-also 'digit' 'string' } ;
+
+HELP: 'string'
+{ $values
+ { "parser" "a parser" }
+} { $description
+ "Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
+} { $see-also 'integer' } ;
--- /dev/null
+USING: kernel peg peg.parsers tools.test ;
+IN: peg.parsers.tests
+
+[ V{ "a" } ]
+[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test
+
+[ f ]
+[ "a" "a" token "," token list-of-many parse ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test
+
+[ f ]
+[ "aaa" "a" token 4 exactly-n parse ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test
+
+[ f ]
+[ "aaa" "a" token 4 at-least-n parse ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" "a" } ]
+[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" } ]
+[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+
+[ V{ "a" "a" "a" "a" } ]
+[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test
+
+[ 97 ]
+[ "a" any-char parse parse-result-ast ] unit-test
+
+[ V{ } ]
+[ "" epsilon parse parse-result-ast ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings namespaces math assocs shuffle
+ vectors arrays combinators.lib memoize math.parser match
+ unicode.categories sequences.deep peg peg.private ;
+IN: peg.parsers
+
+TUPLE: just-parser p1 ;
+
+: just-pattern
+ [
+ dup [
+ dup parse-result-remaining empty? [ drop f ] unless
+ ] when
+ ] ;
+
+
+M: just-parser compile ( parser -- quot )
+ just-parser-p1 compile just-pattern append ;
+
+MEMO: just ( parser -- parser )
+ just-parser construct-boa init-parser ;
+
+MEMO: 1token ( ch -- parser ) 1string token ;
+
+<PRIVATE
+MEMO: (list-of) ( items separator repeat1? -- parser )
+ >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
+ [ unclip 1vector swap first append ] action ;
+PRIVATE>
+
+MEMO: list-of ( items separator -- parser )
+ hide f (list-of) ;
+
+MEMO: list-of-many ( items separator -- parser )
+ hide t (list-of) ;
+
+MEMO: epsilon ( -- parser ) V{ } token ;
+
+MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
+
+<PRIVATE
+
+: flatten-vectors ( pair -- vector )
+ first2 over push-all ;
+
+PRIVATE>
+
+MEMO: exactly-n ( parser n -- parser' )
+ swap <repetition> seq ;
+
+MEMO: at-most-n ( parser n -- parser' )
+ dup zero? [
+ 2drop epsilon
+ ] [
+ 2dup exactly-n
+ -rot 1- at-most-n 2choice
+ ] if ;
+
+MEMO: at-least-n ( parser n -- parser' )
+ dupd exactly-n swap repeat0 2seq
+ [ flatten-vectors ] action ;
+
+MEMO: from-m-to-n ( parser m n -- parser' )
+ >r [ exactly-n ] 2keep r> swap - at-most-n 2seq
+ [ flatten-vectors ] action ;
+
+MEMO: pack ( begin body end -- parser )
+ >r >r hide r> r> hide 3seq [ first ] action ;
+
+MEMO: surrounded-by ( parser begin end -- parser' )
+ [ token ] 2apply swapd pack ;
+
+MEMO: 'digit' ( -- parser )
+ [ digit? ] satisfy [ digit> ] action ;
+
+MEMO: 'integer' ( -- parser )
+ 'digit' repeat1 [ 10 digits>integer ] action ;
+
+MEMO: 'string' ( -- parser )
+ [
+ [ CHAR: " = ] satisfy hide ,
+ [ CHAR: " = not ] satisfy repeat0 ,
+ [ CHAR: " = ] satisfy hide ,
+ ] { } make seq [ first >string ] action ;
\r
HELP: delay\r
{ $values \r
+ { "quot" "a quotation" } \r
{ "parser" "a parser" } \r
}\r
{ $description \r
"Delays the construction of a parser until it is actually required to parse. This " \r
"allows for calling a parser that results in a recursive call to itself. The quotation "\r
- "should return the constructed parser." } ;
\ No newline at end of file
+ "should return the constructed parser." } ;\r
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
-IN: temporary
+IN: peg.tests
{ 0 1 2 } [
0 next-id set-global get-next-id get-next-id get-next-id
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser match
- unicode.categories ;
+ unicode.categories sequences.lib compiler.units parser
+ words ;
IN: peg
TUPLE: parse-result remaining ast ;
: seq ( seq -- parser )
seq-parser construct-boa init-parser ;
+: 2seq ( parser1 parser2 -- parser )
+ 2array seq ;
+
+: 3seq ( parser1 parser2 parser3 -- parser )
+ 3array seq ;
+
+: 4seq ( parser1 parser2 parser3 parser4 -- parser )
+ 4array seq ;
+
+: seq* ( quot -- paser )
+ { } make seq ; inline
+
: choice ( seq -- parser )
choice-parser construct-boa init-parser ;
+: 2choice ( parser1 parser2 -- parser )
+ 2array choice ;
+
+: 3choice ( parser1 parser2 parser3 -- parser )
+ 3array choice ;
+
+: 4choice ( parser1 parser2 parser3 parser4 -- parser )
+ 4array choice ;
+
+: choice* ( quot -- paser )
+ { } make choice ; inline
+
MEMO: repeat0 ( parser -- parser )
repeat0-parser construct-boa init-parser ;
MEMO: hide ( parser -- parser )
[ drop ignore ] action ;
-MEMO: delay ( parser -- parser )
+MEMO: delay ( quot -- parser )
delay-parser construct-boa init-parser ;
-MEMO: list-of ( items separator -- parser )
- hide over 2array seq repeat0 [ concat ] action 2array seq [ unclip 1vector swap first append ] action ;
-
-MEMO: 'digit' ( -- parser )
- [ digit? ] satisfy [ digit> ] action ;
-
-MEMO: 'integer' ( -- parser )
- 'digit' repeat1 [ 10 digits>integer ] action ;
-
-MEMO: 'string' ( -- parser )
- [
- [ CHAR: " = ] satisfy hide ,
- [ CHAR: " = not ] satisfy repeat0 ,
- [ CHAR: " = ] satisfy hide ,
- ] { } make seq [ first >string ] action ;
+: PEG:
+ (:) [
+ [
+ call compile
+ [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
+ append define
+ ] with-compilation-unit
+ ] 2curry over push-all ; parsing
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.pl0 ;
-IN: temporary
+IN: peg.pl0.tests
{ "abc" } [
"abc" ident parse parse-result-ast
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays strings math.parser sequences peg peg.ebnf memoize ;
+USING: kernel arrays strings math.parser sequences
+peg peg.ebnf peg.parsers memoize ;
IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
"Write the object to the standard output stream, unless "
"it is an array, in which case recurse through the array "
"writing each object to the stream." }
-{ $example "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ;
+{ $example "USE: peg.search" "{ 65 \"bc\" { 68 \"ef\" } } tree-write" "AbcDef" } ;
HELP: search
{ $values
"parser."
}
-{ $example "\"one 123 two 456\" 'integer' search" "V{ 123 456 }" }
-{ $example "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2array choice search" "V{ 123 \"hello\" 456 }" }
+{ $example "USING: peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' search ." "V{ 123 456 }" }
+{ $example "USING: peg peg.parsers peg.search prettyprint ;" "\"one 123 \\\"hello\\\" two 456\" 'integer' 'string' 2choice search ." "V{ 123 \"hello\" 456 }" }
{ $see-also replace } ;
HELP: replace
"successfully parse with the given parser replaced with "
"the result of that parser."
}
-{ $example "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace" "\"one 246 two 912\"" }
+{ $example "USING: math math.parser peg peg.parsers peg.search prettyprint ;" "\"one 123 two 456\" 'integer' [ 2 * number>string ] action replace ." "\"one 246 two 912\"" }
{ $see-also search } ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel math math.parser arrays tools.test peg peg.search ;
-IN: temporary
+USING: kernel math math.parser arrays tools.test peg peg.parsers
+peg.search ;
+IN: peg.search.tests
{ V{ 123 456 } } [
"abc 123 def 456" 'integer' search
-IN: temporary
+IN: porter-stemmer.tests
USING: arrays io kernel porter-stemmer sequences tools.test
-io.files ;
+io.files io.encodings.utf8 ;
[ 0 ] [ "xa" consonant-seq ] unit-test
[ 0 ] [ "xxaa" consonant-seq ] unit-test
[ "hell" ] [ "hell" step5 "" like ] unit-test
[ "mate" ] [ "mate" step5 "" like ] unit-test
-: resource-lines resource-path file-lines ;
+: resource-lines resource-path utf8 file-lines ;
[ { } ] [
"extra/porter-stemmer/test/voc.txt" resource-lines
<PRIVATE
: start-date ( -- timestamp )
- 1901 1 1 0 0 0 0 make-timestamp ;
+ 1901 1 1 <date> ;
: end-date ( -- timestamp )
- 2000 12 31 0 0 0 0 make-timestamp ;
+ 2000 12 31 <date> ;
-: (first-days) ( end-date start-date -- )
- 2dup timestamp- 0 >= [
- dup day-of-week , 1 +month (first-days)
- ] [
- 2drop
- ] if ;
-
-: first-days ( start-date end-date -- seq )
- [ swap (first-days) ] { } make ;
+: first-days ( end-date start-date -- days )
+ [ 2dup after=? ]
+ [ dup 1 months time+ swap day-of-week ]
+ [ ] unfold 2nip ;
PRIVATE>
: euler019a ( -- answer )
- start-date end-date first-days [ zero? ] count ;
+ end-date start-date first-days [ zero? ] count ;
! [ euler019a ] 100 ave-time
! 131 ms run / 3 ms GC ave time - 100 trials
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: ascii io.files kernel math project-euler.common sequences sorting splitting ;
+USING: ascii io.encodings.ascii io.files kernel math project-euler.common
+ sequences sequences.lib sorting splitting ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22
: source-022 ( -- seq )
"extra/project-euler/022/names.txt" resource-path
- file-contents [ quotable? ] subset "," split ;
+ ascii file-contents [ quotable? ] subset "," split ;
: name-scores ( seq -- seq )
- dup length [ 1+ swap alpha-value * ] 2map ;
+ [ 1+ swap alpha-value * ] map-index ;
PRIVATE>
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii io.files kernel math math.functions namespaces
- project-euler.common sequences sequences.lib splitting ;
+ project-euler.common sequences sequences.lib splitting io.encodings.ascii ;
IN: project-euler.042
! http://projecteuler.net/index.php?section=problems&id=42
: source-042 ( -- seq )
"extra/project-euler/042/words.txt" resource-path
- file-contents [ quotable? ] subset "," split ;
+ ascii file-contents [ quotable? ] subset "," split ;
: (triangle-upto) ( limit n -- )
2dup nth-triangle > [
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.lib kernel math math.primes math.primes.factors
+ math.ranges namespaces sequences ;
+IN: project-euler.047
+
+! http://projecteuler.net/index.php?section=problems&id=47
+
+! DESCRIPTION
+! -----------
+
+! The first two consecutive numbers to have two distinct prime factors are:
+
+! 14 = 2 * 7
+! 15 = 3 * 5
+
+! The first three consecutive numbers to have three distinct prime factors are:
+
+! 644 = 2² * 7 * 23
+! 645 = 3 * 5 * 43
+! 646 = 2 * 17 * 19.
+
+! Find the first four consecutive integers to have four distinct primes
+! factors. What is the first of these numbers?
+
+
+! SOLUTION
+! --------
+
+! Brute force, not sure why it's incredibly slow compared to other languages
+
+<PRIVATE
+
+: (consecutive) ( count goal test -- n )
+ pick pick = [
+ swap - nip
+ ] [
+ dup prime? [ [ drop 0 ] dipd ] [
+ 2dup unique-factors length = [ [ 1+ ] dipd ] [ [ drop 0 ] dipd ] if
+ ] if 1+ (consecutive)
+ ] if ;
+
+: consecutive ( goal test -- n )
+ 0 -rot (consecutive) ;
+
+PRIVATE>
+
+: euler047 ( -- answer )
+ 4 646 consecutive ;
+
+! [ euler047 ] time
+! 542708 ms run / 60548 ms GC time
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! Use a sieve to generate prime factor counts up to an arbitrary limit, then
+! look for a repetition of the specified number of factors.
+
+<PRIVATE
+
+SYMBOL: sieve
+
+: initialize-sieve ( n -- )
+ 0 <repetition> >array sieve set ;
+
+: is-prime? ( index -- ? )
+ sieve get nth zero? ;
+
+: multiples ( n -- seq )
+ sieve get length 1- over <range> ;
+
+: increment-counts ( n -- )
+ multiples [ sieve get [ 1+ ] change-nth ] each ;
+
+: prime-tau-upto ( limit -- seq )
+ dup initialize-sieve 2 swap [a,b) [
+ dup is-prime? [ increment-counts ] [ drop ] if
+ ] each sieve get ;
+
+: consecutive-under ( m limit -- n/f )
+ prime-tau-upto [ dup <repetition> ] dip start ;
+
+PRIVATE>
+
+: euler047a ( -- answer )
+ 4 200000 consecutive-under ;
+
+! [ euler047a ] 100 ave-time
+! 503 ms run / 5 ms GC ave time - 100 trials
+
+! TODO: I don't like that you have to specify the upper bound, maybe try making
+! this lazy so it could also short-circuit when it finds the answer?
+
+MAIN: euler047a
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
+ math.parser namespaces sequences sequences.lib sequences.private sorting
+ splitting strings ;
+IN: project-euler.059
+
+! http://projecteuler.net/index.php?section=problems&id=59
+
+! DESCRIPTION
+! -----------
+
+! Each character on a computer is assigned a unique code and the preferred
+! standard is ASCII (American Standard Code for Information Interchange). For
+! example, uppercase A = 65, asterisk (*) = 42, and lowercase k = 107.
+
+! A modern encryption method is to take a text file, convert the bytes to
+! ASCII, then XOR each byte with a given value, taken from a secret key. The
+! advantage with the XOR function is that using the same encryption key on the
+! cipher text, restores the plain text; for example, 65 XOR 42 = 107, then 107
+! XOR 42 = 65.
+
+! For unbreakable encryption, the key is the same length as the plain text
+! message, and the key is made up of random bytes. The user would keep the
+! encrypted message and the encryption key in different locations, and without
+! both "halves", it is impossible to decrypt the message.
+
+! Unfortunately, this method is impractical for most users, so the modified
+! method is to use a password as a key. If the password is shorter than the
+! message, which is likely, the key is repeated cyclically throughout the
+! message. The balance for this method is using a sufficiently long password
+! key for security, but short enough to be memorable.
+
+! Your task has been made easy, as the encryption key consists of three lower
+! case characters. Using cipher1.txt (right click and 'Save Link/Target
+! As...'), a file containing the encrypted ASCII codes, and the knowledge that
+! the plain text must contain common English words, decrypt the message and
+! find the sum of the ASCII values in the original text.
+
+
+! SOLUTION
+! --------
+
+! Assume that the space character will be the most common, so XOR the input
+! text with a space character then group the text into three "columns" since
+! that's how long our key is. Then do frequency analysis on each column to
+! find out what the most likely candidate is for the key.
+
+! NOTE: This technique would probably not work well in all cases, but luckily
+! it did for this particular problem.
+
+<PRIVATE
+
+: source-059 ( -- seq )
+ "extra/project-euler/059/cipher1.txt" resource-path
+ ascii file-contents [ blank? ] right-trim "," split
+ [ string>number ] map ;
+
+TUPLE: rollover seq n ;
+
+C: <rollover> rollover
+
+M: rollover length rollover-n ;
+
+M: rollover nth-unsafe rollover-seq [ length mod ] keep nth-unsafe ;
+
+INSTANCE: rollover immutable-sequence
+
+: decrypt ( seq key -- seq )
+ over length <rollover> swap [ bitxor ] 2map ;
+
+: frequency-analysis ( seq -- seq )
+ dup prune [
+ [ 2dup [ = ] curry count 2array , ] each
+ ] { } make nip ; inline
+
+: most-frequent ( seq -- elt )
+ frequency-analysis sort-values keys peek ;
+
+: crack-key ( seq key-length -- key )
+ [ " " decrypt ] dip group 1 head-slice*
+ flip [ most-frequent ] map ;
+
+PRIVATE>
+
+: euler059 ( -- answer )
+ source-059 dup 3 crack-key decrypt sum ;
+
+! [ euler059 ] 100 ave-time
+! 13 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler059
--- /dev/null
+79,59,12,2,79,35,8,28,20,2,3,68,8,9,68,45,0,12,9,67,68,4,7,5,23,27,1,21,79,85,78,79,85,71,38,10,71,27,12,2,79,6,2,8,13,9,1,13,9,8,68,19,7,1,71,56,11,21,11,68,6,3,22,2,14,0,30,79,1,31,6,23,19,10,0,73,79,44,2,79,19,6,28,68,16,6,16,15,79,35,8,11,72,71,14,10,3,79,12,2,79,19,6,28,68,32,0,0,73,79,86,71,39,1,71,24,5,20,79,13,9,79,16,15,10,68,5,10,3,14,1,10,14,1,3,71,24,13,19,7,68,32,0,0,73,79,87,71,39,1,71,12,22,2,14,16,2,11,68,2,25,1,21,22,16,15,6,10,0,79,16,15,10,22,2,79,13,20,65,68,41,0,16,15,6,10,0,79,1,31,6,23,19,28,68,19,7,5,19,79,12,2,79,0,14,11,10,64,27,68,10,14,15,2,65,68,83,79,40,14,9,1,71,6,16,20,10,8,1,79,19,6,28,68,14,1,68,15,6,9,75,79,5,9,11,68,19,7,13,20,79,8,14,9,1,71,8,13,17,10,23,71,3,13,0,7,16,71,27,11,71,10,18,2,29,29,8,1,1,73,79,81,71,59,12,2,79,8,14,8,12,19,79,23,15,6,10,2,28,68,19,7,22,8,26,3,15,79,16,15,10,68,3,14,22,12,1,1,20,28,72,71,14,10,3,79,16,15,10,68,3,14,22,12,1,1,20,28,68,4,14,10,71,1,1,17,10,22,71,10,28,19,6,10,0,26,13,20,7,68,14,27,74,71,89,68,32,0,0,71,28,1,9,27,68,45,0,12,9,79,16,15,10,68,37,14,20,19,6,23,19,79,83,71,27,11,71,27,1,11,3,68,2,25,1,21,22,11,9,10,68,6,13,11,18,27,68,19,7,1,71,3,13,0,7,16,71,28,11,71,27,12,6,27,68,2,25,1,21,22,11,9,10,68,10,6,3,15,27,68,5,10,8,14,10,18,2,79,6,2,12,5,18,28,1,71,0,2,71,7,13,20,79,16,2,28,16,14,2,11,9,22,74,71,87,68,45,0,12,9,79,12,14,2,23,2,3,2,71,24,5,20,79,10,8,27,68,19,7,1,71,3,13,0,7,16,92,79,12,2,79,19,6,28,68,8,1,8,30,79,5,71,24,13,19,1,1,20,28,68,19,0,68,19,7,1,71,3,13,0,7,16,73,79,93,71,59,12,2,79,11,9,10,68,16,7,11,71,6,23,71,27,12,2,79,16,21,26,1,71,3,13,0,7,16,75,79,19,15,0,68,0,6,18,2,28,68,11,6,3,15,27,68,19,0,68,2,25,1,21,22,11,9,10,72,71,24,5,20,79,3,8,6,10,0,79,16,8,79,7,8,2,1,71,6,10,19,0,68,19,7,1,71,24,11,21,3,0,73,79,85,87,79,38,18,27,68,6,3,16,15,0,17,0,7,68,19,7,1,71,24,11,21,3,0,71,24,5,20,79,9,6,11,1,71,27,12,21,0,17,0,7,68,15,6,9,75,79,16,15,10,68,16,0,22,11,11,68,3,6,0,9,72,16,71,29,1,4,0,3,9,6,30,2,79,12,14,2,68,16,7,1,9,79,12,2,79,7,6,2,1,73,79,85,86,79,33,17,10,10,71,6,10,71,7,13,20,79,11,16,1,68,11,14,10,3,79,5,9,11,68,6,2,11,9,8,68,15,6,23,71,0,19,9,79,20,2,0,20,11,10,72,71,7,1,71,24,5,20,79,10,8,27,68,6,12,7,2,31,16,2,11,74,71,94,86,71,45,17,19,79,16,8,79,5,11,3,68,16,7,11,71,13,1,11,6,1,17,10,0,71,7,13,10,79,5,9,11,68,6,12,7,2,31,16,2,11,68,15,6,9,75,79,12,2,79,3,6,25,1,71,27,12,2,79,22,14,8,12,19,79,16,8,79,6,2,12,11,10,10,68,4,7,13,11,11,22,2,1,68,8,9,68,32,0,0,73,79,85,84,79,48,15,10,29,71,14,22,2,79,22,2,13,11,21,1,69,71,59,12,14,28,68,14,28,68,9,0,16,71,14,68,23,7,29,20,6,7,6,3,68,5,6,22,19,7,68,21,10,23,18,3,16,14,1,3,71,9,22,8,2,68,15,26,9,6,1,68,23,14,23,20,6,11,9,79,11,21,79,20,11,14,10,75,79,16,15,6,23,71,29,1,5,6,22,19,7,68,4,0,9,2,28,68,1,29,11,10,79,35,8,11,74,86,91,68,52,0,68,19,7,1,71,56,11,21,11,68,5,10,7,6,2,1,71,7,17,10,14,10,71,14,10,3,79,8,14,25,1,3,79,12,2,29,1,71,0,10,71,10,5,21,27,12,71,14,9,8,1,3,71,26,23,73,79,44,2,79,19,6,28,68,1,26,8,11,79,11,1,79,17,9,9,5,14,3,13,9,8,68,11,0,18,2,79,5,9,11,68,1,14,13,19,7,2,18,3,10,2,28,23,73,79,37,9,11,68,16,10,68,15,14,18,2,79,23,2,10,10,71,7,13,20,79,3,11,0,22,30,67,68,19,7,1,71,8,8,8,29,29,71,0,2,71,27,12,2,79,11,9,3,29,71,60,11,9,79,11,1,79,16,15,10,68,33,14,16,15,10,22,73\r
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files math.parser namespaces project-euler.common sequences splitting ;
+USING: io.files math.parser namespaces project-euler.common
+io.encodings.ascii sequences splitting ;
IN: project-euler.067
! http://projecteuler.net/index.php?section=problems&id=67
: source-067 ( -- seq )
"extra/project-euler/067/triangle.txt" resource-path
- file-lines [ " " split [ string>number ] map ] map ;
+ ascii file-lines [ " " split [ string>number ] map ] map ;
PRIVATE>
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables io.files kernel math math.parser namespaces sequences ;
+USING: assocs hashtables io.files kernel math math.parser namespaces
+io.encodings.ascii sequences ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
<PRIVATE
: source-079 ( -- seq )
- "extra/project-euler/079/keylog.txt" resource-path file-lines ;
+ "extra/project-euler/079/keylog.txt" resource-path ascii file-lines ;
: >edges ( seq -- seq )
[
project-euler.033 project-euler.034 project-euler.035 project-euler.036
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
- project-euler.045 project-euler.046 project-euler.048 project-euler.052
- project-euler.053 project-euler.056 project-euler.067 project-euler.075
- project-euler.079 project-euler.092 project-euler.097 project-euler.134
- project-euler.169 project-euler.173 project-euler.175 ;
+ project-euler.045 project-euler.046 project-euler.047 project-euler.048
+ project-euler.052 project-euler.053 project-euler.056 project-euler.059
+ project-euler.067 project-euler.075 project-euler.079 project-euler.092
+ project-euler.097 project-euler.134 project-euler.169 project-euler.173
+ project-euler.175 ;
IN: project-euler
<PRIVATE
{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
{ $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." }
{ $examples
- { $example "IN: promises LAZY: my-add ( a b -- c ) + ;\n1 2 my-add force ." "3" }
+ { $example "USING: math prettyprint promises ;" "LAZY: my-add ( a b -- c ) + ;" "1 2 my-add force ." "3" }
}
{ $see-also force promise-with promise-with2 } ;
USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors ;
+prettyprint quotations random sequences vectors
+compiler.units ;
USING: random-tester.databank random-tester.safe-words ;
IN: random-tester
: method-words
{
- method-def
forget-word
} ;
USING: kernel math random namespaces sequences tools.test ;
-IN: temporary
+IN: random.tests
: check-random ( max -- ? )
dup >r random 0 r> between? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
- listener ;
+ listener io.encodings.utf8 ;
: tty-listener ( tty -- )
- dup <file-reader> [
- swap <file-writer> [
+ dup utf8 <file-reader> [
+ swap utf8 <file-writer> [
<duplex-stream> [
listener
] with-stream
[ f ] [ "foo bar" "foo\\B bar" f <regexp> matches? ] unit-test
[ t ] [ "fooxbar" "foo\\Bxbar" f <regexp> matches? ] unit-test
[ f ] [ "foo" "foo\\Bbar" f <regexp> matches? ] unit-test
+
+[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
+[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
+[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
"(" ")" surrounded-by ;
: 'range' ( -- parser )
- any-char-parser "-" token <& any-char-parser <&>
+ [ CHAR: ] = not ] satisfy "-" token <&
+ [ CHAR: ] = not ] satisfy <&>
[ first2 char-between?-quot ] <@ ;
: 'character-class-term' ( -- parser )
--- /dev/null
+Regular expressions
--- /dev/null
+USING: kernel peg regexp2 sequences tools.test ;
+IN: regexp2.tests
+
+[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ]
+ [ "056" 'octal' parse ] unit-test
--- /dev/null
+USING: assocs combinators.lib kernel math math.parser
+namespaces peg unicode.case sequences unicode.categories
+memoize peg.parsers ;
+USE: io
+USE: tools.walker
+IN: regexp2
+
+<PRIVATE
+
+SYMBOL: ignore-case?
+
+: char=-quot ( ch -- quot )
+ ignore-case? get
+ [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
+ curry ;
+
+: char-between?-quot ( ch1 ch2 -- quot )
+ ignore-case? get
+ [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+ [ [ between? ] ]
+ if 2curry ;
+
+: or-predicates ( quots -- quot )
+ [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+
+: literal-action [ nip ] curry action ;
+
+: delay-action [ curry ] curry action ;
+
+PRIVATE>
+
+: ascii? ( n -- ? )
+ 0 HEX: 7f between? ;
+
+: octal-digit? ( n -- ? )
+ CHAR: 0 CHAR: 7 between? ;
+
+: hex-digit? ( n -- ? )
+ {
+ [ dup digit? ]
+ [ dup CHAR: a CHAR: f between? ]
+ [ dup CHAR: A CHAR: F between? ]
+ } || nip ;
+
+: control-char? ( n -- ? )
+ { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ;
+
+: punct? ( n -- ? )
+ "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
+: c-identifier-char? ( ch -- ? )
+ { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ;
+
+: java-blank? ( n -- ? )
+ {
+ CHAR: \s
+ CHAR: \t CHAR: \n CHAR: \r
+ HEX: c HEX: 7 HEX: 1b
+ } member? ;
+
+: java-printable? ( n -- ? )
+ { [ dup alpha? ] [ dup punct? ] } || nip ;
+
+MEMO: 'ordinary-char' ( -- parser )
+ [ "\\^*+?|(){}[$" member? not ] satisfy
+ [ char=-quot ] action ;
+
+MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
+
+MEMO: 'octal' ( -- parser )
+ "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq
+ [ first oct> ] action ;
+
+MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
+
+MEMO: 'hex' ( -- parser )
+ "x" token hide 'hex-digit' 2 exactly-n 2seq
+ "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice
+ [ first hex> ] action ;
+
+: satisfy-tokens ( assoc -- parser )
+ [ >r token r> literal-action ] { } assoc>map choice ;
+
+MEMO: 'simple-escape-char' ( -- parser )
+ {
+ { "\\" CHAR: \\ }
+ { "t" CHAR: \t }
+ { "n" CHAR: \n }
+ { "r" CHAR: \r }
+ { "f" HEX: c }
+ { "a" HEX: 7 }
+ { "e" HEX: 1b }
+ } [ char=-quot ] assoc-map satisfy-tokens ;
+
+MEMO: 'predefined-char-class' ( -- parser )
+ {
+ { "d" [ digit? ] }
+ { "D" [ digit? not ] }
+ { "s" [ java-blank? ] }
+ { "S" [ java-blank? not ] }
+ { "w" [ c-identifier-char? ] }
+ { "W" [ c-identifier-char? not ] }
+ } satisfy-tokens ;
+
+MEMO: 'posix-character-class' ( -- parser )
+ {
+ { "Lower" [ letter? ] }
+ { "Upper" [ LETTER? ] }
+ { "ASCII" [ ascii? ] }
+ { "Alpha" [ Letter? ] }
+ { "Digit" [ digit? ] }
+ { "Alnum" [ alpha? ] }
+ { "Punct" [ punct? ] }
+ { "Graph" [ java-printable? ] }
+ { "Print" [ java-printable? ] }
+ { "Blank" [ " \t" member? ] }
+ { "Cntrl" [ control-char? ] }
+ { "XDigit" [ hex-digit? ] }
+ { "Space" [ java-blank? ] }
+ } satisfy-tokens "p{" "}" surrounded-by ;
+
+MEMO: 'simple-escape' ( -- parser )
+ [
+ 'octal' ,
+ 'hex' ,
+ "c" token hide [ LETTER? ] satisfy 2seq ,
+ any-char ,
+ ] choice* [ char=-quot ] action ;
+
+MEMO: 'escape' ( -- parser )
+ "\\" token hide [
+ 'simple-escape-char' ,
+ 'predefined-char-class' ,
+ 'posix-character-class' ,
+ 'simple-escape' ,
+ ] choice* 2seq ;
+
+MEMO: 'any-char' ( -- parser )
+ "." token [ drop t ] literal-action ;
+
+MEMO: 'char' ( -- parser )
+ 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ;
+
+DEFER: 'regexp'
+
+TUPLE: group-result str ;
+
+C: <group-result> group-result
+
+MEMO: 'non-capturing-group' ( -- parser )
+ "?:" token hide 'regexp' ;
+
+MEMO: 'positive-lookahead-group' ( -- parser )
+ "?=" token hide 'regexp' [ ensure ] action ;
+
+MEMO: 'negative-lookahead-group' ( -- parser )
+ "?!" token hide 'regexp' [ ensure-not ] action ;
+
+MEMO: 'simple-group' ( -- parser )
+ 'regexp' [ [ <group-result> ] action ] action ;
+
+MEMO: 'group' ( -- parser )
+ [
+ 'non-capturing-group' ,
+ 'positive-lookahead-group' ,
+ 'negative-lookahead-group' ,
+ 'simple-group' ,
+ ] choice* "(" ")" surrounded-by ;
+
+MEMO: 'range' ( -- parser )
+ any-char "-" token hide any-char 3seq
+ [ first2 char-between?-quot ] action ;
+
+MEMO: 'character-class-term' ( -- parser )
+ 'range'
+ 'escape'
+ [ "\\]" member? not ] satisfy [ char=-quot ] action
+ 3choice ;
+
+MEMO: 'positive-character-class' ( -- parser )
+ ! todo
+ "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq
+ 'character-class-term' repeat1 2choice [ or-predicates ] action ;
+
+MEMO: 'negative-character-class' ( -- parser )
+ "^" token hide 'positive-character-class' 2seq
+ [ [ not ] append ] action ;
+
+MEMO: 'character-class' ( -- parser )
+ 'negative-character-class' 'positive-character-class' 2choice
+ "[" "]" surrounded-by [ satisfy ] action ;
+
+MEMO: 'escaped-seq' ( -- parser )
+ any-char repeat1
+ [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ;
+
+MEMO: 'break' ( quot -- parser )
+ satisfy ensure
+ epsilon just 2choice ;
+
+MEMO: 'break-escape' ( -- parser )
+ "$" token [ "\r\n" member? ] 'break' literal-action
+ "\\b" token [ blank? ] 'break' literal-action
+ "\\B" token [ blank? not ] 'break' literal-action
+ "\\z" token epsilon just literal-action 4choice ;
+
+MEMO: 'simple' ( -- parser )
+ [
+ 'escaped-seq' ,
+ 'break-escape' ,
+ 'group' ,
+ 'character-class' ,
+ 'char' ,
+ ] choice* ;
+
+MEMO: 'exactly-n' ( -- parser )
+ 'integer' [ exactly-n ] delay-action ;
+
+MEMO: 'at-least-n' ( -- parser )
+ 'integer' "," token hide 2seq [ at-least-n ] delay-action ;
+
+MEMO: 'at-most-n' ( -- parser )
+ "," token hide 'integer' 2seq [ at-most-n ] delay-action ;
+
+MEMO: 'from-m-to-n' ( -- parser )
+ 'integer' "," token hide 'integer' 3seq
+ [ first2 from-m-to-n ] delay-action ;
+
+MEMO: 'greedy-interval' ( -- parser )
+ 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ;
+
+MEMO: 'interval' ( -- parser )
+ 'greedy-interval'
+ 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action
+ 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action
+ 3choice "{" "}" surrounded-by ;
+
+MEMO: 'repetition' ( -- parser )
+ [
+ ! Possessive
+ ! "*+" token [ <!*> ] literal-action ,
+ ! "++" token [ <!+> ] literal-action ,
+ ! "?+" token [ <!?> ] literal-action ,
+ ! Reluctant
+ ! "*?" token [ <(*)> ] literal-action ,
+ ! "+?" token [ <(+)> ] literal-action ,
+ ! "??" token [ <(?)> ] literal-action ,
+ ! Greedy
+ "*" token [ repeat0 ] literal-action ,
+ "+" token [ repeat1 ] literal-action ,
+ "?" token [ optional ] literal-action ,
+ ] choice* ;
+
+MEMO: 'dummy' ( -- parser )
+ epsilon [ ] literal-action ;
+
+! todo -- check the action
+! MEMO: 'term' ( -- parser )
+ ! 'simple'
+ ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action
+ ! <!+> [ <and-parser> ] action ;
+
-USING: rss io kernel io.files tools.test ;
+USING: rss io kernel io.files tools.test io.encodings.utf8 ;
+IN: rss.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- <file-reader> read-feed ;
+ utf8 <file-reader> read-feed ;
[ T{
feed
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces semantic-db ;
+IN: semantic-db.context
+
+: create-context* ( context-name -- context-id ) create-node* ;
+: create-context ( context-name -- ) create-context* drop ;
+
+: context ( -- context-id )
+ \ context get ;
+
+: set-context ( context-id -- )
+ \ context set ;
+
+: with-context ( context-id quot -- )
+ >r \ context r> with-variable ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db.tuples kernel new-slots semantic-db
+semantic-db.relations sorting sequences sequences.deep ;
+IN: semantic-db.hierarchy
+
+TUPLE: tree id children ;
+C: <tree> tree
+
+: has-parent-relation ( -- relation-id )
+ "has parent" relation-id ;
+
+: parent-child* ( parent child -- arc-id )
+ has-parent-relation spin create-arc* ;
+
+: parent-child ( parent child -- )
+ parent-child* drop ;
+
+: un-parent-child ( parent child -- )
+ has-parent-relation spin <arc> select-tuples [ id>> delete-arc ] each ;
+
+: child-arcs ( node-id -- child-arcs )
+ has-parent-relation f rot <arc> select-tuples ;
+
+: children ( node-id -- children )
+ child-arcs [ subject>> ] map ;
+
+: parent-arcs ( node-id -- parent-arcs )
+ has-parent-relation swap f <arc> select-tuples ;
+
+: parents ( node-id -- parents )
+ parent-arcs [ object>> ] map ;
+
+: get-node-hierarchy ( node-id -- tree )
+ dup children [ get-node-hierarchy ] map <tree> ;
+
+: uniq ( sorted-seq -- seq )
+ f swap [ tuck = not ] subset nip ;
+
+: (get-root-nodes) ( node-id -- root-nodes/node-id )
+ dup parents dup empty? [
+ drop
+ ] [
+ nip [ (get-root-nodes) ] map
+ ] if ;
+
+: get-root-nodes ( node-id -- root-nodes )
+ (get-root-nodes) flatten natural-sort uniq ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: db.types kernel namespaces semantic-db semantic-db.context
+sequences.lib ;
+IN: semantic-db.relations
+
+! relations:
+! - have a context in context 'semantic-db'
+
+: create-relation* ( context-id relation-name -- relation-id )
+ create-node* tuck has-context-relation spin create-arc ;
+
+: create-relation ( context-id relation-name -- )
+ create-relation* drop ;
+
+: get-relation ( context-id relation-name -- relation-id/f )
+ [
+ ":name" TEXT param ,
+ ":context" INTEGER param ,
+ has-context-relation ":has_context" INTEGER param ,
+ ] { } make
+ "select n.id from node n, arc a where n.content = :name and n.id = a.subject and a.relation = :has_context and a.object = :context"
+ single-int-results ?first ;
+
+: relation-id ( relation-name -- relation-id )
+ context swap [ get-relation ] [ create-relation* ] ensure2 ;
--- /dev/null
+USING: accessors arrays continuations db db.sqlite db.tuples io.files
+kernel math namespaces semantic-db semantic-db.context
+semantic-db.hierarchy semantic-db.relations sequences tools.test
+tools.walker ;
+IN: semantic-db.tests
+
+: db-path "semantic-db-test.db" temp-file ;
+: test-db db-path sqlite-db ;
+: delete-db [ db-path delete-file ] ignore-errors ;
+
+delete-db
+
+test-db [
+ create-node-table create-arc-table
+ [ 1 ] [ "first node" create-node* ] unit-test
+ [ 2 ] [ "second node" create-node* ] unit-test
+ [ 3 ] [ "third node" create-node* ] unit-test
+ [ 4 ] [ f create-node* ] unit-test
+ [ 5 ] [ 1 2 3 create-arc* ] unit-test
+] with-db
+
+delete-db
+
+test-db [
+ init-semantic-db
+ "test content" create-context* [
+ [ 4 ] [ context ] unit-test
+ [ 5 ] [ context "is test content" create-relation* ] unit-test
+ [ 5 ] [ context "is test content" get-relation ] unit-test
+ [ 5 ] [ "is test content" relation-id ] unit-test
+ [ 7 ] [ "has parent" relation-id ] unit-test
+ [ 7 ] [ "has parent" relation-id ] unit-test
+ [ "has parent" ] [ "has parent" relation-id node-content ] unit-test
+ [ "test content" ] [ context node-content ] unit-test
+ ] with-context
+ ! type-type 1array [ "type" ensure-type ] unit-test
+ ! [ { 1 2 3 } ] [ type-type select-nodes-of-type ] unit-test
+ ! [ 1 ] [ type-type select-node-of-type ] unit-test
+ ! [ t ] [ "content" ensure-type integer? ] unit-test
+ ! [ t ] [ "content" ensure-type "content" ensure-type = ] unit-test
+ ! [ t ] [ "content" ensure-type "first content" create-node-of-type integer? ] unit-test
+ ! [ t ] [ "content" ensure-type select-node-of-type integer? ] unit-test
+ ! [ t ] [ "content" ensure-type "first content" select-node-of-type-with-content integer? ] unit-test
+ ! [ t ] [ "content" ensure-type "first content" ensure-node-of-type integer? ] unit-test
+ ! [ t ] [ "content" ensure-type "second content" ensure-node-of-type integer? ] unit-test
+ ! [ 2 ] [ "content" ensure-type select-nodes-of-type length ] unit-test
+] with-db
+
+delete-db
+
+! test hierarchy
+test-db [
+ init-semantic-db
+ "family tree" create-context* [
+ "adam" create-node* "adam" set
+ "eve" create-node* "eve" set
+ "bob" create-node* "bob" set
+ "fran" create-node* "fran" set
+ "charlie" create-node* "charlie" set
+ "gertrude" create-node* "gertrude" set
+ [ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
+ { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
+ [ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
+ [ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ "charlie" get get-root-nodes [ node-content ] map ] unit-test
+ [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
+ ] with-context
+] with-db
+
+delete-db
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
+IN: semantic-db
+
+TUPLE: node id content ;
+: <node> ( content -- node )
+ node construct-empty swap >>content ;
+
+: <id-node> ( id -- node )
+ node construct-empty swap >>id ;
+
+node "node"
+{
+ { "id" "id" +native-id+ +autoincrement+ }
+ { "content" "content" TEXT }
+} define-persistent
+
+: create-node-table ( -- )
+ node create-table ;
+
+: delete-node ( node-id -- )
+ <id-node> delete-tuple ;
+
+: create-node* ( str -- node-id )
+ <node> dup insert-tuple id>> ;
+
+: create-node ( str -- )
+ create-node* drop ;
+
+: node-content ( id -- str )
+ f <node> swap >>id select-tuple content>> ;
+
+TUPLE: arc id relation subject object ;
+
+: <arc> ( relation subject object -- arc )
+ arc construct-empty swap >>object swap >>subject swap >>relation ;
+
+: <id-arc> ( id -- arc )
+ arc construct-empty swap >>id ;
+
+: insert-arc ( arc -- )
+ f <node> dup insert-tuple id>> >>id insert-tuple ;
+
+: delete-arc ( arc-id -- )
+ dup delete-node <id-arc> delete-tuple ;
+
+: create-arc* ( relation subject object -- arc-id )
+ <arc> dup insert-arc id>> ;
+
+: create-arc ( relation subject object -- )
+ create-arc* drop ;
+
+arc "arc"
+{
+ { "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
+ { "relation" "relation" INTEGER +not-null+ }
+ { "subject" "subject" INTEGER +not-null+ }
+ { "object" "object" INTEGER +not-null+ }
+} define-persistent
+
+: create-arc-table ( -- )
+ arc create-table ;
+
+: create-bootstrap-nodes ( -- )
+ "semantic-db" create-node
+ "has context" create-node ;
+
+: semantic-db-context 1 ;
+: has-context-relation 2 ;
+
+: create-bootstrap-arcs ( -- )
+ has-context-relation has-context-relation semantic-db-context create-arc ;
+
+: init-semantic-db ( -- )
+ create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
+
+: param ( value key type -- param )
+ swapd 3array ;
+
+: single-int-results ( bindings sql -- array )
+ f f <simple-statement> [ do-bound-query ] with-disposal
+ [ first string>number ] map ;
+
+: ensure2 ( x y quot1 quot2 -- z )
+ #! quot1 ( x y -- z/f ) finds an existing z
+ #! quot2 ( x y -- z ) creates a new z if quot1 returns f
+ >r >r 2dup r> call [ 2nip ] r> if* ;
+
USING: sequences.deep kernel tools.test strings math arrays
namespaces sequences ;
+IN: sequences.deep.tests
[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
: deep-contains? ( obj quot -- ? ) deep-find* nip ; inline
+: deep-all? ( obj quot -- ? )
+ [ not ] compose deep-contains? not ; inline
+
: deep-change-each ( obj quot -- )
over branch? [ [
[ call ] keep over >r deep-change-each r>
"passed to the quotation given to map-withn for each element in the sequence."\r
} \r
{ $examples\r
- { $example "USE: combinators.lib" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }\r
+ { $example "USING: math sequences.lib prettyprint ;" "1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn .s" "{ 16 17 18 19 20 }" }\r
}\r
{ $see-also each-withn } ;\r
\r
{ $description "Like map sum, but without creating an intermediate sequence." }\r
{ $example\r
"! Find the sum of the squares [0,99]"\r
- "USING: math.ranges combinators.lib ;"\r
+ "USING: math math.ranges sequences.lib prettyprint ;"\r
"100 [1,b] [ sq ] sigma ."\r
"338350"\r
} ;\r
{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }\r
{ $description "Efficiently returns the number of elements that the predicate quotation matches." }\r
{ $example\r
- "USING: math.ranges combinators.lib ;"\r
+ "USING: math math.ranges sequences.lib prettyprint ;"\r
"100 [1,b] [ even? ] count ."\r
"50"\r
} ;\r
USING: arrays kernel sequences sequences.lib math math.functions math.ranges
tools.test strings ;
-IN: temporary
+IN: sequences.lib.tests
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
-
[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-MACRO: nfirst ( n -- )
- [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
+MACRO: firstn ( n -- )
+ [ [ swap nth ] curry
+ [ keep ] curry ] map concat [ drop ] compose ;
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
: strings ( alphabet length -- seqs )
>r dup length r> number-strings map-alphabet ;
-: nths ( nths seq -- subseq )
- ! nths is a sequence of ones and zeroes
+: switches ( seq1 seq -- subseq )
+ ! seq1 is a sequence of ones and zeroes
>r [ length ] keep [ nth 1 = ] curry subset r>
[ nth ] curry { } map-as ;
: power-set ( seq -- subsets )
- 2 over length exact-number-strings swap [ nths ] curry map ;
+ 2 over length exact-number-strings swap [ switches ] curry map ;
: push-either ( elt quot accum1 accum2 -- )
>r >r keep swap r> r> ? push ; inline
: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
+USE: continuations
+: ?subseq ( from to seq -- subseq )
+ >r >r 0 max r> r>
+ [ length tuck min >r min r> ] keep subseq ;
+
+: ?head* ( seq n -- seq/f ) (head) ?subseq ;
+: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
+
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ;
: attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline
+
+: ?nth* ( n seq -- elt/f ? )
+ 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
+
+: nths ( indices seq -- seq' )
+ [ swap nth ] with map ;
<PRIVATE
+: iterate-seq >r dup length swap r> ; inline
+
: (map-next) ( i seq quot -- )
! this uses O(n) more bounds checks than is really necessary
>r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline
USING: help.syntax help.markup ;
IN: serialize
-HELP: (serialize)
-{ $values { "obj" "object to serialize" }
-}
-{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." }
-{ $examples
- { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
-}
-{ $see-also deserialize (deserialize) serialize with-serialized } ;
-
-HELP: (deserialize)
-{ $values { "obj" "deserialized object" }
-}
-{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." }
-{ $examples
- { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
-}
-{ $see-also (serialize) deserialize serialize with-serialized } ;
-
-HELP: with-serialized
-{ $values { "quot" "a quotation" }
-}
-{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." }
-{ $examples
- { $example "USING: serialize io.streams.string ;" "[\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-string-writer\n\n[\n [ (deserialize) (deserialize) ] with-serialized\n] with-string-reader eq? ." "t" }
-}
-{ $see-also (serialize) (deserialize) serialize deserialize } ;
-
HELP: serialize
{ $values { "obj" "object to serialize" }
}
{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained." }
{ $examples
- { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" }
+ { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" }
}
-{ $see-also deserialize (deserialize) (serialize) with-serialized } ;
+{ $see-also deserialize } ;
HELP: deserialize
{ $values { "obj" "deserialized object" }
}
{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained." }
{ $examples
- { $example "USING: serialize io.streams.string ;" "[ { 1 2 } serialize ] with-string-writer\n\n[ deserialize ] with-string-reader ." "{ 1 2 }" }
+ { $example "USING: serialize io.encodings.binary io.streams.byte-array prettyprint ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" }
}
-{ $see-also (serialize) deserialize (deserialize) with-serialized } ;
+{ $see-also serialize } ;
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: tools.test kernel serialize io io.streams.string math
+USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
-classes math.constants ;
-IN: temporary
+classes math.constants io.encodings.binary random
+combinators.lib ;
+IN: serialize.tests
+
+: test-serialize-cell
+ 2^ random dup
+ binary [ serialize-cell ] with-byte-writer
+ binary [ deserialize-cell ] with-byte-reader = ;
+
+[ t ] [
+ 100 [
+ drop
+ {
+ [ 40 [ test-serialize-cell ] all? ]
+ [ 4 [ 40 * test-serialize-cell ] all? ]
+ [ 4 [ 400 * test-serialize-cell ] all? ]
+ [ 4 [ 4000 * test-serialize-cell ] all? ]
+ } &&
+ ] all?
+] unit-test
TUPLE: serialize-test a b ;
{ 1 2 "three" }
V{ 1 2 "three" }
SBUF" hello world"
+ "hello \u123456 unicode"
\ dup
[ \ dup dup ]
T{ serialize-test f "a" 2 }
: check-serialize-1 ( obj -- ? )
dup class .
- dup [ serialize ] with-string-writer
- [ deserialize ] with-string-reader = ;
+ dup
+ binary [ serialize ] with-byte-writer
+ binary [ deserialize ] with-byte-reader = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
] [
dup class .
dup 2array
- [ serialize ] with-string-writer
- [ deserialize ] with-string-reader
+ binary [ serialize ] with-byte-writer
+ binary [ deserialize ] with-byte-reader
first2 eq?
] if ;
[ t ] [ objects [ check-serialize-2 ] all? ] unit-test
[ t ] [ pi check-serialize-1 ] unit-test
-
-[ t ] [
- { 1 2 3 } [
- [
- dup (serialize) (serialize)
- ] with-serialized
- ] with-string-writer [
- deserialize-sequence all-eq?
- ] with-string-reader
-] unit-test
+[ serialize ] must-infer
+[ deserialize ] must-infer
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs tuples arrays
vectors byte-arrays bit-arrays quotations hashtables
-assocs help.syntax help.markup float-arrays splitting ;
+assocs help.syntax help.markup float-arrays splitting
+io.encodings.string io.encodings.utf8 combinators new-slots
+accessors ;
-! Variable holding a sequence of objects already serialized
+! Variable holding a assoc of objects already serialized
SYMBOL: serialized
-: add-object ( obj -- id )
+TUPLE: id obj ;
+
+C: <id> id
+
+M: id hashcode* obj>> hashcode* ;
+
+M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ;
+
+: add-object ( obj -- )
#! Add an object to the sequence of already serialized
- #! objects. Return the id of that object.
- serialized get [ push ] keep length 1 - ;
+ #! objects.
+ serialized get [ assoc-size swap <id> ] keep set-at ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
- serialized get [ eq? ] with find [ drop f ] unless ;
-
-USE: prettyprint
+ <id> serialized get at ;
! Serialize object
GENERIC: (serialize) ( obj -- )
-: serialize-cell 8 >be write ;
+! Numbers are serialized as follows:
+! 0 => B{ 0 }
+! 1<=x<=126 => B{ x | 0x80 }
+! x>127 => B{ length(x) x[0] x[1] ... }
+! x>2^1024 => B{ 0xff length(x) x[0] x[1] ... }
+! The last case is needed because a very large number would
+! otherwise be confused with a small number.
+: serialize-cell ( n -- )
+ dup zero? [ drop 0 write1 ] [
+ dup HEX: 7e <= [
+ HEX: 80 bitor write1
+ ] [
+ dup log2 8 /i 1+
+ dup HEX: 7f >= [
+ HEX: ff write1
+ dup serialize-cell
+ ] [
+ dup write1
+ ] if
+ >be write
+ ] if
+ ] if ;
-: deserialize-cell 8 read be> ;
+: deserialize-cell ( -- n )
+ read1 {
+ { [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
+ { [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
+ { [ t ] [ read be> ] }
+ } cond ;
: serialize-shared ( obj quot -- )
>r dup object-id
- [ "o" write serialize-cell drop ] r> if* ; inline
+ [ CHAR: o write1 serialize-cell drop ] r> if* ; inline
M: f (serialize) ( obj -- )
- drop "n" write ;
-
-: bytes-needed ( number -- int )
- log2 8 + 8 /i ; inline
+ drop CHAR: n write1 ;
M: integer (serialize) ( obj -- )
- dup 0 = [
- drop "z" write
+ dup zero? [
+ drop CHAR: z write1
] [
- dup 0 < [ neg "m" ] [ "p" ] if write
- dup bytes-needed dup serialize-cell
- >be write
+ dup 0 < [ neg CHAR: m ] [ CHAR: p ] if write1
+ serialize-cell
] if ;
M: float (serialize) ( obj -- )
- "F" write
+ CHAR: F write1
double>bits serialize-cell ;
M: complex (serialize) ( obj -- )
- "c" write
+ CHAR: c write1
dup real-part (serialize)
imaginary-part (serialize) ;
M: ratio (serialize) ( obj -- )
- "r" write
+ CHAR: r write1
dup numerator (serialize)
denominator (serialize) ;
+: serialize-string ( obj code -- )
+ write1
+ dup utf8 encode dup length serialize-cell write
+ add-object ;
+
M: string (serialize) ( obj -- )
- [
- "s" write
- dup add-object serialize-cell
- dup length serialize-cell
- write
- ] serialize-shared ;
+ [ CHAR: s serialize-string ] serialize-shared ;
-M: sbuf (serialize) ( obj -- )
- [
- "S" write
- dup add-object serialize-cell
- dup length serialize-cell
- >string write
- ] serialize-shared ;
+: serialize-elements ( seq -- )
+ [ (serialize) ] each CHAR: . write1 ;
M: tuple (serialize) ( obj -- )
[
- "T" write
- dup add-object serialize-cell
- tuple>array
- dup length serialize-cell
- [ (serialize) ] each
+ CHAR: T write1
+ dup tuple>array serialize-elements
+ add-object
] serialize-shared ;
: serialize-seq ( seq code -- )
[
- write
- dup add-object serialize-cell
- dup length serialize-cell
- [ (serialize) ] each
+ write1
+ dup serialize-elements
+ add-object
] curry serialize-shared ;
M: array (serialize) ( obj -- )
- "a" serialize-seq ;
-
-M: vector (serialize) ( obj -- )
- "v" serialize-seq ;
+ CHAR: a serialize-seq ;
M: byte-array (serialize) ( obj -- )
- "A" serialize-seq ;
+ [
+ CHAR: A write1
+ dup dup length serialize-cell write
+ add-object
+ ] serialize-shared ;
M: bit-array (serialize) ( obj -- )
- "b" serialize-seq ;
-
-M: quotation (serialize) ( obj -- )
- "q" serialize-seq ;
-
-M: curry (serialize) ( obj -- )
[
- "C" write
- dup add-object serialize-cell
- dup curry-obj (serialize) curry-quot (serialize)
+ CHAR: b write1
+ dup length serialize-cell
+ dup [ 1 0 ? ] B{ } map-as write
+ add-object
] serialize-shared ;
+M: quotation (serialize) ( obj -- )
+ CHAR: q serialize-seq ;
+
M: float-array (serialize) ( obj -- )
[
- "f" write
- dup add-object serialize-cell
+ CHAR: f write1
dup length serialize-cell
- [ double>bits 8 >be write ] each
+ dup [ double>bits 8 >be write ] each
+ add-object
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
[
- "h" write
- dup add-object serialize-cell
- >alist (serialize)
+ CHAR: h write1
+ dup >alist (serialize)
+ add-object
] serialize-shared ;
M: word (serialize) ( obj -- )
- "w" write
- dup word-name (serialize)
- word-vocabulary (serialize) ;
+ [
+ CHAR: w write1
+ dup word-name (serialize)
+ dup word-vocabulary (serialize)
+ add-object
+ ] serialize-shared ;
M: wrapper (serialize) ( obj -- )
- "W" write
+ CHAR: W write1
wrapped (serialize) ;
DEFER: (deserialize) ( -- obj )
-: intern-object ( id obj -- obj )
- dup rot serialized get set-nth ;
+SYMBOL: deserialized
+
+: intern-object ( obj -- )
+ deserialized get push ;
: deserialize-false ( -- f )
f ;
: deserialize-positive-integer ( -- number )
- deserialize-cell read be> ;
+ deserialize-cell ;
: deserialize-negative-integer ( -- number )
deserialize-positive-integer neg ;
: deserialize-complex ( -- complex )
(deserialize) (deserialize) rect> ;
-: deserialize-string ( -- string )
- deserialize-cell deserialize-cell read intern-object ;
+: (deserialize-string) ( -- string )
+ deserialize-cell read utf8 decode ;
-: deserialize-sbuf ( -- sbuf )
- deserialize-cell deserialize-cell read >sbuf intern-object ;
+: deserialize-string ( -- string )
+ (deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup
- [ ] [ "Unknown word" throw ] ?if ;
+ [ dup intern-object ] [ "Unknown word" throw ] ?if ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
+SYMBOL: +stop+
+
+: (deserialize-seq) ( -- seq )
+ [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
+
: deserialize-seq ( seq -- array )
- deserialize-cell deserialize-cell
- [ drop (deserialize) ] roll map-as
- intern-object ;
+ >r (deserialize-seq) r> like dup intern-object ;
: deserialize-array ( -- array )
{ } deserialize-seq ;
-: deserialize-vector ( -- array )
- V{ } deserialize-seq ;
-
: deserialize-quotation ( -- array )
[ ] deserialize-seq ;
+: (deserialize-byte-array) ( -- byte-array )
+ deserialize-cell read B{ } like ;
+
: deserialize-byte-array ( -- byte-array )
- B{ } deserialize-seq ;
+ (deserialize-byte-array) dup intern-object ;
: deserialize-bit-array ( -- bit-array )
- ?{ } deserialize-seq ;
+ (deserialize-byte-array) [ 0 > ] ?{ } map-as
+ dup intern-object ;
: deserialize-float-array ( -- float-array )
- deserialize-cell deserialize-cell
+ deserialize-cell
8 * read 8 <groups> [ be> bits>double ] F{ } map-as
- intern-object ;
+ dup intern-object ;
: deserialize-hashtable ( -- hashtable )
- deserialize-cell (deserialize) >hashtable intern-object ;
+ (deserialize) >hashtable dup intern-object ;
: deserialize-tuple ( -- array )
- deserialize-cell
- deserialize-cell [ drop (deserialize) ] map >tuple
- intern-object ;
-
-: deserialize-curry ( -- curry )
- deserialize-cell
- (deserialize) (deserialize) curry
- intern-object ;
+ (deserialize-seq) >tuple dup intern-object ;
: deserialize-unknown ( -- object )
- deserialize-cell serialized get nth ;
+ deserialize-cell deserialized get nth ;
+
+: deserialize-stop ( -- object )
+ +stop+ get ;
: deserialize* ( -- object ? )
read1 [
- H{
- { CHAR: A deserialize-byte-array }
- { CHAR: C deserialize-curry }
- { CHAR: F deserialize-float }
- { CHAR: S deserialize-sbuf }
- { CHAR: T deserialize-tuple }
- { CHAR: W deserialize-wrapper }
- { CHAR: a deserialize-array }
- { CHAR: b deserialize-bit-array }
- { CHAR: c deserialize-complex }
- { CHAR: f deserialize-float-array }
- { CHAR: h deserialize-hashtable }
- { CHAR: m deserialize-negative-integer }
- { CHAR: n deserialize-false }
- { CHAR: o deserialize-unknown }
- { CHAR: p deserialize-positive-integer }
- { CHAR: q deserialize-quotation }
- { CHAR: r deserialize-ratio }
- { CHAR: s deserialize-string }
- { CHAR: v deserialize-vector }
- { CHAR: w deserialize-word }
- { CHAR: z deserialize-zero }
- } at dup [ "Unknown typecode" throw ] unless execute t
+ {
+ { CHAR: A [ deserialize-byte-array ] }
+ { CHAR: F [ deserialize-float ] }
+ { CHAR: T [ deserialize-tuple ] }
+ { CHAR: W [ deserialize-wrapper ] }
+ { CHAR: a [ deserialize-array ] }
+ { CHAR: b [ deserialize-bit-array ] }
+ { CHAR: c [ deserialize-complex ] }
+ { CHAR: f [ deserialize-float-array ] }
+ { CHAR: h [ deserialize-hashtable ] }
+ { CHAR: m [ deserialize-negative-integer ] }
+ { CHAR: n [ deserialize-false ] }
+ { CHAR: o [ deserialize-unknown ] }
+ { CHAR: p [ deserialize-positive-integer ] }
+ { CHAR: q [ deserialize-quotation ] }
+ { CHAR: r [ deserialize-ratio ] }
+ { CHAR: s [ deserialize-string ] }
+ { CHAR: w [ deserialize-word ] }
+ { CHAR: z [ deserialize-zero ] }
+ { CHAR: . [ deserialize-stop ] }
+ } case t
] [
f f
] if* ;
: (deserialize) ( -- obj )
deserialize* [ "End of stream" throw ] unless ;
-: with-serialized ( quot -- )
- V{ } clone serialized rot with-variable ; inline
-
-: deserialize-sequence ( -- seq )
- [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ;
-
: deserialize ( -- obj )
- [ (deserialize) ] with-serialized ;
+ [
+ V{ } clone deserialized set
+ gensym +stop+ set
+ (deserialize)
+ ] with-scope ;
: serialize ( obj -- )
- [ (serialize) ] with-serialized ;
\ No newline at end of file
+ [
+ H{ } clone serialized set
+ (serialize)
+ ] with-scope ;
\ No newline at end of file
"placed on the top of the stack."
}
{ $examples
- { $example "USE: shuffle" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
+ { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
}
{ $see-also dup over pick } ;
"placed on the top of the stack."
}
{ $examples
- { $example "USE: shuffle" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
+ { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
}
{ $see-also dup 2dup 3dup } ;
"for any number of items."
}
{ $examples
- { $example "USE: shuffle" "1 2 3 4 3 nnip .s" "4" }
+ { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" }
}
{ $see-also nip 2nip } ;
"for any number of items."
}
{ $examples
- { $example "USE: shuffle" "1 2 3 4 3 ndrop .s" "1" }
+ { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" }
}
{ $see-also drop 2drop 3drop } ;
"number of items on the stack. "
}
{ $examples
- { $example "USE: shuffle" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
+ { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
}
{ $see-also rot -nrot } ;
"number of items on the stack. "
}
{ $examples
- { $example "USE: shuffle" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
+ { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
}
{ $see-also rot nrot } ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax kernel words ;
+IN: singleton
+
+HELP: SINGLETON:
+{ $syntax "SINGLETON: class"
+} { $values
+ { "class" "a new singleton to define" }
+} { $description
+ "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
+} { $examples
+ { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+} { $see-also
+ POSTPONE: PREDICATE:
+} ;
+
+HELP: SINGLETONS:
+{ $syntax "SINGLETONS: classes... ;"
+} { $values
+ { "classes" "new singletons to define" }
+} { $description
+ "Defines a new singleton for each class in the list."
+} { $examples
+ { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" }
+} { $see-also
+ POSTPONE: SINGLETON:
+} ;
--- /dev/null
+USING: kernel singleton tools.test ;
+IN: singleton.tests
+
+[ ] [ SINGLETON: bzzt ] unit-test
+[ t ] [ bzzt bzzt? ] unit-test
+[ t ] [ bzzt bzzt eq? ] unit-test
+GENERIC: zammo ( obj -- )
+[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
+[ "yes!" ] [ bzzt zammo ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.predicate kernel namespaces parser quotations
+sequences words ;
+IN: singleton
+
+: define-singleton ( token -- )
+ \ word swap create-class-in
+ dup [ eq? ] curry define-predicate-class ;
+
+: SINGLETON:
+ scan define-singleton ; parsing
+
+: SINGLETONS:
+ ";" parse-tokens [ define-singleton ] each ; parsing
--- /dev/null
+
+USING: kernel namespaces sequences
+ io io.files io.launcher io.encodings.ascii
+ bake builder.util
+ accessors vars
+ math.parser ;
+
+IN: size-of
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: headers
+
+: include-headers ( -- seq )
+ headers> [ { "#include <" , ">" } bake to-string ] map ;
+
+: size-of-c-program ( type -- lines )
+ {
+ "#include <stdio.h>"
+ include-headers
+ { "main() { printf( \"%i\" , sizeof( " , " ) ) ; }" }
+ }
+ bake to-strings ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: c-file ( -- path ) "size-of.c" temp-file ;
+
+: exe ( -- path ) "size-of" temp-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: size-of ( type -- n )
+ size-of-c-program c-file ascii set-file-lines
+
+ { "gcc" c-file "-o" exe } to-strings
+ [ "Error compiling generated C program" print ] run-or-bail
+
+ exe ascii <process-stream> contents string>number ;
\ No newline at end of file
: stylesheet
H{
- { default-style
+ { default-span-style
H{
{ font "sans-serif" }
{ font-size 36 }
+ }
+ }
+ { default-block-style
+ H{
{ wrap-margin 1000 }
}
}
! Copyright (C) 2007 Elie CHAFTARI
! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel prettyprint io io.timeouts io.server
+sequences namespaces io.sockets continuations calendar io.encodings.ascii ;
+IN: smtp.server
! Mock SMTP server for testing purposes.
-! Usage: 4321 smtp-server
+! Usage: 4321 mock-smtp-server
! $ telnet 127.0.0.1 4321
! Trying 127.0.0.1...
! Connected to localhost.
! bye
! Connection closed by foreign host.
-USING: combinators kernel prettyprint io io.timeouts io.server
-sequences namespaces io.sockets continuations ;
-IN: smtp.server
-
SYMBOL: data-mode
: process ( -- )
] }
} cond nip [ process ] when ;
-: smtp-server ( port -- )
+: mock-smtp-server ( port -- )
"Starting SMTP server on port " write dup . flush
- "127.0.0.1" swap <inet4> <server> [
+ "127.0.0.1" swap <inet4> ascii <server> [
accept [
- 60000 stdio get set-timeout
+ 1 minutes stdio get set-timeout
"220 hello\r\n" write flush
process
global [ flush ] bind
-USING: smtp tools.test io.streams.string threads
-smtp.server kernel sequences namespaces logging ;
-IN: temporary
+USING: smtp tools.test io.streams.string io.sockets threads
+smtp.server kernel sequences namespaces logging accessors
+assocs sorting ;
+IN: smtp.tests
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ { "hello" "." "world" } validate-message ] must-fail
[ "hello\r\nworld\r\n.\r\n" ] [
- { "hello" "world" } [ send-body ] with-string-writer
+ "hello\nworld" [ send-body ] with-string-writer
] unit-test
[ "500 syntax error" check-response ] must-fail
] must-fail
[
- V{
- { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
+ {
{ "From" "Doug <erg@factorcode.org>" }
{ "Subject" "Factor rules" }
+ { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
}
{ "slava@factorcode.org" "dharmatech@factorcode.org" }
"erg@factorcode.org"
] [
- "Factor rules"
- {
- "Slava <slava@factorcode.org>"
- "Ed <dharmatech@factorcode.org>"
- }
- "Doug <erg@factorcode.org>"
- simple-headers >r >r 2 head* r> r>
-] unit-test
-
-[
- {
- "To: Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>"
- "From: Doug <erg@factorcode.org>"
- "Subject: Factor rules"
- f
- f
- ""
- "Hi guys"
- "Bye guys"
- }
- { "slava@factorcode.org" "dharmatech@factorcode.org" }
- "erg@factorcode.org"
-] [
- "Hi guys\nBye guys"
- "Factor rules"
- {
- "Slava <slava@factorcode.org>"
- "Ed <dharmatech@factorcode.org>"
- }
- "Doug <erg@factorcode.org>"
- prepare-simple-message
- >r >r f 3 pick set-nth f 4 pick set-nth r> r>
+ <email>
+ "Factor rules" >>subject
+ {
+ "Slava <slava@factorcode.org>"
+ "Ed <dharmatech@factorcode.org>"
+ } >>to
+ "Doug <erg@factorcode.org>" >>from
+ prepare
+ dup headers>> >alist sort-keys [
+ drop { "Date" "Message-Id" } member? not
+ ] assoc-subset
+ over to>>
+ rot from>>
] unit-test
-[ ] [ [ 4321 smtp-server ] in-thread ] unit-test
+[ ] [ [ 4321 mock-smtp-server ] in-thread ] unit-test
[ ] [
[
- 4321 smtp-port set
-
- "Hi guys\nBye guys"
- "Factor rules"
- {
- "Slava <slava@factorcode.org>"
- "Ed <dharmatech@factorcode.org>"
- }
- "Doug <erg@factorcode.org>"
-
- send-simple-message
+ "localhost" 4321 <inet> smtp-server set
+
+ <email>
+ "Hi guys\nBye guys" >>body
+ "Factor rules" >>subject
+ {
+ "Slava <slava@factorcode.org>"
+ "Ed <dharmatech@factorcode.org>"
+ } >>to
+ "Doug <erg@factorcode.org>" >>from
+ send-email
] with-scope
-] unit-test
\ No newline at end of file
+] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
-math.parser random system calendar ;
-
+math.parser random system calendar io.encodings.ascii
+calendar.format new-slots accessors ;
IN: smtp
SYMBOL: smtp-domain
-SYMBOL: smtp-host "localhost" smtp-host set-global
-SYMBOL: smtp-port 25 smtp-port set-global
-SYMBOL: read-timeout 60000 read-timeout set-global
+SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
+SYMBOL: read-timeout 1 minutes read-timeout set-global
SYMBOL: esmtp t esmtp set-global
-: log-smtp-connection ( host port -- ) 2drop ;
-
-\ log-smtp-connection NOTICE add-input-logging
+LOG: log-smtp-connection NOTICE ( addrspec -- )
: with-smtp-connection ( quot -- )
- smtp-host get smtp-port get
- 2dup log-smtp-connection
- <inet> <client> [
+ smtp-server get
+ dup log-smtp-connection
+ ascii <client> [
smtp-domain [ host-name or ] change
read-timeout get stdio get set-timeout
call
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
- dup [ "\r\n>" member? ] contains?
- [ "Bad e-mail address: " swap append throw ] when ;
+ dup "\r\n>" seq-intersect empty?
+ [ "Bad e-mail address: " swap append throw ] unless ;
: mail-from ( fromaddr -- )
"MAIL FROM:<" write validate-address write ">" write crlf ;
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
: send-body ( body -- )
+ string-lines
validate-message
[ write crlf ] each
"." write crlf ;
: get-ok ( -- ) flush receive-response check-response ;
-: send-raw-message ( body to from -- )
+: validate-header ( string -- string' )
+ dup "\r\n" seq-intersect empty?
+ [ "Invalid header string: " swap append throw ] unless ;
+
+: write-header ( key value -- )
+ swap
+ validate-header write
+ ": " write
+ validate-header write
+ crlf ;
+
+: write-headers ( assoc -- )
+ [ write-header ] assoc-each ;
+
+TUPLE: email from to subject headers body ;
+
+M: email clone
+ (clone) [ clone ] change-headers ;
+
+: (send) ( email -- )
[
helo get-ok
- mail-from get-ok
- [ rcpt-to get-ok ] each
+ dup from>> mail-from get-ok
+ dup to>> [ rcpt-to get-ok ] each
data get-ok
- send-body get-ok
+ dup headers>> write-headers
+ crlf
+ body>> send-body get-ok
quit get-ok
] with-smtp-connection ;
-: validate-header ( string -- string' )
- dup [ "\r\n" member? ] contains?
- [ "Invalid header string: " swap append throw ] when ;
-
-: prepare-header ( key value -- )
- swap
- validate-header %
- ": " %
- validate-header % ;
-
-: prepare-headers ( assoc -- )
- [ [ prepare-header ] "" make , ] assoc-each ;
-
: extract-email ( recepient -- email )
#! This could be much smarter.
- " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
+ " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
: message-id ( -- string )
[
">" %
] "" make ;
-: simple-headers ( subject to from -- headers to from )
- [
- >r dup ", " join "To" set [ extract-email ] map r>
- dup "From" set extract-email
- rot "Subject" set
- now timestamp>rfc822-string "Date" set
- message-id "Message-Id" set
- ] { } make-assoc -rot ;
-
-: prepare-message ( body headers -- body' )
- [
- prepare-headers
- "" ,
- dup string? [ string-lines ] when %
- ] { } make ;
+: set-header ( email value key -- email )
+ pick headers>> set-at ;
-: prepare-simple-message ( body subject to from -- body' to from )
- simple-headers >r >r prepare-message r> r> ;
+: prepare ( email -- email )
+ clone
+ dup from>> "From" set-header
+ [ extract-email ] change-from
+ dup to>> ", " join "To" set-header
+ [ [ extract-email ] map ] change-to
+ dup subject>> "Subject" set-header
+ now timestamp>rfc822-string "Date" set-header
+ message-id "Message-Id" set-header ;
-: send-message ( body headers to from -- )
- >r >r prepare-message r> r> send-raw-message ;
+: <email> ( -- email )
+ email construct-empty
+ H{ } clone >>headers ;
-: send-simple-message ( body subject to from -- )
- prepare-simple-message send-raw-message ;
+: send-email ( email -- )
+ prepare (send) ;
! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
! CRAM MD5, and the old code didn't work properly either, so here
! (cram-md5-auth) "\r\n" append get-ok ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: new-slots
-
-TUPLE: email from to subject body ;
-
-: <email> ( -- email ) email construct-empty ;
-
-: send ( email -- )
- { email-body email-subject email-to email-from } get-slots
- send-simple-message ;
\ No newline at end of file
!
USING: cpu.8080 cpu.8080.emulator openal math alien.c-types
sequences kernel shuffle arrays io.files combinators ui.gestures
-ui.gadgets ui.render opengl.gl system threads match
-ui byte-arrays combinators.lib ;
+ui.gadgets ui.render opengl.gl system match
+ui byte-arrays combinators.lib qualified ;
+QUALIFIED: threads
IN: space-invaders
TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
: sync-frame ( millis -- millis )
#! Sleep until the time for the next frame arrives.
1000 60 / >fixnum + millis - dup 0 >
- [ sleep ] [ drop yield ] if millis ;
+ [ threads:sleep ] [ drop threads:yield ] if millis ;
: invaders-process ( millis gadget -- )
#! Run a space invaders gadget inside a
dup invaders-gadget-cpu init-sounds
f over set-invaders-gadget-quit?
[ millis swap invaders-process ] curry
- "Space invaders" spawn drop ;
+ "Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- )
t swap set-invaders-gadget-quit? ;
--- /dev/null
+USING: kernel sequences strings.lib tools.test ;
+IN: temporary
+
+[ "abcdefghijklmnopqrstuvwxyz" ] [ lower-alpha-chars "" like ] unit-test
+[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
+[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
+[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
+[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
--- /dev/null
+USING: math arrays sequences kernel random splitting strings unicode.case ;
+IN: strings.lib
+
+: char>digit ( c -- i ) 48 - ;
+
+: string>digits ( s -- seq ) [ char>digit ] { } map-as ;
+
+: >Upper ( str -- str )
+ dup empty? [
+ unclip ch>upper 1string swap append
+ ] unless ;
+
+: >Upper-dashes ( str -- str )
+ "-" split [ >Upper ] map "-" join ;
+
+: lower-alpha-chars ( -- seq )
+ 26 [ CHAR: a + ] map ;
+
+: upper-alpha-chars ( -- seq )
+ 26 [ CHAR: A + ] map ;
+
+: numeric-chars ( -- seq )
+ 10 [ CHAR: 0 + ] map ;
+
+: alpha-chars ( -- seq )
+ lower-alpha-chars upper-alpha-chars append ;
+
+: alphanumeric-chars ( -- seq )
+ alpha-chars numeric-chars append ;
+
+: random-alpha-char ( -- ch )
+ alpha-chars random ;
+
+: random-alphanumeric-char ( -- ch )
+ alphanumeric-chars random ;
+
+: random-alphanumeric-string ( length -- str )
+ [ drop random-alphanumeric-char ] map "" like ;
+
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax ;
+IN: symbols
+
+HELP: SYMBOLS:
+{ $syntax "SYMBOLS: words... ;" }
+{ $values { "words" "a sequence of new words to define" } }
+{ $description "Creates a new word for every token until the ';'." }
+{ $examples { $example "USING: prettyprint symbols ;" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } }
+{ $see-also POSTPONE: SYMBOL: } ;
--- /dev/null
+USING: kernel symbols tools.test ;
+IN: symbols.tests
+
+[ ] [ SYMBOLS: a b c ; ] unit-test
+[ a ] [ a ] unit-test
+[ b ] [ b ] unit-test
+[ c ] [ c ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser sequences words ;
+IN: symbols
+
+: SYMBOLS:
+ ";" parse-tokens [ create-in define-symbol ] each ;
+ parsing
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
-hexdump tools.interpreter ;
+hexdump io.encodings.binary ;
IN: tar
: zero-checksum 256 ;
! Normal file
: typeflag-0
- tar-header-name tar-path+ <file-writer>
+ tar-header-name tar-path+ binary <file-writer>
[ read-data-blocks ] keep dispose ;
! Hard link
] when* ;
: parse-tar ( path -- obj )
- [
+ binary [
"tar-test" resource-path base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind
USING: kernel money taxes tools.test ;
-IN: temporary
+IN: taxes.tests
[
426 23
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds
-ui.gadgets.status-bar ui.gestures ui.render ui tetris.game
-tetris.gl sequences arrays math math.parser namespaces timers ;
+USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
+ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
+tetris.game tetris.gl sequences system math math.parser namespaces ;
IN: tetris
-TUPLE: tetris-gadget tetris ;
+TUPLE: tetris-gadget tetris alarm ;
: <tetris-gadget> ( tetris -- gadget )
tetris-gadget construct-gadget
{ T{ key-down f f "n" } [ new-tetris ] }
} set-gestures
-M: tetris-gadget tick ( object -- )
+: tick ( gadget -- )
dup tetris-gadget-tetris maybe-update relayout-1 ;
M: tetris-gadget graft* ( gadget -- )
- 100 1 add-timer ;
+ dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm
+ swap set-tetris-gadget-alarm ;
M: tetris-gadget ungraft* ( gadget -- )
- remove-timer ;
+ [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ;
: tetris-window ( -- )
[
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Simple low-resolution timers
+++ /dev/null
-USING: help.syntax help.markup classes kernel ;
-IN: timers
-
-HELP: init-timers
-{ $description "Initializes the timer code." }
-{ $notes "This word is automatically called when the UI is initialized, and it should only be called manually if timers are being used outside of the UI." } ;
-
-HELP: tick
-{ $values { "object" object } }
-{ $description "Called to notify an object registered with a timer that the timer has fired." } ;
-
-HELP: add-timer
-{ $values { "object" object } { "delay" "a positive integer" } { "initial" "a positive integer" } }
-{ $description "Registers a timer. Every " { $snippet "delay" } " milliseconds, " { $link tick } " will be called on the object. The initial delay from the time " { $link add-timer } " is called to when " { $link tick } " is first called is " { $snippet "initial" } " milliseconds." } ;
-
-HELP: remove-timer
-{ $values { "object" object } }
-{ $description "Unregisters a timer." } ;
-
-HELP: do-timers
-{ $description "Fires all registered timers which are due to fire." }
-{ $notes "This word is automatically called from the UI event loop, and it should only be called manually if timers are being used outside of the UI." } ;
-
-{ init-timers add-timer remove-timer tick do-timers } related-words
-
-ARTICLE: "timers" "Timers"
-"Timers can be added and removed:"
-{ $subsection add-timer }
-{ $subsection remove-timer }
-"Classes must implement a generic word so that their instances can handle timer ticks:"
-{ $subsection tick }
-"Timers can be used outside of the UI, however they must be initialized with an explicit call, and fired manually:"
-{ $subsection init-timers }
-{ $subsection do-timers } ;
-
-ABOUT: "timers"
+++ /dev/null
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math namespaces sequences system ;
-IN: timers
-
-TUPLE: timer object delay next ;
-
-: <timer> ( object delay initial -- timer )
- millis + timer construct-boa ;
-
-GENERIC: tick ( object -- )
-
-: timers \ timers get-global ;
-
-: init-timers ( -- ) H{ } clone \ timers set-global ;
-
-: add-timer ( object delay initial -- )
- pick >r <timer> r> timers set-at ;
-
-: remove-timer ( object -- ) timers delete-at ;
-
-: advance-timer ( ms timer -- )
- [ timer-delay + ] keep set-timer-next ;
-
-: do-timer ( ms timer -- )
- dup timer-next pick <=
- [ [ advance-timer ] keep timer-object tick ] [ 2drop ] if ;
-
-: do-timers ( -- )
- millis timers values [ do-timer ] with each ;
USING: tools.test tools.annotations math parser ;
-IN: temporary
+IN: tools.annotations.tests
: foo ;
\ foo watch
[ 4 ] [ 3 some-generic ] unit-test
-[ ] [ "IN: temporary USE: math M: integer some-generic 1- ;" eval ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects definitions compiler.units
-namespaces assocs ;
+namespaces assocs tools.walker ;
IN: tools.annotations
: reset ( word -- )
dupd [ (watch-vars) ] 2curry annotate ;
: breakpoint ( word -- )
- [ \ break add* ] annotate ;
+ [ add-breakpoint ] annotate ;
: breakpoint-if ( word quot -- )
[ [ [ break ] when ] rot 3append ] curry annotate ;
-IN: temporary
+IN: tools.browser.tests
USING: tools.browser tools.test help.markup ;
[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces splitting sequences io.files kernel assocs
words vocabs vocabs.loader definitions parser continuations
-inspector debugger io io.styles io.streams.lines hashtables
+inspector debugger io io.styles hashtables
sorting prettyprint source-files arrays combinators strings
system math.parser help.markup help.topics help.syntax
-help.stylesheet memoize ;
+help.stylesheet memoize io.encodings.utf8 ;
IN: tools.browser
MEMO: (vocab-file-contents) ( path -- lines )
?resource-path dup exists?
- [ file-lines ] [ drop f ] if ;
+ [ utf8 file-lines ] [ drop f ] if ;
: vocab-file-contents ( vocab name -- seq )
vocab-path+ dup [ (vocab-file-contents) ] when ;
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-path+ [
- ?resource-path
- [ [ print ] each ] with-file-writer
+ ?resource-path utf8 set-file-lines
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
{ $values { "seq" "a sequence of integers" } { "newseq" "a sequence of sequences of integers" } }
{ $description "Groups subsequences of consecutive integers." }
{ $examples
- { $example "USE: tools.completion" "{ 1 2 3 5 6 9 10 } runs ." "V{ V{ 1 2 3 } V{ 5 6 } V{ 9 10 } }" }
+ { $example "USING: prettyprint tools.completion ;" "{ 1 2 3 5 6 9 10 } runs ." "V{ V{ 1 2 3 } V{ 5 6 } V{ 9 10 } }" }
} ;
HELP: score
USING: math kernel sequences io.files tools.crossref tools.test
-parser namespaces source-files ;
-IN: temporary
+parser namespaces source-files generic definitions ;
+IN: tools.crossref.tests
GENERIC: foo
M: integer foo + ;
-"resource:extra/tools/test/foo.factor" run-file
+"resource:extra/tools/crossref/test/foo.factor" run-file
-[ t ] [ { integer foo } \ + smart-usage member? ] unit-test
-[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test
+[ t ] [ integer \ foo method \ + usage member? ] unit-test
+[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
sorting hashtables vocabs parser source-files ;
IN: tools.crossref
-: synopsis-alist ( definitions -- alist )
- [ dup synopsis swap ] { } map>assoc ;
-
-: definitions. ( alist -- )
- [ write-object nl ] assoc-each ;
-
: usage. ( word -- )
- smart-usage synopsis-alist sort-keys definitions. ;
+ usage sorted-definitions. ;
: words-matching ( str -- seq )
all-words [ dup word-name ] { } map>assoc completions ;
--- /dev/null
+USE: tools.crossref.tests
+USE: kernel
+
+1 2 foo drop
inspector layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.streams.duplex io.files io.backend
quotations io.launcher words.private tools.deploy.config
-bootstrap.image ;
+bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
: (copy-lines) ( stream -- )
[ (copy-lines) ] with-disposal ;
: run-with-output ( arguments -- )
- [
- +arguments+ set
- +stdout+ +stderr+ set
- ] H{ } make-assoc <process-stream>
- dup duplex-stream-out dispose
+ <process>
+ swap >>command
+ +stdout+ >>stderr
+ +closed+ >>stdin
+ utf8 <process-stream>
dup copy-lines
- process-stream-process wait-for-process zero? [
+ process>> wait-for-process zero? [
"Deployment failed" throw
] unless ;
] { } make ;
: run-factor ( vm flags -- )
- dup . swap add* run-with-output ; inline
+ swap add* dup . run-with-output ; inline
: make-staging-image ( vm config -- )
staging-command-line run-factor ;
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
+HELP: deploy-threads?
+{ $description "Deploy flag. If set, the deployed image will contain support for threads."
+$nl
+"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
+
HELP: deploy-compiler?
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
$nl
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
+SYMBOL: deploy-threads?
SYMBOL: deploy-io
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
+ { deploy-threads? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
--- /dev/null
+IN: tools.deploy.tests\r
+USING: tools.test system io.files kernel tools.deploy.config\r
+tools.deploy.backend math ;\r
+\r
+: shake-and-bake\r
+ "." resource-path [\r
+ vm\r
+ "hello.image" temp-file\r
+ rot dup deploy-config make-deploy-image\r
+ ] with-directory ;\r
+\r
+[ ] [ "hello-world" shake-and-bake ] unit-test\r
+\r
+[ t ] [\r
+ "hello.image" temp-file file-length 500000 <=\r
+] unit-test\r
+\r
+[ ] [ "hello-ui" shake-and-bake ] unit-test\r
+\r
+[ t ] [\r
+ "hello.image" temp-file file-length 2000000 <=\r
+] unit-test\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.launcher kernel namespaces sequences
+USING: io io.files kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
-hashtables prettyprint io.unix.backend cocoa
+hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
cocoa.application cocoa.classes cocoa.plists qualified ;
-QUALIFIED: unix
IN: tools.deploy.macosx
-: touch ( path -- )
- { "touch" } swap add try-process ;
-
-: rm ( path -- )
- { "rm" "-rf" } swap add try-process ;
-
: bundle-dir ( -- dir )
vm parent-directory parent-directory ;
-: copy-bundle-dir ( name dir -- )
+: copy-bundle-dir ( bundle-name dir -- )
bundle-dir over path+ -rot
- >r "Contents" path+ r> path+ copy-directory ;
-
-: chmod ( path perms -- )
- unix:chmod io-error ;
+ "Contents" swap path+ path+ copy-tree ;
: copy-vm ( executable bundle-name -- vm )
- "Contents/MacOS/" path+ swap path+ vm swap
- [ copy-file ] keep
- [ OCT: 755 chmod ] keep ;
+ "Contents/MacOS/" path+ swap path+ vm over copy-file ;
: copy-fonts ( name -- )
"fonts/" resource-path
- swap "Contents/Resources/fonts/" path+ copy-directory ;
+ swap "Contents/Resources/" path+ copy-tree-into ;
-: print-app-plist ( executable bundle-name -- )
+: app-plist ( executable bundle-name -- string )
[
namespace {
{ "CFBundleInfoDictionaryVersion" "6.0" }
dup "CFBundleExecutable" set
"org.factor." swap append "CFBundleIdentifier" set
- ] H{ } make-assoc print-plist ;
+ ] H{ } make-assoc plist>string ;
: create-app-plist ( vocab bundle-name -- )
- dup "Contents/Info.plist" path+ <file-writer>
- [ print-app-plist ] with-stream ;
+ [ app-plist ] keep
+ "Contents/Info.plist" path+
+ utf8 set-file-contents ;
: create-app-dir ( vocab bundle-name -- vm )
dup "Frameworks" copy-bundle-dir
".app deploy tool" assert.app
"." resource-path cd
dup deploy-config [
- bundle-name rm
+ bundle-name dup exists? [ delete-tree ] [ drop ] if
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
: strip-init-hooks ( -- )
"Stripping startup hooks" show
"command-line" init-hooks get delete-at
- "mallocs" init-hooks get delete-at
- strip-io? [ "io.backend" init-hooks get delete-at ] when ;
+ "libc" init-hooks get delete-at
+ deploy-threads? get [
+ "threads" init-hooks get delete-at
+ ] unless
+ native-io? [
+ "io.thread" init-hooks get delete-at
+ ] unless
+ strip-io? [
+ "io.backend" init-hooks get delete-at
+ ] when ;
: strip-debugger ( -- )
strip-debugger? [
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
+
"Saving final image" show
[ save-image-and-exit ] call-clear ;
USING: cocoa cocoa.messages cocoa.application cocoa.nibs
-assocs namespaces kernel words compiler sequences ui.cocoa ;
+assocs namespaces kernel words compiler.units sequences
+ui.cocoa ;
"stop-after-last-window?" get
global [
-USING: kernel ;
+USING: kernel threads threads.private ;
IN: debugger
: print-error die ;
: error. die ;
+
+M: thread error-in-thread ( error thread -- ) die 2drop ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files kernel namespaces sequences system
tools.deploy.backend tools.deploy.config assocs hashtables
IN: tools.deploy.windows
: copy-vm ( executable bundle-name -- vm )
- swap path+ ".exe" append vm swap [ copy-file ] keep ;
+ swap path+ ".exe" append
+ vm over copy-file ;
: copy-fonts ( bundle-name -- )
- "fonts/" resource-path
- swap "fonts/" path+ copy-directory ;
+ "fonts/" resource-path swap copy-tree-into ;
: copy-dlls ( bundle-name -- )
- {
- "freetype6.dll"
- "zlib1.dll"
- "factor-nt.dll"
- } [
- dup resource-path -rot path+ copy-file
- ] with each ;
+ { "freetype6.dll" "zlib1.dll" "factor.dll" }
+ [ resource-path ] map
+ swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
T{ windows-deploy-implementation } deploy-implementation set-global
M: windows-deploy-implementation deploy*
- "." resource-path cd
- dup deploy-config [
- [ deploy-name get create-exe-dir ] keep
- [ deploy-name get image-name ] keep
- [ namespace make-deploy-image ] keep
- open-in-explorer
- ] bind ;
+ "." resource-path [
+ dup deploy-config [
+ [ deploy-name get create-exe-dir ] keep
+ [ deploy-name get image-name ] keep
+ [ namespace make-deploy-image ] keep
+ open-in-explorer
+ ] bind
+ ] with-directory ;
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
-system math generator.fixup ;
+system math generator.fixup io.encodings.ascii accessors ;
IN: tools.disassembler
-: in-file "gdb-in.txt" resource-path ;
+: in-file "gdb-in.txt" temp-file ;
-: out-file "gdb-out.txt" resource-path ;
+: out-file "gdb-out.txt" temp-file ;
GENERIC: make-disassemble-cmd ( obj -- )
word-xt code-format - 2array make-disassemble-cmd ;
M: pair make-disassemble-cmd
- in-file [
+ in-file ascii [
"attach " write
current-process-handle number>string print
"disassemble " write
] with-file-writer ;
: run-gdb ( -- lines )
- [
- +closed+ +stdin+ set
- out-file +stdout+ set
- [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set
- ] { } make-assoc run-process drop
- out-file file-lines ;
+ <process>
+ +closed+ >>stdin
+ out-file >>stdout
+ [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
+ try-process
+ out-file ascii file-lines ;
: tabs>spaces ( str -- str' )
{ { CHAR: \t CHAR: \s } } substitute ;
-: disassemble ( word -- )
+: disassemble ( obj -- )
make-disassemble-cmd run-gdb
[ tabs>spaces ] map [ print ] each ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.interpreter kernel arrays continuations threads
-sequences namespaces ;
-IN: tools.interpreter.debug
-
-: run-interpreter ( interpreter -- )
- dup interpreter-continuation [
- dup step-into run-interpreter
- ] [
- drop
- ] if ;
-
-: quot>cont ( quot -- cont )
- [
- swap [
- continue-with
- ] curry callcc0 call stop
- ] curry callcc1 ;
-
-: init-interpreter ( quot interpreter -- )
- >r
- [ datastack "datastack" set ] compose quot>cont
- f swap 2array
- r> restore ;
-
-: test-interpreter ( quot -- )
- <interpreter>
- [ init-interpreter ] keep
- run-interpreter
- "datastack" get ;
+++ /dev/null
-USING: help.markup help.syntax kernel generic
-math hashtables quotations classes continuations ;
-IN: tools.interpreter
-
-ARTICLE: "meta-interpreter" "Meta-circular interpreter"
-"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
-$nl
-"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
-$nl
-"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
-$nl
-"Breakpoints can be inserted in user code:"
-{ $subsection break }
-"Breakpoints invoke a hook:"
-{ $subsection break-hook }
-"Single stepping with the meta-circular interpreter:"
-{ $subsection step }
-{ $subsection step-into }
-{ $subsection step-out }
-{ $subsection step-all } ;
-
-ABOUT: "meta-interpreter"
-
-HELP: interpreter
-{ $class-description "An interpreter instance." } ;
-
-HELP: step
-{ $values { "interpreter" interpreter } }
-{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
- { $list
- { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
- { "If the object is a word, then the word is executed in the single stepper's continuation atomically" }
- { "Otherwise, the object is pushed on the single stepper's data stack" }
- }
-} ;
-
-HELP: step-into
-{ $values { "interpreter" interpreter } }
-{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
- { $list
- { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
- { "If the object is a compound word, then the single stepper enters the word definition" }
- { "If the object is a primitive word or a word with special single stepper behavior, it is executed in the single stepper's continuation atomically" }
- { "Otherwise, the object is pushed on the single stepper's data stack" }
- }
-} ;
-
-HELP: step-out
-{ $values { "interpreter" interpreter } }
-{ $description "Evaluates the remainder of the current quotation in the single stepper." } ;
-
-HELP: step-all
-{ $values { "interpreter" interpreter } }
-{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ;
+++ /dev/null
-USING: tools.interpreter io io.streams.string kernel math
-math.private namespaces prettyprint sequences tools.test
-continuations math.parser threads arrays
-tools.interpreter.private tools.interpreter.debug ;
-IN: temporary
-
-[ "Ooops" throw ] break-hook set
-
-[ { } ] [
- [ ] test-interpreter
-] unit-test
-
-[ { 1 } ] [
- [ 1 ] test-interpreter
-] unit-test
-
-[ { 1 2 3 } ] [
- [ 1 2 3 ] test-interpreter
-] unit-test
-
-[ { "Yo" 2 } ] [
- [ 2 >r "Yo" r> ] test-interpreter
-] unit-test
-
-[ { 2 } ] [
- [ t [ 2 ] [ "hi" ] if ] test-interpreter
-] unit-test
-
-[ { "hi" } ] [
- [ f [ 2 ] [ "hi" ] if ] test-interpreter
-] unit-test
-
-[ { 4 } ] [
- [ 2 2 fixnum+ ] test-interpreter
-] unit-test
-
-: foo 2 2 fixnum+ ;
-
-[ { 8 } ] [
- [ foo 4 fixnum+ ] test-interpreter
-] unit-test
-
-[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
- [ C{ 1 1.5 } { } 2dup ] test-interpreter
-] unit-test
-
-[ { t } ] [
- [ 5 5 number= ] test-interpreter
-] unit-test
-
-[ { f } ] [
- [ 5 6 number= ] test-interpreter
-] unit-test
-
-[ { f } ] [
- [ "XYZ" "XYZ" mismatch ] test-interpreter
-] unit-test
-
-[ { t } ] [
- [ "XYZ" "XYZ" sequence= ] test-interpreter
-] unit-test
-
-[ { t } ] [
- [ "XYZ" "XYZ" = ] test-interpreter
-] unit-test
-
-[ { f } ] [
- [ "XYZ" "XuZ" = ] test-interpreter
-] unit-test
-
-[ { 4 } ] [
- [ 2 2 + ] test-interpreter
-] unit-test
-
-[ { } 2 ] [
- 2 "x" set [ [ 3 "x" set ] with-scope ] test-interpreter "x" get
-] unit-test
-
-[ { 3 } ] [
- [ 3 "x" set "x" get ] test-interpreter
-] unit-test
-
-[ { "hi\n" } ] [
- [ [ "hi" print ] with-string-writer ] test-interpreter
-] unit-test
-
-[ { "4\n" } ] [
- [ [ 2 2 + number>string print ] with-string-writer ] test-interpreter
-] unit-test
-
-[ { 1 2 3 } ] [
- [ { 1 2 3 } set-datastack ] test-interpreter
-] unit-test
-
-[ { 6 } ]
-[ [ 3 [ nip continue ] callcc0 2 * ] test-interpreter ] unit-test
-
-[ { 6 } ]
-[ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test
-
-[ { } ]
-[ [ [ ] [ ] recover ] test-interpreter ] unit-test
-
-[ { 6 } ]
-[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test
-
-[ { "{ 1 2 3 }\n" } ] [
- [ [ { 1 2 3 } . ] with-string-writer ] test-interpreter
-] unit-test
-
-[ { } ] [
- [ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes combinators sequences.private
-continuations continuations.private generic hashtables io kernel
-kernel.private math namespaces namespaces.private prettyprint
-quotations sequences splitting strings threads
-vectors words ;
-IN: tools.interpreter
-
-: walk ( quot -- ) \ break add* call ;
-
-TUPLE: interpreter continuation ;
-
-: <interpreter> interpreter construct-empty ;
-
-GENERIC# restore 1 ( obj interpreter -- )
-
-M: f restore
- set-interpreter-continuation ;
-
-M: continuation restore
- >r clone r> set-interpreter-continuation ;
-
-: with-interpreter-datastack ( quot interpreter -- )
- interpreter-continuation [
- continuation-data
- swap with-datastack
- ] keep set-continuation-data ; inline
-
-M: pair restore
- >r first2 r> [ restore ] keep
- >r [ nip f ] curry r> with-interpreter-datastack ;
-
-<PRIVATE
-
-: (step-into-if) ? walk ;
-
-: (step-into-dispatch)
- nth walk ;
-
-: (step-into-execute) ( word -- )
- dup "step-into" word-prop [
- call
- ] [
- dup primitive? [
- execute break
- ] [
- word-def walk
- ] if
- ] ?if ;
-
-: (step-into-continuation)
- continuation callstack over set-continuation-call break ;
-
-M: word (step-into) (step-into-execute) ;
-
-{
- { call [ walk ] }
- { (throw) [ drop walk ] }
- { execute [ (step-into-execute) ] }
- { if [ (step-into-if) ] }
- { dispatch [ (step-into-dispatch) ] }
- { continuation [ (step-into-continuation) ] }
-} [ "step-into" set-word-prop ] assoc-each
-
-{
- >n ndrop >c c>
- continue continue-with
- (continue-with) stop
-} [
- dup [ execute break ] curry
- "step-into" set-word-prop
-] each
-
-\ break [ break ] "step-into" set-word-prop
-
-! Stepping
-: change-innermost-frame ( quot interpreter -- )
- interpreter-continuation [
- continuation-call clone
- [
- dup innermost-frame-scan 1+
- swap innermost-frame-quot
- rot call
- ] keep
- [ set-innermost-frame-quot ] keep
- ] keep set-continuation-call ; inline
-
-: (step) ( interpreter quot -- )
- swap
- [ change-innermost-frame ] keep
- [ interpreter-continuation with-walker-hook ] keep
- restore ;
-
-PRIVATE>
-
-: step ( interpreter -- )
- [
- 2dup nth \ break = [
- nip
- ] [
- swap 1+ cut [ break ] swap 3append
- ] if
- ] (step) ;
-
-: step-out ( interpreter -- )
- [ nip \ break add ] (step) ;
-
-: step-into ( interpreter -- )
- [
- swap cut [
- swap % unclip literalize , \ (step-into) , %
- ] [ ] make
- ] (step) ;
-
-: step-all ( interpreter -- )
- interpreter-continuation [ (continue) ] curry in-thread ;
+++ /dev/null
-Meta-circular interpreter and single-stepper support
USING: tools.test tools.memory ;
-IN: temporary
+IN: tools.memory.tests
[ ] [ heap-stats. ] unit-test
-IN: temporary
+IN: tools.profiler.tests
USING: tools.profiler tools.test kernel memory math threads
alien tools.profiler.private sequences ;
dup <vocab-profile> write-object ;
M: method-body (profile.)
- "method" word-prop
- dup method-specializer over method-generic 2array synopsis
- swap method-generic <usage-profile> write-object ;
+ dup synopsis swap "method-generic" word-prop
+ <usage-profile> write-object ;
: counter. ( obj n -- )
[
+++ /dev/null
-USE: temporary
-USE: kernel
-
-1 2 foo drop
}
"The latter is used for vocabularies with more extensive test suites."
$nl
-"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run."
+"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested."
{ $subsection "tools.test.write" }
{ $subsection "tools.test.run" }
{ $subsection "tools.test.failure" } ;
{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-HELP: failure.
-{ $values { "failures" "an association list of unit test failures" } }
+HELP: test-failures.
+{ $values { "assoc" "an association list of unit test failures" } }
{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ;
: must-fail ( quot -- )
[ drop t ] must-fail-with ;
-: ignore-errors ( quot -- )
- [ drop ] recover ; inline
-
: (run-test) ( vocab -- )
dup vocab-source-loaded? [
- vocab-tests
- [
- "temporary" forget-vocab
- dup [ forget-source ] each
- ] with-compilation-unit
- dup [ run-file ] each
- ] when drop ;
+ vocab-tests [ run-file ] each
+ ] [ drop ] if ;
: run-test ( vocab -- failures )
V{ } clone [
-IN: temporary
+IN: tools.test.tests
USING: completion words sequences test ;
[ ] [ "swp" apropos ] unit-test
--- /dev/null
+IN: tools.threads
+USING: help.markup help.syntax threads ;
+
+HELP: threads.
+{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:"
+ { $list
+ "``running'' if the thread is the current thread"
+ "``yield'' if the thread is waiting to run"
+ { "the string given to " { $link suspend } " if the thread is suspended" }
+ }
+} ;
+
+ARTICLE: "tools.threads" "Listing threads"
+"Printing a list of running threads:"
+{ $subsection threads. } ;
+
+ABOUT: "tools.threads"
! See http://factorcode.org/license.txt for BSD license.\r
IN: tools.threads\r
USING: threads kernel prettyprint prettyprint.config\r
-io io.styles sequences assocs namespaces sorting boxes ;\r
+io io.styles sequences assocs namespaces sorting boxes\r
+heaps.private system math math.parser ;\r
\r
: thread. ( thread -- )\r
dup thread-id pprint-cell\r
- dup thread-name pprint-cell\r
- thread-state [ "Waiting for " swap append ] [ "Running" ] if*\r
- [ write ] with-cell ;\r
+ dup thread-name over [ write-object ] with-cell\r
+ dup thread-state [\r
+ [ dup self eq? "running" "yield" ? ] unless*\r
+ write\r
+ ] with-cell\r
+ [\r
+ thread-sleep-entry [\r
+ entry-key millis [-] number>string write\r
+ " ms" write\r
+ ] when*\r
+ ] with-cell ;\r
\r
: threads. ( -- )\r
standard-table-style [\r
[\r
- { "ID" "Name" "State" }\r
+ { "ID" "Name" "Waiting on" "Remaining sleep" }\r
[ [ write ] with-cell ] each\r
] with-row\r
\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises models tools.walker kernel
+sequences concurrency.messaging locals continuations
+threads namespaces namespaces.private ;
+IN: tools.walker.debug
+
+:: test-walker ( quot -- data )
+ [let | p [ <promise> ]
+ s [ f <model> ]
+ c [ f <model> ] |
+ [
+ H{ } clone >n
+ [ s c start-walker-thread p fulfill ] new-walker-hook set
+ [ drop ] show-walker-hook set
+
+ break
+
+ quot call
+ ] "Walker test" spawn drop
+
+ step-into-all
+ p ?promise
+ send-synchronous drop
+
+ detach
+ p ?promise
+ send-synchronous drop
+
+ c model-value continuation-data
+ ] ;
--- /dev/null
+Single-stepper for walking through code
--- /dev/null
+USING: tools.walker io io.streams.string kernel math
+math.private namespaces prettyprint sequences tools.test
+continuations math.parser threads arrays tools.walker.debug ;
+IN: tools.walker.tests
+
+[ { } ] [
+ [ ] test-walker
+] unit-test
+
+[ { 1 } ] [
+ [ 1 ] test-walker
+] unit-test
+
+[ { 1 2 3 } ] [
+ [ 1 2 3 ] test-walker
+] unit-test
+
+[ { "Yo" 2 } ] [
+ [ 2 >r "Yo" r> ] test-walker
+] unit-test
+
+[ { 2 } ] [
+ [ t [ 2 ] [ "hi" ] if ] test-walker
+] unit-test
+
+[ { "hi" } ] [
+ [ f [ 2 ] [ "hi" ] if ] test-walker
+] unit-test
+
+[ { 4 } ] [
+ [ 2 2 fixnum+ ] test-walker
+] unit-test
+
+: foo 2 2 fixnum+ ;
+
+[ { 8 } ] [
+ [ foo 4 fixnum+ ] test-walker
+] unit-test
+
+[ { C{ 1 1.5 } { } C{ 1 1.5 } { } } ] [
+ [ C{ 1 1.5 } { } 2dup ] test-walker
+] unit-test
+
+[ { t } ] [
+ [ 5 5 number= ] test-walker
+] unit-test
+
+[ { f } ] [
+ [ 5 6 number= ] test-walker
+] unit-test
+
+[ { f } ] [
+ [ "XYZ" "XYZ" mismatch ] test-walker
+] unit-test
+
+[ { t } ] [
+ [ "XYZ" "XYZ" sequence= ] test-walker
+] unit-test
+
+[ { t } ] [
+ [ "XYZ" "XYZ" = ] test-walker
+] unit-test
+
+[ { f } ] [
+ [ "XYZ" "XuZ" = ] test-walker
+] unit-test
+
+[ { 4 } ] [
+ [ 2 2 + ] test-walker
+] unit-test
+
+[ { 3 } ] [
+ [ [ 3 "x" set "x" get ] with-scope ] test-walker
+] unit-test
+
+[ { "hi\n" } ] [
+ [ [ "hi" print ] with-string-writer ] test-walker
+] unit-test
+
+[ { "4\n" } ] [
+ [ [ 2 2 + number>string print ] with-string-writer ] test-walker
+] unit-test
+
+[ { 1 2 3 } ] [
+ [ { 1 2 3 } set-datastack ] test-walker
+] unit-test
+
+[ { 6 } ]
+[ [ 3 [ nip continue ] callcc0 2 * ] test-walker ] unit-test
+
+[ { 6 } ]
+[ [ [ 3 swap continue-with ] callcc1 2 * ] test-walker ] unit-test
+
+[ { } ]
+[ [ [ ] [ ] recover ] test-walker ] unit-test
+
+[ { 6 } ]
+[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
+
+[ { } ] [
+ [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
+] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: threads kernel namespaces continuations combinators
+sequences math namespaces.private continuations.private
+concurrency.messaging quotations kernel.private words
+sequences.private assocs models ;
+IN: tools.walker
+
+SYMBOL: new-walker-hook ! ( -- )
+SYMBOL: show-walker-hook ! ( thread -- )
+
+! Thread local
+SYMBOL: walker-thread
+SYMBOL: walking-thread
+
+: get-walker-thread ( -- thread )
+ walker-thread tget [
+ dup show-walker-hook get call
+ ] [
+ new-walker-hook get call
+ walker-thread tget
+ ] if* ;
+
+: break ( -- )
+ continuation callstack over set-continuation-call
+
+ get-walker-thread send-synchronous {
+ { [ dup continuation? ] [ (continue) ] }
+ { [ dup quotation? ] [ call ] }
+ { [ dup not ] [ "Single stepping abandoned" throw ] }
+ } cond ;
+
+\ break t "break?" set-word-prop
+
+: walk ( quot -- quot' )
+ \ break add* [ break rethrow ] recover ;
+
+: add-breakpoint ( quot -- quot' )
+ dup [ break ] head? [ \ break add* ] unless ;
+
+: (step-into-quot) ( quot -- ) add-breakpoint call ;
+
+: (step-into-if) ? (step-into-quot) ;
+
+: (step-into-dispatch) nth (step-into-quot) ;
+
+: (step-into-execute) ( word -- )
+ dup "step-into" word-prop [
+ call
+ ] [
+ dup primitive? [
+ execute break
+ ] [
+ word-def (step-into-quot)
+ ] if
+ ] ?if ;
+
+\ (step-into-execute) t "step-into?" set-word-prop
+
+: (step-into-continuation)
+ continuation callstack over set-continuation-call break ;
+
+! Messages sent to walker thread
+SYMBOL: step
+SYMBOL: step-out
+SYMBOL: step-into
+SYMBOL: step-all
+SYMBOL: step-into-all
+SYMBOL: step-back
+SYMBOL: detach
+SYMBOL: abandon
+SYMBOL: call-in
+
+! Thread locals
+SYMBOL: walker-status
+SYMBOL: walker-continuation
+SYMBOL: walker-history
+
+SYMBOL: +running+
+SYMBOL: +suspended+
+SYMBOL: +stopped+
+SYMBOL: +detached+
+
+: change-frame ( continuation quot -- continuation' )
+ #! Applies quot to innermost call frame of the
+ #! continuation.
+ >r clone r>
+ over continuation-call clone
+ [
+ dup innermost-frame-scan 1+
+ swap innermost-frame-quot
+ rot call
+ ] keep
+ [ set-innermost-frame-quot ] keep
+ over set-continuation-call ; inline
+
+: step-msg ( continuation -- continuation' )
+ [
+ 2dup nth \ break = [
+ nip
+ ] [
+ swap 1+ cut [ break ] swap 3append
+ ] if
+ ] change-frame ;
+
+: step-out-msg ( continuation -- continuation' )
+ [ nip \ break add ] change-frame ;
+
+{
+ { call [ (step-into-quot) ] }
+ { (throw) [ drop (step-into-quot) ] }
+ { execute [ (step-into-execute) ] }
+ { if [ (step-into-if) ] }
+ { dispatch [ (step-into-dispatch) ] }
+ { continuation [ (step-into-continuation) ] }
+} [ "step-into" set-word-prop ] assoc-each
+
+{
+ >n ndrop >c c>
+ continue continue-with
+ stop yield suspend sleep (spawn)
+ suspend
+} [
+ dup [ execute break ] curry
+ "step-into" set-word-prop
+] each
+
+\ break [ break ] "step-into" set-word-prop
+
+: step-into-msg ( continuation -- continuation' )
+ [
+ swap cut [
+ swap % unclip {
+ { [ dup \ break eq? ] [ , ] }
+ { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+ { [ t ] [ , \ break , ] }
+ } cond %
+ ] [ ] make
+ ] change-frame ;
+
+: status ( -- symbol )
+ walker-status tget model-value ;
+
+: set-status ( symbol -- )
+ walker-status tget set-model ;
+
+: unassociate-thread ( -- )
+ walker-thread walking-thread tget thread-variables delete-at
+ [ ] walking-thread tget set-thread-exit-handler ;
+
+: detach-msg ( -- )
+ +detached+ set-status
+ unassociate-thread ;
+
+: keep-running ( -- )
+ +running+ set-status ;
+
+: walker-stopped ( -- )
+ +stopped+ set-status
+ [ status +stopped+ eq? ] [
+ [
+ {
+ { detach [ detach-msg ] }
+ [ drop ]
+ } case f
+ ] handle-synchronous
+ ] [ ] while ;
+
+: step-into-all-loop ( -- )
+ +running+ set-status
+ [ status +running+ eq? ] [
+ [
+ {
+ { detach [ detach-msg f ] }
+ { step [ f ] }
+ { step-out [ f ] }
+ { step-into [ f ] }
+ { step-all [ f ] }
+ { step-into-all [ f ] }
+ { step-back [ f ] }
+ { f [ +stopped+ set-status f ] }
+ [
+ dup walker-continuation tget set-model
+ step-into-msg
+ ]
+ } case
+ ] handle-synchronous
+ ] [ ] while ;
+
+: step-back-msg ( continuation -- continuation' )
+ walker-history tget dup pop*
+ empty? [ drop walker-history tget pop ] unless ;
+
+: walker-suspended ( continuation -- continuation' )
+ +suspended+ set-status
+ [ status +suspended+ eq? ] [
+ dup walker-history tget push
+ dup walker-continuation tget set-model
+ [
+ {
+ ! These are sent by the walker tool. We reply
+ ! and keep cycling.
+ { detach [ detach-msg ] }
+ ! These change the state of the thread being
+ ! interpreted, so we modify the continuation and
+ ! output f.
+ { step [ step-msg keep-running ] }
+ { step-out [ step-out-msg keep-running ] }
+ { step-into [ step-into-msg keep-running ] }
+ { step-all [ keep-running ] }
+ { step-into-all [ step-into-all-loop ] }
+ { abandon [ drop f keep-running ] }
+ ! Pass quotation to debugged thread
+ { call-in [ nip keep-running ] }
+ ! Pass previous continuation to debugged thread
+ { step-back [ step-back-msg ] }
+ } case f
+ ] handle-synchronous
+ ] [ ] while ;
+
+: walker-loop ( -- )
+ +running+ set-status
+ [ status +detached+ eq? not ] [
+ [
+ {
+ { detach [ detach-msg f ] }
+ ! ignore these commands while the thread is
+ ! running
+ { step [ f ] }
+ { step-out [ f ] }
+ { step-into [ f ] }
+ { step-all [ f ] }
+ { step-into-all [ step-into-all-loop f ] }
+ { step-back [ f ] }
+ { abandon [ f ] }
+ { f [ walker-stopped f ] }
+ ! thread hit a breakpoint and sent us the
+ ! continuation, so we modify it and send it
+ ! back.
+ [ walker-suspended ]
+ } case
+ ] handle-synchronous
+ ] [ ] while ;
+
+: associate-thread ( walker -- )
+ walker-thread tset
+ [ f walker-thread tget send-synchronous drop ]
+ self set-thread-exit-handler ;
+
+: start-walker-thread ( status continuation -- thread' )
+ self [
+ walking-thread tset
+ walker-continuation tset
+ walker-status tset
+ V{ } clone walker-history tset
+ walker-loop
+ ] 3curry
+ "Walker on " self thread-name append spawn
+ [ associate-thread ] keep ;
USING: kernel tools.test trees trees.avl math random sequences assocs ;
-IN: temporary
+IN: trees.avl.tests
[ "key1" 0 "key2" 0 ] [
T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
DEFER: avl-set
: avl-insert ( value key node -- node taller? )
- 2dup node-key key< left right ? [
+ 2dup node-key before? left right ? [
[ node-link avl-set ] keep swap
>r tuck set-node-link r>
[ dup current-side get change-balance balance-insert ] [ f ] if
] with-side ;
: (avl-set) ( value key node -- node taller? )
- 2dup node-key key= [
+ 2dup node-key = [
-rot pick set-node-key over set-node-value f
] [ avl-insert ] if ;
{ $description "Creates an empty splay tree" } ;
HELP: >splay
-{ $values { "assoc" assoc } { "splay" splay } }
+{ $values { "assoc" assoc } { "tree" splay } }
{ $description "Converts any " { $link assoc } " into an splay tree." } ;
HELP: splay
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test trees.splay math namespaces assocs
sequences random ;
-IN: temporary
+IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
100 [ drop 100 random swap at drop ] with each ;
TUPLE: splay ;
-: <splay> ( -- splay-tree )
+: <splay> ( -- tree )
\ splay construct-tree ;
INSTANCE: splay tree-mixin
M: splay new-assoc
2drop <splay> ;
-: >splay ( assoc -- splay-tree )
+: >splay ( assoc -- tree )
T{ splay T{ tree f f 0 } } assoc-clone-like ;
: SPLAY{
USING: trees assocs tools.test kernel sequences ;
-IN: temporary
+IN: trees.tests
: test-tree ( -- tree )
TREE{
#! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
<=> sgn ;
-: key< ( k1 k2 -- ? ) <=> 0 < ;
-: key> ( k1 k2 -- ? ) <=> 0 > ;
-: key= ( k1 k2 -- ? ) <=> zero? ;
-
: random-side ( -- side ) left right 2array random ;
: choose-branch ( key node -- key node-left/right )
: node-at* ( key node -- value ? )
[
- 2dup node-key key= [
+ 2dup node-key = [
nip node-value t
] [
choose-branch node-at*
: valid-node? ( node -- ? )
[
- dup dup node-left [ node-key swap node-key key< ] when* >r
- dup dup node-right [ node-key swap node-key key> ] when* r> and swap
+ dup dup node-left [ node-key swap node-key before? ] when* >r
+ dup dup node-right [ node-key swap node-key after? ] when* r> and swap
dup node-left valid-node? swap node-right valid-node? and and
] [ t ] if* ;
--- /dev/null
+Alex Chapman
--- /dev/null
+triggers allow you to register code to be 'triggered'
--- /dev/null
+USING: triggers kernel tools.test ;
+IN: triggers.tests
+
+SYMBOL: test-trigger
+test-trigger reset-trigger
+: add-test-trigger test-trigger add-trigger ;
+[ ] [ test-trigger call-trigger ] unit-test
+[ "op called" ] [ "op" [ "op called" ] add-test-trigger test-trigger call-trigger ] unit-test
+[ "first called" "second called" ] [
+ test-trigger reset-trigger
+ "second op" [ "second called" ] add-test-trigger
+ "first op" [ "first called" ] add-test-trigger
+ test-trigger call-trigger
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs digraphs kernel namespaces sequences ;
+IN: triggers
+
+: triggers ( -- triggers )
+ \ triggers global [ drop H{ } clone ] cache ;
+
+: trigger-graph ( trigger -- graph )
+ triggers [ drop <digraph> ] cache ;
+
+: reset-trigger ( trigger -- )
+ <digraph> swap triggers set-at ;
+
+: add-trigger ( key quot trigger -- )
+ #! trigger should be a symbol. Note that symbols with the same name but
+ #! different vocab are not equal
+ trigger-graph add-vertex ;
+
+: before ( key1 key2 trigger -- )
+ trigger-graph add-edge ;
+
+: after ( key1 key2 trigger -- )
+ swapd before ;
+
+: call-trigger ( trigger -- )
+ trigger-graph topological-sorted-values [ call ] each ;
+
-USING: listener io.server ;
+USING: listener io.server io.encodings.utf8 ;
IN: tty-server
: tty-server ( port -- )
local-server
"tty-server"
- [ listener ] with-server ;
+ utf8 [ listener ] with-server ;
: default-tty-server 9999 tty-server ;
-MAIN: default-tty-server
\ No newline at end of file
+MAIN: default-tty-server
USING: tuple-arrays sequences tools.test namespaces kernel math ;
+IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
USING: tools.test tuple-syntax ;
-IN: temporary
+IN: tuple-syntax.tests
TUPLE: foo bar baz ;
{ $values { "class" "a tuple class" } }
{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
{ $example
- "USE: tuples.lib"
+ "USING: kernel prettyprint tuples.lib ;"
"TUPLE: foo a b c ;"
"1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
"1\n2\n3"
{ $values { "class" "a tuple class" } }
{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
{ $example
- "USE: tuples.lib"
+ "USING: kernel prettyprint tuples.lib ;"
"TUPLE: foo a bb* ccc dddd* ;"
"1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
"2\n4"
USING: kernel tools.test tuples.lib ;
-IN: temporary
+IN: tuples.lib.tests
TUPLE: foo a b* c d* e f* ;
HOOK: (close-window) ui-backend ( handle -- )
-HOOK: raise-window ui-backend ( world -- )
+HOOK: raise-window* ui-backend ( world -- )
HOOK: select-gl-context ui-backend ( handle -- )
: event-loop ( -- )
event-loop? [
[
- [ NSApp do-events ui-step 10 sleep ] ui-try
+ [ NSApp do-events ui-wait ] ui-try
] with-autorelease-pool event-loop
] when ;
world-handle second f -> performClose:
] when* ;
-M: cocoa-ui-backend raise-window ( world -- )
+M: cocoa-ui-backend raise-window* ( world -- )
world-handle [
second dup f -> orderFront: -> makeKeyWindow
NSApp 1 -> activateIgnoringOtherApps:
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
[
[
- 2drop dup view-dim swap window set-gadget-dim
- ui-step
+ 2drop dup view-dim swap window set-gadget-dim yield
] ui-try
]
}
{ $description "Outputs a human-readable name for the command." }
{ $examples
{ $example
- "USE: ui.commands"
+ "USING: io ui.commands ;"
": com-my-command ;"
"\\ com-my-command command-name write"
- "My command"
+ "My Command"
}
} ;
{ $description "Outputs a string containing the command name followed by the gesture." }
{ $examples
{ $example
- "USING: ui.commands ui.gestures ;"
+ "USING: io ui.commands ui.gestures ;"
": com-my-command ;"
"T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
- "My command (C+s)"
+ "My Command (C+s)"
}
} ;
-IN: temporary
+IN: ui.commands.tests
USING: ui.commands ui.gestures tools.test help.markup io
io.streams.string ;
: open-face ( font style -- face )
ttf-name ttf-path
- dup file-contents >byte-array malloc-byte-array
+ dup malloc-file-contents
swap file-length
(open-face) ;
-IN: temporary
+IN: ui.gadgets.books.tests
USING: tools.test ui.gadgets.books ;
\ <book> must-infer
-IN: temporary
+IN: ui.gadgets.buttons.tests
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
ui.gadgets tools.test namespaces sequences kernel models ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme
} at T{ one-line-elt } or ;
: drag-direction? ( loc editor -- ? )
- editor-mark* <=> 0 < ;
+ editor-mark* before? ;
: drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep
-IN: temporary
+IN: ui.gadgets.frames.tests
USING: ui.gadgets.frames ui.gadgets tools.test ;
[ ] [ <frame> layout ] unit-test
-IN: temporary
+IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel dlists math
math.parser ui sequences hashtables assocs io arrays
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
-timers quotations math.vectors combinators sorting vectors
-dlists models ;
+quotations math.vectors combinators sorting vectors dlists
+models threads concurrency.flags ;
IN: ui.gadgets
+SYMBOL: ui-notify-flag
+
+: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
+
TUPLE: rect loc dim ;
C: <rect> rect
#! When unit testing gadgets without the UI running, the
#! invalid queue is not initialized and we simply ignore
#! invalidation requests.
- layout-queue [ push-front ] [ drop ] if* ;
+ layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
DEFER: relayout
: queue-graft ( gadget -- )
{ f t } over set-gadget-graft-state
- graft-queue push-front ;
+ graft-queue push-front notify-ui-thread ;
: queue-ungraft ( gadget -- )
{ t f } over set-gadget-graft-state
- graft-queue push-front ;
+ graft-queue push-front notify-ui-thread ;
: graft-later ( gadget -- )
dup gadget-graft-state {
USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
namespaces ;
-IN: temporary
+IN: ui.gadgets.grids.tests
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
HELP: <labelled-pane>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "title" string } { "gadget" "a new " { $link gadget } } }
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
{ <labelled-pane> <pane-control> } related-words
USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled
ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces
kernel tools.test ui.gadgets.buttons sequences ;
-IN: temporary
+IN: ui.gadgets.labelled.tests
TUPLE: testing ;
: <labelled-scroller> ( gadget title -- gadget )
>r <scroller> r> <labelled-gadget> ;
-: <labelled-pane> ( model quot title -- gadget )
- >r <pane-control> t over set-pane-scrolls? r>
+: <labelled-pane> ( model quot scrolls? title -- gadget )
+ >r >r <pane-control> r> over set-pane-scrolls? r>
<labelled-scroller> ;
: <close-box> ( quot -- button/f )
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math namespaces
-opengl sequences io.streams.lines strings splitting
+opengl sequences strings splitting
ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
models ;
IN: ui.gadgets.labels
-IN: temporary
+IN: ui.gadgets.lists.tests
USING: ui.gadgets.lists models prettyprint math tools.test
kernel ;
-IN: temporary
+IN: ui.gadgets.packs.tests
USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
kernel namespaces tools.test math.parser sequences ;
-IN: temporary
+IN: ui.gadgets.panes.tests
USING: alien ui.gadgets.panes ui.gadgets namespaces
kernel sequences io io.streams.string tools.test prettyprint
definitions help help.syntax help.markup splitting
-IN: temporary
+IN: ui.gadgets.presentations.tests
USING: math ui.gadgets.presentations ui.gadgets tools.test
prettyprint ui.gadgets.buttons io io.streams.string kernel
tuples ;
-IN: temporary
+IN: ui.gadgets.scrollers.tests
USING: ui.gadgets ui.gadgets.scrollers
namespaces tools.test kernel models ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
-IN: temporary
+IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ;
[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models sequences ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ;
+ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
+calendar ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
- 100 <delay> [ "" like ] <filter> <label-control>
+ 1/10 seconds <delay> [ "" like ] <filter> <label-control>
dup reverse-video-theme
t over set-gadget-root? ;
USING: kernel ui.gadgets ui.gadgets.tracks tools.test ;
-IN: temporary
+IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [
[
{ $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
-HELP: raise-window
-{ $values { "world" world } }
-{ $description "Makes the native window containing the given world the front-most window." }
-{ $notes "To raise the window containing a specific gadget, use " { $link find-world } " to find the world containing the gadget first." } ;
-
HELP: select-gl-context
{ $values { "handle" "a backend-specific handle" } }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
-IN: temporary
+IN: ui.gadgets.worlds.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel ;
{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
{ $examples
- { $example "USE: ui.gestures" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
+ { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
} ;
ARTICLE: "ui-gestures" "UI gestures"
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
-math.vectors tuples classes ui.gadgets timers combinators.lib ;
+math.vectors tuples classes ui.gadgets combinators.lib boxes
+calendar alarms symbols ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
tuple>array 1 head* >tuple ;
! Modifiers
-SYMBOL: C+
-SYMBOL: A+
-SYMBOL: M+
-SYMBOL: S+
+SYMBOLS: C+ A+ M+ S+ ;
TUPLE: key-down mods sym ;
: drag-gesture ( -- )
hand-buttons get-global first <drag> button-gesture ;
-TUPLE: drag-timer ;
+SYMBOL: drag-timer
-M: drag-timer tick drop drag-gesture ;
-
-drag-timer construct-empty drag-timer set-global
+<box> drag-timer set-global
: start-drag-timer ( -- )
hand-buttons get-global empty? [
- drag-timer get-global 100 300 add-timer
+ [ drag-gesture ]
+ 300 milliseconds from-now
+ 100 milliseconds
+ add-alarm drag-timer get-global >box
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
- drag-timer get-global remove-timer
+ drag-timer get-global ?box
+ [ cancel-alarm ] [ drop ] if
] when ;
: fire-motion ( -- )
-IN: temporary
+IN: ui.operations.tests
USING: ui.operations ui.commands prettyprint kernel namespaces
tools.test ui.gadgets ui.gadgets.editors parser io
io.streams.string math help help.markup ;
-IN: temporary
+IN: ui.tools.browser.tests
USING: tools.test tools.test.ui ui.tools.browser ;
\ <browser-gadget> must-infer
"Advanced:" <label> gadget,
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
deploy-math? get "Rational and complex number support" <checkbox> gadget,
- deploy-word-props? get "Include word properties" <checkbox> gadget,
- deploy-word-defs? get "Include word definitions" <checkbox> gadget,
- deploy-c-types? get "Include C types" <checkbox> gadget, ;
+ deploy-threads? get "Threading support" <checkbox> gadget,
+ deploy-word-props? get "Retain all word properties" <checkbox> gadget,
+ deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
+ deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
: deploy-settings-theme
{ 10 10 } over set-pack-gap
-IN: temporary
+IN: ui.tools.interactor.tests
USING: ui.tools.interactor tools.test ;
\ <interactor> must-infer
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
-ui.tools.workspace hashtables io io.styles kernel math
+ hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
sequences sequences.lib strings threads listener
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes ;
+definitions boxes calendar concurrency.flags ui.tools.workspace ;
IN: ui.tools.interactor
-TUPLE: interactor
-history output
-thread quot
-help ;
+TUPLE: interactor history output flag thread help ;
: interactor-continuation ( interactor -- continuation )
interactor-thread box-value
] if ;
: init-caret-help ( interactor -- )
- dup editor-caret 100 <delay> swap set-interactor-help ;
+ dup editor-caret 1/3 seconds <delay>
+ swap set-interactor-help ;
: init-interactor-history ( interactor -- )
V{ } clone swap set-interactor-history ;
+: init-interactor-state ( interactor -- )
+ <flag> over set-interactor-flag
+ <box> swap set-interactor-thread ;
+
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
tuck set-interactor-output
- <box> over set-interactor-thread
dup init-interactor-history
+ dup init-interactor-state
dup init-caret-help ;
M: interactor graft*
] unless drop ;
: interactor-yield ( interactor -- obj )
- [ interactor-thread >box ] curry "input" suspend ;
+ [
+ [ interactor-thread >box ] keep
+ interactor-flag raise-flag
+ ] curry "input" suspend ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish ?first ;
USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
-timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words tools.test.ui slots.private ;
-IN: temporary
-
-timers [ init-timers ] unless
+tools.test ui.commands ui.gadgets ui.gadgets.editors
+ui.gadgets.panes vocabs words tools.test.ui slots.private
+threads ;
+IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
[ ] [ <listener-gadget> "listener" set ] unit-test
"listener" get [
- [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
+ [ "dup" ] [
+ \ dup "listener" get word-completion-string
+ ] unit-test
[ "USE: slots.private slot" ]
[ \ slot "listener" get word-completion-string ] unit-test
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads ;
+prettyprint listener debugger threads boxes concurrency.flags ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
M: listener-gadget tool-scroller
listener-gadget-output find-scroller ;
-: workspace-busy? ( workspace -- ? )
- workspace-listener listener-gadget-input
- interactor-busy? ;
+: wait-for-listener ( listener -- )
+ #! Wait for the listener to start.
+ listener-gadget-input interactor-flag wait-for-flag ;
-: get-listener ( -- listener )
- [ workspace-busy? not ] get-workspace* workspace-listener ;
+: workspace-busy? ( workspace -- ? )
+ workspace-listener listener-gadget-input interactor-busy? ;
: listener-input ( string -- )
- get-listener listener-gadget-input set-editor-string ;
+ get-workspace
+ workspace-listener
+ listener-gadget-input set-editor-string ;
: (call-listener) ( quot listener -- )
listener-gadget-input interactor-call ;
: call-listener ( quot -- )
- get-listener (call-listener) ;
+ [ workspace-busy? not ] get-workspace* workspace-listener
+ [ dup wait-for-listener (call-listener) ] 2curry
+ "Listener call" spawn drop ;
M: listener-command invoke-command ( target command -- )
command-quot call-listener ;
[ operation-hook call ] keep operation-quot call-listener ;
: eval-listener ( string -- )
- get-listener
+ get-workspace
+ workspace-listener
listener-gadget-input [ set-editor-string ] keep
evaluate-input ;
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
: insert-word ( word -- )
- get-listener [ word-completion-string ] keep
+ get-workspace
+ workspace-listener
+ [ word-completion-string ] keep
listener-gadget-input user-input ;
: quot-action ( interactor -- lines )
g workspace-listener swap [
dup <toolbar> f track,
listener-gadget-stack [ stack. ]
- "Data stack" <labelled-pane> 1 track,
+ t "Data stack" <labelled-pane> 1 track,
] { 0 1 } build-track ;
M: stack-display tool-scroller
listener
] with-stream* ;
+: start-listener-thread ( listener -- )
+ [ listener-thread ] curry "Listener" spawn drop ;
+
: restart-listener ( listener -- )
+ #! Returns when listener is ready to receive input.
dup com-end dup clear-output
- [ listener-thread ] curry
- "Listener" spawn drop ;
+ dup start-listener-thread
+ wait-for-listener ;
: init-listener ( listener -- )
f <model> swap set-listener-gadget-stack ;
M: listener-gadget graft*
dup delegate graft*
+ dup listener-gadget-input interactor-thread ?box 2drop
restart-listener ;
M: listener-gadget ungraft*
ui.tools.search ui.tools.traceback ui.tools.workspace generic
help.topics inference inspector io.files io.styles kernel
namespaces parser prettyprint quotations tools.annotations
-editors tools.profiler tools.test tools.time tools.interpreter
+editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
tools.browser classes compiler.units ;
USING: assocs ui.tools.search help.topics io.files io.styles
-kernel namespaces sequences source-files threads timers
+kernel namespaces sequences source-files threads
tools.test ui.gadgets ui.gestures vocabs
vocabs.loader words tools.test.ui debugger ;
-IN: temporary
-
-timers get [ init-timers ] unless
+IN: ui.tools.search.tests
[ f ] [
"no such word with this name exists, certainly"
: update-live-search ( search -- seq )
dup [
- 300 sleep do-timers
+ 300 sleep
live-search-list control-value
] with-grafted-gadget ;
dup [
{ "set-word-prop" } over live-search-field set-control-value
300 sleep
- do-timers
search-value \ set-word-prop eq?
] with-grafted-gadget
] unit-test
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
models namespaces prettyprint quotations sequences sorting
-source-files strings tools.completion tools.crossref tuples
-ui.commands ui.gadgets ui.gadgets.editors
+source-files definitions strings tools.completion tools.crossref
+tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
-tools.browser unicode.case ;
+tools.browser unicode.case calendar ui ;
IN: ui.tools.search
TUPLE: live-search field list ;
} set-gestures
: <search-model> ( producer -- model )
- >r g live-search-field gadget-model 200 <delay>
+ >r g live-search-field gadget-model
+ ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget )
"Words in " rot vocab-name append show-titled-popup ;
: show-word-usage ( workspace word -- )
- "" over smart-usage f <definition-search>
+ "" over usage f <definition-search>
"Words and methods using " rot word-name append
show-titled-popup ;
USING: editors help.markup help.syntax inspector io listener
-parser prettyprint tools.profiler tools.interpreter ui.commands
+parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
ui.tools.interactor ui.tools.listener ui.tools.operations
{ $command-map browser-gadget "toolbar" }
"Browsers are instances of " { $link browser-gadget } "." ;
-ARTICLE: "ui-walker" "UI walker"
-"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
-$nl
-"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
-{ $command-map walker "toolbar" }
-{ $command-map walker "other" }
-"Walkers are instances of " { $link walker } "." ;
-
ARTICLE: "ui-profiler" "UI profiler"
"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
$nl
{ $command-map workspace "scrolling" }
{ $command-map workspace "workflow" }
{ $heading "Implementation" }
-"Workspaces are instances of " { $link workspace-window } "." ;
+"Workspaces are instances of " { $link workspace } "." ;
ARTICLE: "ui-tools" "UI development tools"
"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
-{ $subsection "ui-walker" }
{ $subsection "ui-profiler" }
"Additional tools:"
+{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
"Platform-specific features:"
{ $subsection "ui-cocoa" } ;
USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces
-sequences timers tools.test ui.gadgets ui.gadgets.buttons
+sequences tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs tools.test.ui ui ;
-IN: temporary
+IN: ui.tools.tests
[
[ f ] [
] unit-test
] with-scope
-timers get [ init-timers ] unless
-
[ ] [ <workspace> "w" set ] unit-test
[ ] [ "w" get com-scroll-up ] unit-test
[ ] [ "w" get com-scroll-down ] unit-test
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs debugger ui.tools.workspace
-ui.tools.operations ui.tools.browser ui.tools.inspector
-ui.tools.listener ui.tools.profiler ui.tools.walker
+ui.tools.operations ui.tools.traceback ui.tools.browser
+ui.tools.inspector ui.tools.listener ui.tools.profiler
ui.tools.operations inspector io kernel math models namespaces
prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons
-ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
-vocabs.loader tools.test ui.gadgets.buttons
-ui.gadgets.status-bar mirrors ;
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
+ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
+ui.gadgets.presentations ui.gestures words vocabs.loader
+tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ;
IN: ui.tools
: <workspace-tabs> ( -- tabs )
<stack-display> ,
<browser-gadget> ,
<inspector-gadget> ,
- <walker> ,
<profiler-gadget> ,
] { } make g gadget-model <book> ;
: com-inspector inspector-gadget select-tool ;
-: com-walker walker select-tool ;
-
: com-profiler profiler-gadget select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }
{ T{ key-down f { A+ } "2" } com-browser }
{ T{ key-down f { A+ } "3" } com-inspector }
- { T{ key-down f { A+ } "4" } com-walker }
- { T{ key-down f { A+ } "5" } com-profiler }
+ { T{ key-down f { A+ } "4" } com-profiler }
} define-command-map
\ workspace-window
} define-command-map
[
- <workspace> "Factor workspace" open-status-window
+ <workspace> dup "Factor workspace" open-status-window
] workspace-window-hook set-global
+
+: inspect-continuation ( traceback -- )
+ control-value [ inspect ] curry call-listener ;
+
+traceback-gadget "toolbar" f {
+ { T{ key-down f f "v" } variables }
+ { T{ key-down f f "n" } inspect-continuation }
+} define-command-map
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations kernel models namespaces prettyprint ui
-ui.commands ui.gadgets ui.gadgets.labelled
-ui.gadgets.tracks ui.gestures ;
+ui.commands ui.gadgets ui.gadgets.labelled assocs
+ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ui.gadgets.status-bar ui.gadgets.scrollers
+ui.gestures sequences hashtables inspector ;
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
[ [ continuation-call callstack. ] when* ]
- "Call stack" <labelled-pane> ;
+ t "Call stack" <labelled-pane> ;
: <datastack-display> ( model -- gadget )
[ [ continuation-data stack. ] when* ]
- "Data stack" <labelled-pane> ;
+ t "Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- gadget )
[ [ continuation-retain stack. ] when* ]
- "Retain stack" <labelled-pane> ;
+ t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget ;
-M: traceback-gadget pref-dim* drop { 300 400 } ;
+M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget )
{ 0 1 } <track> traceback-gadget construct-control [
g gadget-model <retainstack-display> 1/2 track,
] { 1 0 } make-track 1/3 track,
g gadget-model <callstack-display> 2/3 track,
+ toolbar,
] with-gadget
] keep ;
+: <namestack-display> ( model -- gadget )
+ [ [ continuation-name namestack. ] when* ]
+ <pane-control> ;
+
+TUPLE: variables-gadget ;
+
+: <variables-gadget> ( model -- gadget )
+ <namestack-display> <scroller>
+ variables-gadget construct-empty
+ [ set-gadget-delegate ] keep ;
+
+M: variables-gadget pref-dim* drop { 400 400 } ;
+
+: variables ( traceback -- )
+ gadget-model <variables-gadget>
+ "Dynamic variables" open-status-window ;
+
: traceback-window ( continuation -- )
<model> <traceback-gadget> "Traceback" open-window ;
--- /dev/null
+IN: ui.tools.walker\r
+USING: help.markup help.syntax ui.commands ui.operations\r
+tools.walker ;\r
+\r
+ARTICLE: "ui-walker" "UI walker"\r
+"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
+$nl\r
+"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."\r
+{ $command-map walker-gadget "toolbar" }\r
+"Walkers are instances of " { $link walker-gadget } "." ;\r
-USING: arrays continuations ui.tools.listener ui.tools.walker
-ui.tools.workspace inspector kernel namespaces sequences threads
-listener tools.test ui ui.gadgets ui.gadgets.worlds
-ui.gadgets.packs vectors ui.tools tools.interpreter
-tools.interpreter.debug tools.test.ui ;
-IN: temporary
+USING: ui.tools.walker tools.test ;
+IN: ui.tools.walker.tests
-\ <walker> must-infer
-
-[ ] [ <walker> "walker" set ] unit-test
-
-"walker" get [
- ! Make sure the toolbar buttons don't throw if we're
- ! not actually walking.
-
- [ ] [ "walker" get com-step ] unit-test
- [ ] [ "walker" get com-into ] unit-test
- [ ] [ "walker" get com-out ] unit-test
- [ ] [ "walker" get com-back ] unit-test
- [ ] [ "walker" get com-inspect ] unit-test
- [ ] [ "walker" get reset-walker ] unit-test
- [ ] [ "walker" get com-continue ] unit-test
-] with-grafted-gadget
-
-: <test-world> ( gadget -- world )
- [ gadget, ] make-pile "Hi" f <world> ;
-
-f <workspace> dup [
- [ <test-world> 2array 1vector windows set ] keep
-
- "ok" off
-
- [
- workspace-listener
- listener-gadget-input
- "ok" on
- stream-read-quot
- "c" get continue-with
- ] in-thread drop
-
- [ t ] [ "ok" get ] unit-test
-
- [ ] [ walker get-tool "w" set ] unit-test
- continuation "c" set
-
- [ ] [ "c" get "w" get call-tool* ] unit-test
-
- [ ] [
- [ "c" set f ] callcc1
- [ "q" set ] [ "w" get com-inspect stop ] if*
- ] unit-test
-
- [ t ] [
- "q" get dup first continuation?
- swap second \ inspect eq? and
- ] unit-test
-] with-grafted-gadget
-
-[
- f <workspace> dup [
- <test-world> 2array 1vector windows set
-
- [ ] [
- [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
- ] unit-test
-
- [ ] [ walker get-tool com-continue ] unit-test
-
- [ ] [ yield ] unit-test
-
- [ t ] [ walker get-tool walker-active? ] unit-test
-
- [ ] [ "walker" get com-continue ] unit-test
-
- [ ] [ "walker" get com-continue ] unit-test
-
- [ ] [ "walker" get com-continue ] unit-test
- ] with-grafted-gadget
-] with-scope
+\ <walker-gadget> must-infer
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs ui.tools.listener ui.tools.traceback
-ui.tools.workspace inspector kernel models namespaces
-prettyprint quotations sequences threads
-tools.interpreter ui.commands ui.gadgets ui.gadgets.labelled
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons
-ui.gadgets.panes prettyprint.config prettyprint.backend
-continuations ;
+USING: kernel concurrency.messaging inspector ui.tools.listener
+ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
+ui.gadgets.tracks ui.commands ui.gadgets models
+ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
+namespaces tools.walker assocs ;
IN: ui.tools.walker
-TUPLE: walker model interpreter history ;
+TUPLE: walker-gadget status continuation thread traceback ;
-: update-stacks ( walker -- )
- dup walker-interpreter interpreter-continuation
- swap walker-model set-model ;
+: walker-command ( walker msg -- )
+ over walker-gadget-thread thread-registered?
+ [ swap walker-gadget-thread send-synchronous drop ]
+ [ 2drop ] if ;
-: with-walker ( walker quot -- )
- over >r >r walker-interpreter r> call r>
- update-stacks ; inline
+: com-step ( walker -- ) step walker-command ;
-: walker-active? ( walker -- ? )
- walker-interpreter interpreter-continuation >boolean ;
+: com-into ( walker -- ) step-into walker-command ;
-: save-interpreter ( walker -- )
- dup walker-interpreter interpreter-continuation clone
- swap walker-history push ;
+: com-out ( walker -- ) step-out walker-command ;
-: walker-command ( gadget quot -- )
- over walker-active? [
- over save-interpreter
- with-walker
- ] [ 2drop ] if ; inline
+: com-back ( walker -- ) step-back walker-command ;
-: com-step ( walker -- ) [ step ] walker-command ;
+: com-continue ( walker -- ) step-all walker-command ;
-: com-into ( walker -- ) [ step-into ] walker-command ;
+: com-abandon ( walker -- ) abandon walker-command ;
-: com-out ( walker -- ) [ step-out ] walker-command ;
+M: walker-gadget ungraft*
+ dup delegate ungraft* detach walker-command ;
-: com-back ( walker -- )
- dup walker-history
- dup empty? [ 2drop ] [ pop swap call-tool* ] if ;
+M: walker-gadget focusable-child*
+ walker-gadget-traceback ;
-: reset-walker ( walker -- )
- <interpreter> over set-walker-interpreter
- V{ } clone over set-walker-history
- update-stacks ;
+: walker-state-string ( status thread -- string )
+ [
+ "Thread: " %
+ dup thread-name %
+ " (" %
+ swap {
+ { +stopped+ "Stopped" }
+ { +suspended+ "Suspended" }
+ { +running+ "Running" }
+ { +detached+ "Detached" }
+ } at %
+ ")" %
+ drop
+ ] "" make ;
-M: walker graft* dup delegate graft* reset-walker ;
+: <thread-status> ( model thread -- gadget )
+ [ walker-state-string ] curry <filter> <label-control> ;
-: <walker> ( -- gadget )
- f <model> f f walker construct-boa [
+: <walker-gadget> ( status continuation thread -- gadget )
+ over <traceback-gadget> walker-gadget construct-boa [
toolbar,
- g walker-model <traceback-gadget> 1 track,
+ g walker-gadget-status self <thread-status> f track,
+ g walker-gadget-traceback 1 track,
] { 0 1 } build-track ;
-M: walker call-tool* ( continuation walker -- )
- [ restore ] with-walker ;
-
-: com-inspect ( walker -- )
- dup walker-active? [
- walker-interpreter interpreter-continuation
- [ inspect ] curry call-listener
- ] [
- drop
- ] if ;
-
-: com-continue ( walker -- )
- #! Reset walker first, in case step-all ends up calling
- #! the walker again.
- dup walker-active? [
- dup walker-interpreter swap reset-walker step-all
- ] [
- drop
- ] if ;
-
: walker-help "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command
-walker "toolbar" f {
- { T{ key-down f { A+ } "s" } com-step }
- { T{ key-down f { A+ } "i" } com-into }
- { T{ key-down f { A+ } "o" } com-out }
- { T{ key-down f { A+ } "b" } com-back }
- { T{ key-down f { A+ } "c" } com-continue }
+walker-gadget "toolbar" f {
+ { T{ key-down f f "s" } com-step }
+ { T{ key-down f f "i" } com-into }
+ { T{ key-down f f "o" } com-out }
+ { T{ key-down f f "b" } com-back }
+ { T{ key-down f f "c" } com-continue }
+ { T{ key-down f f "a" } com-abandon }
+ { T{ key-down f f "d" } close-window }
{ T{ key-down f f "F1" } walker-help }
} define-command-map
-walker "other" f {
- { T{ key-down f { A+ } "n" } com-inspect }
-} define-command-map
+: walker-window ( -- )
+ f <model> f <model> 2dup start-walker-thread
+ [ <walker-gadget> ] keep thread-name open-status-window ;
+
+[ [ walker-window ] with-ui ] new-walker-hook set-global
-[ walker call-tool stop ] break-hook set-global
+[
+ [
+ >r dup walker-gadget?
+ [ walker-gadget-thread r> eq? ]
+ [ r> 2drop f ] if
+ ] curry find-window raise-window
+] show-walker-hook set-global
-IN: temporary
+IN: ui.tools.workspace.tests
USING: tools.test ui.tools ;
\ <workspace> must-infer
SYMBOL: workspace-window-hook
-: workspace-window ( -- workspace )
+: workspace-window* ( -- workspace )
workspace-window-hook get call ;
+: workspace-window ( -- )
+ workspace-window* drop ;
+
GENERIC: call-tool* ( arg tool -- )
GENERIC: tool-scroller ( tool -- scroller )
: select-tool ( workspace class -- ) swap show-tool drop ;
: get-workspace* ( quot -- workspace )
- [ dup workspace? [ over call ] [ drop f ] if ] find-window
- [ nip dup raise-window gadget-child ]
- [ workspace-window get-workspace* ] if* ; inline
+ [ >r dup workspace? r> [ drop f ] if ] curry find-window
+ [ dup raise-window gadget-child ]
+ [ workspace-window* ] if* ; inline
: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
-IN: temporary
+IN: ui.traverse.tests
USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
math arrays tools.test io ui.gadgets.panes ui.traverse
definitions compiler.units ;
HELP: find-window
{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
-{ $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
+{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
{ $values { "world" world } { "handle" "a baackend-specific handle" } }
{ $subsection start-ui }
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
$nl
-"The event loop must not block. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout, runs timers and sleeps for 10 milliseconds, or until a Factor thread wakes up." ;
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
"If the user clicks the window's close box, you must call the following word:"
{ $subsection close-window } ;
+HELP: raise-window
+{ $values { "gadget" gadget } }
+{ $description "Makes the native window containing the given gadget the front-most window." } ;
+
ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
{ $subsection "ui-layout-basics" }
{ $subsection "ui-paint" }
{ $subsection "ui-control-impl" }
{ $subsection "clipboard-protocol" }
-{ $subsection "timers" }
{ $see-also "ui-layout-impl" } ;
ARTICLE: "ui" "UI framework"
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
-timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables ;
+hashtables concurrency.flags ;
IN: ui
! Assoc mapping aliens to gadgets
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
-: ui-step ( -- )
- [ do-timers ] assert-depth
- [ notify-queued ] assert-depth
- [ layout-queued "a" set ] assert-depth
- [ "a" get redraw-worlds ] assert-depth ;
+: update-ui ( -- )
+ [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+
+: ui-wait ( -- )
+ 10 sleep ;
+
+: ui-try ( quot -- ) [ ui-error ] recover ;
+
+SYMBOL: ui-thread
+
+: ui-running ( quot -- )
+ t \ ui-running set-global
+ [ f \ ui-running set-global ] [ ] cleanup ; inline
+
+: ui-running? ( -- ? )
+ \ ui-running get-global ;
+
+: update-ui-loop ( -- )
+ ui-running? ui-thread get-global self eq? and [
+ ui-notify-flag get lower-flag
+ [ update-ui ] ui-try
+ update-ui-loop
+ ] when ;
+
+: start-ui-thread ( -- )
+ [ self ui-thread set-global update-ui-loop ]
+ "UI update" spawn drop ;
: open-world-window ( world -- )
- dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
+ dup pref-dim over set-gadget-dim dup relayout graft ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
: fullscreen? ( gadget -- ? )
find-world fullscreen* ;
+: raise-window ( gadget -- )
+ find-world raise-window* ;
+
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- )
- init-timers
restore-windows? [
restore-windows
] [
init-ui ui-hook get call
- ] if ui-step ;
+ ] if
+ notify-ui-thread start-ui-thread ;
-: ui-running ( quot -- )
- t \ ui-running set-global
- [ f \ ui-running set-global ] [ ] cleanup ; inline
-
-: ui-running? ( -- ? )
- \ ui-running get-global ;
-
-[ f \ ui-running set-global ] "ui" add-init-hook
+[
+ f \ ui-running set-global
+ <flag> ui-notify-flag set-global
+] "ui" add-init-hook
HOOK: ui ui-backend ( -- )
f windows set-global
ui-hook [ ui ] with-variable
] if ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;
math math.vectors namespaces prettyprint sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
-windows threads timers libc combinators
-continuations command-line shuffle opengl ui.render unicode.case
-ascii math.bitfields ;
+windows threads libc combinators continuations command-line
+shuffle opengl ui.render unicode.case ascii math.bitfields
+locals symbols ;
IN: ui.windows
TUPLE: windows-ui-backend ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
: enum-clipboard ( -- seq )
- 0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
- { } unfold nip ;
+ 0
+ [ EnumClipboardFormats win32-error dup dup 0 > ]
+ [ ]
+ [ drop ]
+ unfold nip ;
: with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f
: copy ( str -- )
lf>crlf [
string>u16-alien
- f OpenClipboard win32-error=0/f
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
- rot dup length memcpy
+ swapd byte-array>memory
dup GlobalUnlock win32-error=0/f
CF_UNICODETEXT swap SetClipboardData win32-error=0/f
] with-clipboard ;
TUPLE: win hWnd hDC hRC world title ;
C: <win> win
-SYMBOL: msg-obj
-SYMBOL: class-name-ptr
-SYMBOL: mouse-captured
+SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
-: adjust-RECT ( RECT -- )
- style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( width height -- RECT )
- "RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
-
-: make-adjusted-RECT ( width height -- RECT )
- make-RECT dup adjust-RECT ;
+: get-RECT-top-left ( RECT -- x y )
+ [ RECT-left ] keep RECT-top ;
-: get-RECT-dimensions ( RECT -- width height )
+: get-RECT-dimensions ( RECT -- x y width height )
+ [ get-RECT-top-left ] keep
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
-: get-RECT-top-left ( RECT -- x y )
- [ RECT-left ] keep RECT-top ;
-
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
#! only paint if width/height both > 0
- 3drop window draw-world ;
+ 3drop window relayout-1 yield ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
- [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
- dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
+
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ swap window set-world-loc ;
: wm-keydown-codes ( -- key )
H{
] if
] if ;
-SYMBOL: lParam
-SYMBOL: wParam
-SYMBOL: uMsg
-SYMBOL: hWnd
-
-: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
- lParam set wParam set uMsg set hWnd set
- wParam get exclude-key-wm-keydown? [
- wParam get keystroke>gesture <key-down>
- hWnd get window-focus send-gesture drop
+:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam keystroke>gesture <key-down>
+ hWnd window-focus send-gesture drop
] unless ;
-: handle-wm-char ( hWnd uMsg wParam lParam -- )
- lParam set wParam set uMsg set hWnd set
- wParam get exclude-key-wm-char? ctrl? alt? xor or [
- wParam get 1string
- hWnd get window-focus user-input
+:: handle-wm-char ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-char? ctrl? alt? xor or [
+ wParam 1string
+ hWnd window-focus user-input
] unless ;
-: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
- lParam set wParam set uMsg set hWnd set
- wParam get keystroke>gesture <key-up>
- hWnd get window-focus send-gesture
- drop ;
+:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+ wParam keystroke>gesture <key-up>
+ hWnd window-focus send-gesture drop ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
3drop window [ unfocus-world ] when* ;
+: message>button ( uMsg -- button down? )
+ {
+ { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
+ { [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
+ { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
+ { [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
+ { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
+ { [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
+
+ { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
+ { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
+ { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
+ { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
+ { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
+ { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
+ } cond ;
+
+! If the user clicks in the window border ("non-client area")
+! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
+! mouse is subsequently released outside the NC area, we receive
+! a [LMR]BUTTONUP message and Factor can get confused. So we
+! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
+SYMBOL: nc-buttons
+
+: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
+ 2drop nip
+ message>button nc-buttons get
+ swap [ push ] [ delete ] if ;
+
: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-absolute>relative ( lparam handle -- array )
>r >lo-hi r>
- 0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep
+ "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
: mouse-event>gesture ( uMsg -- button )
- key-modifiers swap
- {
- { [ dup WM_LBUTTONDOWN = ] [ drop 1 <button-down> ] }
- { [ dup WM_LBUTTONUP = ] [ drop 1 <button-up> ] }
- { [ dup WM_MBUTTONDOWN = ] [ drop 2 <button-down> ] }
- { [ dup WM_MBUTTONUP = ] [ drop 2 <button-up> ] }
- { [ dup WM_RBUTTONDOWN = ] [ drop 3 <button-down> ] }
- { [ dup WM_RBUTTONUP = ] [ drop 3 <button-up> ] }
- { [ t ] [ "bad button" throw ] }
- } cond ;
+ key-modifiers swap message>button
+ [ <button-down> ] [ <button-up> ] if ;
: mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ;
mouse-captured off ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
- >r over capture-mouse? [ pick set-capture ] when r>
+ >r >r dup capture-mouse? [ over set-capture ] when r> r>
prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when
- prepare-mouse send-button-up ;
+ pick message>button drop dup nc-buttons get member? [
+ nc-buttons get delete 4drop
+ ] [
+ drop prepare-mouse send-button-up
+ ] if ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
"TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
#! message sent if mouse leaves main application
4drop forget-rollover ;
+SYMBOL: wm-handlers
+
+H{ } clone wm-handlers set-global
+
+: add-wm-handler ( quot wm -- )
+ dup array?
+ [ [ execute add-wm-handler ] with each ]
+ [ wm-handlers get-global set-at ] if ;
+
+[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
+[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
+
+[ handle-wm-size 0 ] WM_SIZE add-wm-handler
+[ handle-wm-move 0 ] WM_MOVE add-wm-handler
+
+[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
+[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
+[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
+
+[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
+[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
+[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
+
+[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
+[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
+
+[ 4dup handle-wm-ncbutton DefWindowProc ]
+{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
+WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
+add-wm-handler
+
+[ nc-buttons get-global delete-all DefWindowProc ]
+{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
+
+[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
+[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
+[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
+[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
+
+SYMBOL: trace-messages?
+
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [
[
- pick ! global [ dup windows-message-name . ] bind
- {
- { [ dup WM_CLOSE = ] [ drop handle-wm-close 0 ] }
- { [ dup WM_PAINT = ]
- [ drop 4dup handle-wm-paint DefWindowProc ] }
- { [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] }
-
- ! Keyboard events
- { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
- [ drop 4dup handle-wm-keydown DefWindowProc ] }
- { [ dup WM_CHAR = over WM_SYSCHAR = or ]
- [ drop 4dup handle-wm-char DefWindowProc ] }
- { [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
- [ drop 4dup handle-wm-keyup DefWindowProc ] }
-
- { [ dup WM_SYSCOMMAND = ] [ drop handle-wm-syscommand ] }
- { [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] }
- { [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] }
-
- ! Mouse events
- { [ dup WM_LBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
- { [ dup WM_MBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
- { [ dup WM_RBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] }
- { [ dup WM_LBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
- { [ dup WM_MBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
- { [ dup WM_RBUTTONUP = ] [ drop handle-wm-buttonup 0 ] }
- { [ dup WM_MOUSEMOVE = ] [ drop handle-wm-mousemove 0 ] }
- { [ dup WM_MOUSEWHEEL = ] [ drop handle-wm-mousewheel 0 ] }
- { [ dup WM_CANCELMODE = ] [ drop handle-wm-cancelmode 0 ] }
- { [ dup WM_MOUSELEAVE = ] [ drop handle-wm-mouseleave 0 ] }
-
- { [ t ] [ drop DefWindowProc ] }
- } cond
+ pick
+ trace-messages? get-global [ dup windows-message-name . ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] ui-try
] alien-callback ;
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
- { [ dup peek-message? ] [
- >r [ ui-step 10 sleep ] ui-try
- r> event-loop
- ] }
+ { [ dup peek-message? ] [ ui-wait event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [
dup TranslateMessage drop
RegisterClassEx dup win32-error=0/f
] when ;
-: create-window ( width height -- hwnd )
+: adjust-RECT ( RECT -- )
+ style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+ dup world-loc { 40 40 } vmax dup rot rect-dim v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+ make-RECT dup adjust-RECT ;
+
+: create-window ( rect -- hwnd )
make-adjusted-RECT
>r class-name-ptr get-global f r>
>r >r >r ex-style r> r>
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
- CW_USEDEFAULT dup r>
- get-RECT-dimensions
+ r> get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- )
SetFocus drop ;
: init-win32-ui ( -- )
- "MSG" <c-object> msg-obj set
+ V{ } clone nc-buttons set-global
+ "MSG" <c-object> msg-obj set-global
"Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
get-dc dup setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- )
- [ rect-dim first2 create-window dup setup-gl ] keep
+ [ create-window dup setup-gl ] keep
[ f <win> ] keep
[ swap win-hWnd register-window ] 2keep
dupd set-world-handle
win-hDC SwapBuffers win32-error=0/f ;
! Move window to front
-M: windows-ui-backend raise-window ( world -- )
+M: windows-ui-backend raise-window* ( world -- )
world-handle [
win-hWnd SetFocus drop
] when* ;
M: windows-ui-backend set-title ( string world -- )
- world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
+ world-handle
dup win-title [ free ] when*
>r malloc-u16-string r>
- dupd set-win-title alien-address
- SendMessage drop ;
+ 2dup set-win-title
+ win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
M: windows-ui-backend ui
[
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
namespaces opengl sequences strings x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows
+x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
io.encodings.utf8 combinators debugger system command-line
ui.render math.vectors tuples opengl.gl threads ;
IN: ui.x11
: encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target XA_UTF8_STRING =
- [ encode-utf8 ] [ string>char-alien ] if ;
+ [ utf8 encode ] [ string>char-alien ] if ;
: set-selection-prop ( evt -- )
dpy get swap
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
- ui-step 10 sleep wait-event
+ ui-wait wait-event
] if ;
: do-events ( -- )
: set-title-new ( dpy window string -- )
>r
XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
- r> encode-utf8 dup length XChangeProperty drop ;
+ r> utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )
world-handle x11-handle-window swap dpy get -rot
dup gadget-window
world-handle x11-handle-window dup set-closable map-window ;
-M: x11-ui-backend raise-window ( world -- )
+M: x11-ui-backend raise-window* ( world -- )
world-handle [
dpy get swap x11-handle-window XRaiseWindow drop
] when* ;
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
combinators.lib assocs.lib math.ranges unicode.normalize
-unicode.syntax unicode.data compiler.units alien.syntax ;
+unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
concat >set ;
: other-extend-lines ( -- lines )
- "extra/unicode/PropList.txt" resource-path file-lines ;
+ "extra/unicode/PropList.txt" resource-path ascii file-lines ;
VALUE: other-extend
USING: unicode.syntax ;
IN: unicode.categories
-CATEGORY: blank Zs Zl Zp ;
+CATEGORY: blank Zs Zl Zp \r\n ;
CATEGORY: letter Ll ;
CATEGORY: LETTER Lu ;
CATEGORY: Letter Lu Ll Lt Lm Lo ;
USING: assocs math kernel sequences io.files hashtables
quotations splitting arrays math.parser combinators.lib hash2
-byte-arrays words namespaces words compiler.units parser ;
+byte-arrays words namespaces words compiler.units parser io.encodings.ascii ;
IN: unicode.data
<<
! Loading data from UnicodeData.txt
: data ( filename -- data )
- file-lines [ ";" split ] map ;
+ ascii file-lines [ ";" split ] map ;
: load-data ( -- data )
"extra/unicode/UnicodeData.txt" resource-path data ;
USING: kernel math tools.test units.imperial inverse ;
-IN: temporary
+IN: units.imperial.tests
[ 1 ] [ 12 inches [ feet ] undo ] unit-test
[ 12 ] [ 1 feet [ inches ] undo ] unit-test
USING: kernel tools.test units.si inverse math.constants
math.functions units.imperial ;
-IN: temporary
+IN: units.si.tests
[ t ] [ 1 m 100 cm = ] unit-test
USING: arrays kernel math sequences tools.test units.si
units.imperial units inverse math.functions ;
-IN: temporary
+IN: units.tests
[ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test
[ T{ dimensioned f 3 { m } { s } } ] [ 3 m/s ] unit-test
: km/L km 1 L d/ ;
: mpg miles 1 gallons d/ ;
-[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
+! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
M: dimensions-not-equal summary drop "Dimensions do not match" ;
-: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
- swap [ member? ] curry subset ;
-
: remove-one ( seq obj -- seq )
1array split1 append ;
--- /dev/null
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! FreeBSD 8.0-CURRENT
+
+C-STRUCT: stat
+ { "__dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "__dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "fflags_t" "st_flags" }
+ { "__uint32_t" "st_gen" }
+ { "__int32_t" "st_lspare" }
+ { "timespec" "st_birthtimespec" }
+! not sure about the padding here.
+ { "__uint32_t" "pad0" }
+ { "__uint32_t" "pad1" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! Ubuntu 8.04 32-bit
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ushort" "__pad1" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "ushort" "__pad2" }
+ { "off_t" "st_size" }
+ { "blksize_t" "st_blksize" }
+ { "blkcnt_t" "st_blocks" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "ulong" "unused4" }
+ { "ulong" "unused5" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
+
+: stat ( pathname buf -- int ) 3 -rot __xstat ;
+: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! Ubuntu 7.10 64-bit
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "nlink_t" "st_nlink" }
+ { "mode_t" "st_mode" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "int" "pad0" }
+ { "dev_t" "st_rdev" }
+ { "off_t" "st_size" }
+ { "blksize_t" "st_blksize" }
+ { "blkcnt_t" "st_blocks" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "long" "__unused0" }
+ { "long" "__unused1" }
+ { "long" "__unused2" } ;
+
+FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
+
+: stat ( pathname buf -- int ) 3 -rot __xstat ;
+: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
\ No newline at end of file
--- /dev/null
+
+USING: layouts combinators vocabs.loader ;
+
+IN: unix.stat
+
+cell-bits
+ {
+ { 32 [ "unix.stat.linux.32" require ] }
+ { 64 [ "unix.stat.linux.64" require ] }
+ }
+case
--- /dev/null
+
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! Mac OS X ppc
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "__uint32_t" "st_flags" }
+ { "__uint32_t" "st_gen" }
+ { "__int32_t" "st_lspare" }
+ { "__int64_t" "st_qspare0" }
+ { "__int64_t" "st_qspare1" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+
+: stat-st_atim stat-st_atimespec ;
+: stat-st_mtim stat-st_mtimespec ;
+: stat-st_ctim stat-st_ctimespec ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system combinators alien.syntax alien.c-types
+ math io.unix.backend vocabs.loader ;
+
+IN: unix.stat
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! File Types
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: S_IFMT OCT: 170000 ; ! These bits determine file type.
+
+: S_IFDIR OCT: 40000 ; ! Directory.
+: S_IFCHR OCT: 20000 ; ! Character device.
+: S_IFBLK OCT: 60000 ; ! Block device.
+: S_IFREG OCT: 100000 ; ! Regular file.
+: S_IFIFO OCT: 010000 ; ! FIFO.
+: S_IFLNK OCT: 120000 ; ! Symbolic link.
+: S_IFSOCK OCT: 140000 ; ! Socket.
+
+: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
+
+: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
+: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
+: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
+: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
+: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
+: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
+: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! File Access Permissions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Read, write, execute/search by owner
+: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
+: S_IRUSR OCT: 0000400 ; inline ! r owner
+: S_IWUSR OCT: 0000200 ; inline ! w owner
+: S_IXUSR OCT: 0000100 ; inline ! x owner
+! Read, write, execute/search by group
+: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
+: S_IRGRP OCT: 0000040 ; inline ! r group
+: S_IWGRP OCT: 0000020 ; inline ! w group
+: S_IXGRP OCT: 0000010 ; inline ! x group
+! Read, write, execute/search by others
+: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
+: S_IROTH OCT: 0000004 ; inline ! r other
+: S_IWOTH OCT: 0000002 ; inline ! w other
+: S_IXOTH OCT: 0000001 ; inline ! x other
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+FUNCTION: int chmod ( char* path, mode_t mode ) ;
+
+FUNCTION: int fchmod ( int fd, mode_t mode ) ;
+
+FUNCTION: int mkdir ( char* path, mode_t mode ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+<<
+ os
+ {
+ { "linux" [ "unix.stat.linux" require ] }
+ { "macosx" [ "unix.stat.macosx" require ] }
+ { "freebsd" [ "unix.stat.freebsd" require ] }
+ [ drop ]
+ }
+ case
+>>
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-status ( n -- ) io-error ;
+
+: stat* ( pathname -- stat )
+ "stat" <c-object> dup >r
+ stat check-status
+ r> ;
+
+: lstat* ( pathname -- stat )
+ "stat" <c-object> dup >r
+ lstat check-status
+ r> ;
--- /dev/null
+
+USING: kernel alien.syntax alien.c-types math ;
+
+IN: unix.time
+
+TYPEDEF: uint time_t
+
+C-STRUCT: tm
+ { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
+ { "int" "min" } ! Minutes: 0-59
+ { "int" "hour" } ! Hours since midnight: 0-23
+ { "int" "mday" } ! Day of the month: 1-31
+ { "int" "mon" } ! Months *since* january: 0-11
+ { "int" "year" } ! Years since 1900
+ { "int" "wday" } ! Days since Sunday (0-6)
+ { "int" "yday" } ! Days since Jan. 1: 0-365
+ { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
+ { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
+ { "char*" "zone" } ;
+
+C-STRUCT: timespec
+ { "time_t" "sec" }
+ { "long" "nsec" } ;
+
+: make-timespec ( ms -- timespec )
+ 1000 /mod 1000000 *
+ "timespec" <c-object>
+ [ set-timespec-nsec ] keep
+ [ set-timespec-sec ] keep ;
+
+FUNCTION: time_t time ( time_t* t ) ;
+FUNCTION: tm* localtime ( time_t* clock ) ;
\ No newline at end of file
--- /dev/null
+USING: alien.syntax ;
+
+IN: unix.types
+
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint16_t mode_t
+TYPEDEF: __uint16_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
\ No newline at end of file
--- /dev/null
+
+USING: alien.syntax ;
+
+IN: unix.types
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TYPEDEF: ulonglong __uquad_type
+TYPEDEF: ulong __ulongword_type
+TYPEDEF: long __sword_type
+TYPEDEF: ulong __uword_type
+TYPEDEF: long __slongword_type
+TYPEDEF: uint __u32_type
+TYPEDEF: int __s32_type
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TYPEDEF: __uquad_type dev_t
+TYPEDEF: __ulongword_type ino_t
+TYPEDEF: __u32_type mode_t
+TYPEDEF: __uword_type nlink_t
+TYPEDEF: __u32_type uid_t
+TYPEDEF: __u32_type gid_t
+TYPEDEF: __slongword_type off_t
+TYPEDEF: __slongword_type blksize_t
+TYPEDEF: __slongword_type blkcnt_t
+TYPEDEF: __sword_type ssize_t
+TYPEDEF: __s32_type pid_t
+TYPEDEF: __slongword_type time_t
\ No newline at end of file
--- /dev/null
+
+USING: alien.syntax ;
+
+IN: unix.types
+
+! Darwin 9.1.0 ppc
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TYPEDEF: __int32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint16_t mode_t
+TYPEDEF: __uint16_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __int32_t blksize_t
+TYPEDEF: long ssize_t
+TYPEDEF: __int32_t pid_t
+TYPEDEF: long time_t
--- /dev/null
+
+USING: kernel system alien.syntax combinators vocabs.loader ;
+
+IN: unix.types
+
+TYPEDEF: void* caddr_t
+
+os
+ {
+ { "linux" [ "unix.types.linux" require ] }
+ { "macosx" [ "unix.types.macosx" require ] }
+ { "freebsd" [ "unix.types.freebsd" require ] }
+ [ drop ]
+ }
+case
\ No newline at end of file
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
+
USING: alien alien.c-types alien.syntax kernel libc structs
-math namespaces system combinators vocabs.loader ;
-
-! ! ! Unix types
-TYPEDEF: int blksize_t
-TYPEDEF: int dev_t
-TYPEDEF: long ssize_t
-TYPEDEF: longlong blkcnt_t
-TYPEDEF: longlong quad_t
-TYPEDEF: uint gid_t
+math namespaces system combinators vocabs.loader unix.types ;
+
+IN: unix
+
TYPEDEF: uint in_addr_t
-TYPEDEF: uint ino_t
-TYPEDEF: int pid_t
TYPEDEF: uint socklen_t
-TYPEDEF: uint time_t
-TYPEDEF: uint uid_t
TYPEDEF: ulong size_t
-TYPEDEF: ulong u_long
-TYPEDEF: ushort mode_t
-TYPEDEF: ushort nlink_t
-TYPEDEF: void* caddr_t
-
-TYPEDEF: ulong off_t
-TYPEDEF-IF: bsd? ulonglong off_t
-
-C-STRUCT: tm
- { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
- { "int" "min" } ! Minutes: 0-59
- { "int" "hour" } ! Hours since midnight: 0-23
- { "int" "mday" } ! Day of the month: 1-31
- { "int" "mon" } ! Months *since* january: 0-11
- { "int" "year" } ! Years since 1900
- { "int" "wday" } ! Days since Sunday (0-6)
- { "int" "yday" } ! Days since Jan. 1: 0-365
- { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
- { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
- { "char*" "zone" } ;
-
-C-STRUCT: timespec
- { "time_t" "sec" }
- { "long" "nsec" } ;
-
-: make-timespec ( ms -- timespec )
- 1000 /mod 1000000 *
- "timespec" <c-object>
- [ set-timespec-nsec ] keep
- [ set-timespec-sec ] keep ;
-
-! ! ! Unix constants
-
-! File type
-: S_IFMT OCT: 0170000 ; inline ! type of file
-: S_IFIFO OCT: 0010000 ; inline ! named pipe (fifo)
-: S_IFCHR OCT: 0020000 ; inline ! character special
-: S_IFDIR OCT: 0040000 ; inline ! directory
-: S_IFBLK OCT: 0060000 ; inline ! block special
-: S_IFREG OCT: 0100000 ; inline ! regular
-: S_IFLNK OCT: 0120000 ; inline ! symbolic link
-: S_IFSOCK OCT: 0140000 ; inline ! socket
-: S_IFWHT OCT: 0160000 ; inline ! whiteout
-: S_IFXATTR OCT: 0200000 ; inline ! extended attribute
-
-! File mode
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
-: S_IRUSR OCT: 0000400 ; inline ! r owner
-: S_IWUSR OCT: 0000200 ; inline ! w owner
-: S_IXUSR OCT: 0000100 ; inline ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
-: S_IRGRP OCT: 0000040 ; inline ! r group
-: S_IWGRP OCT: 0000020 ; inline ! w group
-: S_IXGRP OCT: 0000010 ; inline ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
-: S_IROTH OCT: 0000004 ; inline ! r other
-: S_IWOTH OCT: 0000002 ; inline ! w other
-: S_IXOTH OCT: 0000001 ; inline ! x other
-
-: S_ISUID OCT: 0004000 ; inline ! set user id on execution
-: S_ISGID OCT: 0002000 ; inline ! set group id on execution
-: S_ISVTX OCT: 0001000 ; inline ! sticky bit
: PROT_NONE 0 ; inline
: PROT_READ 1 ; inline
: MAP_FAILED -1 <alien> ; inline
+: ESRCH 3 ; inline
+: EEXIST 17 ; inline
+
! ! ! Unix functions
LIBRARY: factor
FUNCTION: int err_no ( ) ;
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
-FUNCTION: int chmod ( char* path, mode_t mode ) ;
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int chroot ( char* path ) ;
FUNCTION: void close ( int fd ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
FUNCTION: int fchdir ( int fd ) ;
-FUNCTION: int fchmod ( int fd, mode_t mode ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
FUNCTION: int flock ( int fd, int operation ) ;
FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ;
FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
-FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
-FUNCTION: int mkdir ( char* path, mode_t mode ) ;
FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: char* strerror ( int errno ) ;
FUNCTION: int system ( char* command ) ;
-FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
{ [ solaris? ] [ "unix.solaris" require ] }
{ [ t ] [ ] }
} cond
+
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: threads io.files io.monitors init kernel\r
-tools.browser namespaces continuations ;\r
+tools.browser namespaces continuations vocabs.loader ;\r
IN: vocabs.monitor\r
\r
! Use file system change monitoring to flush the tags/authors\r
SYMBOL: vocab-monitor\r
\r
: monitor-thread ( -- )\r
- vocab-monitor get-global next-change 2drop reset-cache ;\r
+ vocab-monitor get-global\r
+ next-change 2drop\r
+ t sources-changed? set-global reset-cache ;\r
\r
: start-monitor-thread\r
#! Silently ignore errors during monitor creation since\r
[\r
"" resource-path t <monitor> vocab-monitor set-global\r
[ monitor-thread t ] "Vocabulary monitor" spawn-server drop\r
- ] [ drop ] recover ;\r
+ ] ignore-errors ;\r
\r
[ start-monitor-thread ] "vocabs.monitor" add-init-hook\r
+++ /dev/null
-Chris Double
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: html http http.server.responders io kernel math
-namespaces prettyprint continuations random system sequences
-assocs ;
-IN: webapps.callback
-
-#! Name of the variable holding the continuation used to exit
-#! back to the httpd responder.
-SYMBOL: exit-continuation
-
-#! Tuple to hold global request data. This gets passed to
-#! the continuation when resumed so it can restore things
-#! like 'stdio' so it writes to the correct socket.
-TUPLE: request stream exitcc method url raw-query query header response ;
-
-: <request> ( -- request )
- stdio get
- exit-continuation get
- "method" get
- "request" get
- "raw-query" get
- "query" get
- "header" get
- "response" get
- request construct-boa ;
-
-: restore-request ( -- )
- request get
- dup request-stream stdio set
- dup request-method "method" set
- dup request-raw-query "raw-query" set
- dup request-query "query" set
- dup request-header "header" set
- dup request-response "response" set
- request-exitcc exit-continuation set ;
-
-: update-request ( request new-request -- )
- [ request-stream over set-request-stream ] keep
- [ request-method over set-request-method ] keep
- [ request-url over set-request-url ] keep
- [ request-raw-query over set-request-raw-query ] keep
- [ request-query over set-request-query ] keep
- [ request-header over set-request-header ] keep
- [ request-response over set-request-response ] keep
- request-exitcc swap set-request-exitcc ;
-
-: with-exit-continuation ( quot -- )
- #! Call the quotation with the variable exit-continuation bound
- #! such that when the exit continuation is called, computation
- #! will resume from the end of this 'with-exit-continuation' call.
- [
- exit-continuation set call exit-continuation get continue
- ] callcc0 drop ;
-
-: expiry-timeout ( -- ms ) 900 1000 * ;
-
-: get-random-id ( -- id )
- #! Generate a random id to use for continuation URL's
- 4 big-random unparse ;
-
-: callback-table ( -- <hashtable> )
- #! Return the global table of continuations
- \ callback-table get-global ;
-
-: reset-callback-table ( -- )
- #! Create the initial global table
- H{ } clone \ callback-table set-global ;
-
-reset-callback-table
-
-#! Tuple for holding data related to a callback.
-TUPLE: item quot expire? request id time-added ;
-
-: <item> ( quot expire? request id -- item )
- millis item construct-boa ;
-
-: expired? ( item -- ? )
- #! Return true if the callback item is expirable
- #! and has expired (ie. was added to the table more than
- #! timeout milliseconds ago).
- [ item-time-added expiry-timeout + millis < ] keep
- item-expire? and ;
-
-: expire-callbacks ( -- )
- #! Expire all continuations in the continuation table
- #! if they are 'timeout-seconds' old (ie. were added
- #! more than 'timeout-seconds' ago.
- callback-table clone [
- expired? [ callback-table delete-at ] [ drop ] if
- ] assoc-each ;
-
-: id>url ( id -- string )
- #! Convert the continuation id to an URL suitable for
- #! embedding in an HREF or other HTML.
- "/responder/callback/?id=" swap url-encode append ;
-
-: register-callback ( quot expire? -- url )
- #! Store a continuation in the table and associate it with
- #! a random id. That continuation will be expired after
- #! a certain period of time if 'expire?' is true.
- request get get-random-id [ <item> ] keep
- [ callback-table set-at ] keep
- id>url ;
-
-: register-html-callback ( quot expire? -- url )
- >r [ serving-html ] swap append r> register-callback ;
-
-: callback-responder ( -- )
- expire-callbacks
- "id" query-param callback-table at [
- [
- dup item-request [
- <request> update-request
- ] when*
- item-quot call
- exit-continuation get continue
- ] with-exit-continuation drop
- ] [
- "404 Callback not available" httpd-error
- ] if* ;
-
-global [
- "callback" [ callback-responder ] add-simple-responder
-] bind
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs io.files combinators
-arrays io.launcher io http.server.responders webapps.file
-sequences strings math.parser unicode.case ;
-IN: webapps.cgi
-
-SYMBOL: cgi-root
-
-: post? "method" get "post" = ;
-
-: cgi-variables ( name -- assoc )
- #! This needs some work.
- [
- cgi-root get over path+ "PATH_TRANSLATED" set
- cgi-root get over path+ "SCRIPT_FILENAME" set
- "SCRIPT_NAME" set
-
- "CGI/1.0" "GATEWAY_INTERFACE" set
- "HTTP/1.0" "SERVER_PROTOCOL" set
- "Factor " version append "SERVER_SOFTWARE" set
- host "SERVER_NAME" set
- "" "SERVER_PORT" set
- "request" get "PATH_INFO" set
- "request" get "PATH_TRANSLATED" set
- "" "REMOTE_HOST" set
- "" "REMOTE_ADDR" set
- "" "AUTH_TYPE" set
- "" "REMOTE_USER" set
- "" "REMOTE_IDENT" set
-
- "method" get >upper "REQUEST_METHOD" set
- "raw-query" get "QUERY_STRING" set
- "Cookie" header-param "HTTP_COOKIE" set
-
- "User-Agent" header-param "HTTP_USER_AGENT" set
- "Accept" header-param "HTTP_ACCEPT" set
-
- post? [
- "Content-Type" header-param "CONTENT_TYPE" set
- "raw-response" get length number>string "CONTENT_LENGTH" set
- ] when
- ] H{ } make-assoc ;
-
-: cgi-descriptor ( name -- desc )
- [
- cgi-root get over path+ 1array +arguments+ set
- cgi-variables +environment+ set
- ] H{ } make-assoc ;
-
-: (do-cgi) ( name -- )
- "200 CGI output follows" response
- stdio get swap cgi-descriptor <process-stream> [
- post? [
- "raw-response" get write flush
- ] when
- stdio get swap (stream-copy)
- ] with-stream ;
-
-: serve-regular-file ( -- )
- cgi-root get "doc-root" [ file-responder ] with-variable ;
-
-: do-cgi ( name -- )
- {
- { [ dup ".cgi" tail? not ] [ drop serve-regular-file ] }
- { [ dup empty? ] [ "403 forbidden" httpd-error ] }
- { [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] }
- { [ ".." over subseq? ] [ "403 forbidden" httpd-error ] }
- { [ t ] [ (do-cgi) ] }
- } cond ;
-
-global [
- "cgi" [ "argument" get do-cgi ] add-simple-responder
-] bind
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: http math namespaces io strings kernel html html.elements
-hashtables continuations quotations parser generic sequences
-webapps.callback http.server.responders ;
-IN: webapps.continuation
-
-#! Used inside the session state of responders to indicate whether the
-#! next request should use the post-refresh-get pattern. It is set to
-#! true after each request.
-SYMBOL: post-refresh-get?
-
-: >callable ( quot|interp|f -- interp )
- dup continuation? [
- [ continue ] curry
- ] when ;
-
-: forward-to-url ( url -- )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
- [
- "HTTP/1.1 302 Document Moved\nLocation: " % %
- "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
- ] "" make write exit-continuation get continue ;
-
-: forward-to-id ( id -- )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
- >r "request" get r> id>url append forward-to-url ;
-
-SYMBOL: current-show
-
-: store-current-show ( -- )
- #! Store the current continuation in the variable 'current-show'
- #! so it can be returned to later by href callbacks. Note that it
- #! recalls itself when the continuation is called to ensure that
- #! it resets its value back to the most recent show call.
- [ ( 0 -- )
- [ ( 0 1 -- )
- current-show set ( 0 -- )
- continue
- ] callcc1
- nip
- restore-request
- call
- store-current-show
- ] callcc0 restore-request ;
-
-: redirect-to-here ( -- )
- #! Force a redirect to the client browser so that the browser
- #! goes to the current point in the code. This forces an URL
- #! change on the browser so that refreshing that URL will
- #! immediately run from this code point. This prevents the
- #! "this request will issue a POST" warning from the browser
- #! and prevents re-running the previous POST logic. This is
- #! known as the 'post-refresh-get' pattern.
- post-refresh-get? get [
- [
- >callable t register-callback forward-to-url
- ] callcc0 restore-request
- ] [
- t post-refresh-get? set
- ] if ;
-
-: (show) ( quot -- hashtable )
- #! See comments for show. The difference is the
- #! quotation MUST set the content-type using 'serving-html'
- #! or similar.
- store-current-show redirect-to-here
- [
- >callable t register-callback swap with-scope
- exit-continuation get continue
- ] callcc0 drop restore-request "response" get ;
-
-: show ( quot -- namespace )
- #! Call the quotation with the URL associated with the current
- #! continuation. All output from the quotation goes to the client
- #! browser. When the URL is later referenced then
- #! computation will resume from this 'show' call with a hashtable on
- #! the stack containing any query or post parameters.
- #! 'quot' has stack effect ( url -- )
- #! NOTE: On return from 'show' the stack is exactly the same as
- #! initial entry with 'quot' popped off and the hashtable pushed on. Even
- #! if the quotation consumes items on the stack.
- [ serving-html ] swap append (show) ;
-
-: (show-final) ( quot -- namespace )
- #! See comments for show-final. The difference is the
- #! quotation MUST set the content-type using 'serving-html'
- #! or similar.
- store-current-show redirect-to-here
- with-scope exit-continuation get continue ;
-
-: show-final ( quot -- namespace )
- #! Similar to 'show', except the quotation does not receive the URL
- #! to resume computation following 'show-final'. No continuation is
- #! stored for this resumption. As a result, 'show-final' is for use
- #! when a page is to be displayed with no further action to occur. Its
- #! use is an optimisation to save having to generate and save a continuation
- #! in that special case.
- #! 'quot' has stack effect ( -- ).
- [ serving-html ] swap compose (show-final) ;
-
-#! Name of variable for holding initial continuation id that starts
-#! the responder.
-SYMBOL: root-callback
-
-: cont-get/post-responder ( id-or-f -- )
- #! httpd responder that handles the root continuation request.
- #! The requests for actual continuation are processed by the
- #! 'callback-responder'.
- [
- [ f post-refresh-get? set <request> request set root-callback get call ] with-scope
- exit-continuation get continue
- ] with-exit-continuation drop ;
-
-: quot-url ( quot -- url )
- current-show get [ continue-with ] 2curry t register-callback ;
-
-: quot-href ( text quot -- )
- #! Write to standard output an HTML HREF where the href,
- #! when referenced, will call the quotation and then return
- #! back to the most recent 'show' call (via the callback-cc).
- #! The text of the link will be the 'text' argument on the
- #! stack.
- <a quot-url =href a> write </a> ;
-
-: install-cont-responder ( name quot -- )
- #! Install a cont-responder with the given name
- #! that will initially run the given quotation.
- #!
- #! Convert the quotation so it is run within a session namespace
- #! and that namespace is initialized first.
- [
- [ cont-get/post-responder ] "get" set
- [ cont-get/post-responder ] "post" set
- swap "responder" set
- root-callback set
- ] make-responder ;
-
-: show-message-page ( message -- )
- #! Display the message in an HTML page with an OK button.
- [
- "Press OK to Continue" [
- swap paragraph
- <a =href a> "OK" write </a>
- ] simple-page
- ] show 2drop ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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.
-!
-! Simple test applications
-USING: hashtables html kernel io html html.elements strings math
-assocs quotations webapps.continuation namespaces prettyprint
-sequences ;
-
-IN: webapps.continuation.examples
-
-: display-page ( title -- )
- #! Display a page with some text to test the cont-responder.
- #! The page has a link to the 'next' continuation.
- [
- <h1> over write </h1>
- swap [
- <a =href a> "Next" write </a>
- ] simple-html-document
- ] show 2drop ;
-
-: display-get-name-page ( -- name )
- #! Display a page prompting for input of a name and return that name.
- [
- "Enter your name" [
- <h1> swap write </h1>
- <form "post" =method =action form>
- "Name: " write
- <input "text" =type "name" =name "20" =size input/>
- <input "submit" =type "Ok" =value input/>
- </form>
- ] simple-html-document
- ] show "name" swap at ;
-
-: test-cont-responder ( -- )
- #! Test the cont-responder responder by displaying a few pages in a row.
- "Page one" display-page
- "Hello " display-get-name-page append display-page
- "Page three" display-page ;
-
-: test-cont-responder2 ( -- )
- #! Test the cont-responder responder by displaying a few pages in a loop.
- [ "one" "two" "three" "four" ] [ display-page ] each
- "Done!" display-page ;
-
-: test-cont-responder3 ( -- )
- #! Test the quot-href word by displaying a menu of the current
- #! test words. Note that we use show-final as we don't link to a 'next' page.
- [
- "Menu" [
- <h1> "Menu" write </h1>
- <ol>
- <li> "Test responder1" [ test-cont-responder ] quot-href </li>
- <li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
- </ol>
- ] simple-html-document
- ] show-final ;
-
-: counter-example ( count -- )
- #! Display a counter which can be incremented or decremented
- #! using anchors.
- #!
- #! Don't need the original alist
- [
- #! And we don't need the 'url' argument
- drop
- "Counter: " over unparse append [
- dup <h2> unparse write </h2>
- "++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href
- "--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href
- drop
- ] simple-html-document
- ] show drop ;
-
-: counter-example2 ( -- )
- #! Display a counter which can be incremented or decremented
- #! using anchors.
- #!
- 0 "counter" set
- [
- #! We don't need the 'url' argument
- drop
- "Counter: " "counter" get unparse append [
- <h2> "counter" get unparse write </h2>
- "++" [ "counter" get 1 + "counter" set ] quot-href
- "--" [ "counter" get 1 - "counter" set ] quot-href
- ] simple-html-document
- ] show
- drop ;
-
-! Install the examples
-"counter1" [ drop 0 counter-example ] install-cont-responder
-"counter2" [ drop counter-example2 ] install-cont-responder
-"test1" [ test-cont-responder ] install-cont-responder
-"test2" [ drop test-cont-responder2 ] install-cont-responder
-"test3" [ drop test-cont-responder3 ] install-cont-responder
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: calendar html io io.files kernel math math.parser
-http.server.responders http.server.templating namespaces parser
-sequences strings assocs hashtables debugger http.mime sorting
-html.elements logging ;
-
-IN: webapps.file
-
-: serving-path ( filename -- filename )
- "" or "doc-root" get swap path+ ;
-
-: file-http-date ( filename -- string )
- file-modified unix-time>timestamp timestamp>http-string ;
-
-: file-response ( filename mime-type -- )
- "200 OK" response
- [
- "Content-Type" set
- dup file-length number>string "Content-Length" set
- file-http-date "Last-Modified" set
- now timestamp>http-string "Date" set
- ] H{ } make-assoc print-header ;
-
-: last-modified-matches? ( filename -- bool )
- file-http-date dup [
- "If-Modified-Since" header-param =
- ] when ;
-
-: not-modified-response ( -- )
- "304 Not Modified" response
- now timestamp>http-string "Date" associate print-header ;
-
-! You can override how files are served in a custom responder
-SYMBOL: serve-file-hook
-
-[
- dupd
- file-response
- <file-reader> stdio get stream-copy
-] serve-file-hook set-global
-
-: serve-static ( filename mime-type -- )
- over last-modified-matches? [
- 2drop not-modified-response
- ] [
- "method" get "head" = [
- file-response
- ] [
- serve-file-hook get call
- ] if
- ] if ;
-
-SYMBOL: page
-
-: run-page ( filename -- )
- dup
- [ [ dup page set run-template-file ] with-scope ] try
- drop ;
-
-\ run-page DEBUG add-input-logging
-
-: include-page ( filename -- )
- "doc-root" get swap path+ run-page ;
-
-: serve-fhtml ( filename -- )
- serving-html
- "method" get "head" = [ drop ] [ run-page ] if ;
-
-: serve-file ( filename -- )
- dup mime-type dup "application/x-factor-server-page" =
- [ drop serve-fhtml ] [ serve-static ] if ;
-
-\ serve-file NOTICE add-input-logging
-
-: file. ( name dirp -- )
- [ "/" append ] when
- dup <a =href a> write </a> ;
-
-: directory. ( path request -- )
- dup [
- <h1> write </h1>
- <ul>
- directory sort-keys
- [ <li> file. </li> ] assoc-each
- </ul>
- ] simple-html-document ;
-
-: list-directory ( directory -- )
- serving-html
- "method" get "head" = [
- drop
- ] [
- "request" get directory.
- ] if ;
-
-: find-index ( filename -- path )
- { "index.html" "index.fhtml" }
- [ dupd path+ exists? ] find nip
- dup [ path+ ] [ nip ] if ;
-
-: serve-directory ( filename -- )
- dup "/" tail? [
- dup find-index
- [ serve-file ] [ list-directory ] ?if
- ] [
- drop directory-no/
- ] if ;
-
-: serve-object ( filename -- )
- serving-path dup exists? [
- dup directory? [ serve-directory ] [ serve-file ] if
- ] [
- drop "404 not found" httpd-error
- ] if ;
-
-: file-responder ( -- )
- "doc-root" get [
- "argument" get serve-object
- ] [
- "404 doc-root not set" httpd-error
- ] if ;
-
-global [
- ! Serves files from a directory stored in the "doc-root"
- ! variable. You can set the variable in the global
- ! namespace, or inside the responder.
- "file" [ file-responder ] add-simple-responder
-
- ! The root directory is served by...
- "file" set-default-responder
-] bind
\ No newline at end of file
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2006 Chris Double. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel furnace fjsc peg namespaces
- lazy-lists io io.files furnace.validator sequences
- http.client http.server http.server.responders
- webapps.file html ;
-IN: webapps.fjsc
-
-: compile ( code -- )
- #! Compile the factor code as a string, outputting the http
- #! response containing the javascript.
- serving-text
- 'expression' parse parse-result-ast fjsc-compile
- write flush ;
-
-! The 'compile' action results in an URL that looks like
-! 'responder/fjsc/compile'. It takes one query or post
-! parameter called 'code'. It calls the 'compile' word
-! passing the parameter to it on the stack.
-\ compile {
- { "code" v-required }
-} define-action
-
-: compile-url ( url -- )
- #! Compile the factor code at the given url, return the javascript.
- dup "http:" head? [ "Unable to access remote sites." throw ] when
- "http://" "Host" header-param rot 3append http-get compile "();" write flush ;
-
-\ compile-url {
- { "url" v-required }
-} define-action
-
-: render-page* ( model body-template head-template -- )
- [
- [ render-component ] [ f rot render-component ] html-document
- ] serve-html ;
-
-: repl ( -- )
- #! The main 'repl' page.
- f "repl" "head" render-page* ;
-
-! An action called 'repl'
-\ repl { } define-action
-
-: fjsc-web-app ( -- )
- ! Create the web app, providing access
- ! under '/responder/fjsc' which calls the
- ! 'repl' action.
- "fjsc" "repl" "extra/webapps/fjsc" web-app
-
- ! An URL to the javascript resource files used by
- ! the 'fjsc' responder.
- "fjsc-resources" [
- [
- "extra/fjsc/resources/" resource-path "doc-root" set
- file-responder
- ] with-scope
- ] add-simple-responder
-
- ! An URL to the resource files used by
- ! 'termlib'.
- "fjsc-repl-resources" [
- [
- "extra/webapps/fjsc/resources/" resource-path "doc-root" set
- file-responder
- ] with-scope
- ] add-simple-responder ;
-
-MAIN: fjsc-web-app
+++ /dev/null
-<title>Factor to Javascript REPL</title>\r
-<link rel="stylesheet" type="text/css" href="/responder/fjsc-repl-resources/termlib/term_styles.css"/>\r
-<script type="text/javascript" src="/responder/fjsc-repl-resources/termlib/termlib.js"></script>\r
-<script type="text/javascript" src="/responder/fjsc-resources/jquery.js"></script>\r
-<script type="text/javascript" src="/responder/fjsc-resources/bootstrap.js"></script>\r
-<script type="text/javascript" src="/responder/fjsc-repl-resources/repl.js"></script>\r
-<script type="text/javascript" src="/responder/fjsc/compile-url?url=/responder/fjsc-resources/bootstrap.factor"></script>\r
+++ /dev/null
-<table border="0">
-<tr><td valign="top">
-<div id="repl" style="position:relative;"></div>
-<p>More information on the Factor to Javascript compiler can be found at these blog posts:
-<ul>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/compiling-factor-to-javascript.html">Factor to Javascript Compiler</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/factor-to-javascript-compiler-updates.html">Factor to Javascript Compiler Updates</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/continuations-added-to-fjsc.html">Continuations added to fjsc</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2006/12/cross-domain-json-with-fjsc.html">Cross Domain JSON with fjsc</a></li>
-<li><a href="http://www.bluishcoder.co.nz/2007/02/factor-to-javascript-compiler-makeover.html">Factor to Javascript Compiler Makeover</a></li>
-</ul>
-</p>
-<p>The terminal emulation code for the Factor REPL is provided by the awesome <a href="http://www.masswerk.at/termlib/index.html">termlib</a> library by Norbert Landsteiner. Documentation for termlib is <a href="/responder/fjsc-repl-resources/termlib/">available here</a>. Please note the license of 'termlib':</p>
-<blockquote>This JavaScript-library is free for private and academic use. Please include a readable copyright statement and a backlink to <http://www.masswerk.at> in the web page. The library should always be accompanied by the "readme.txt" and the sample HTML-documents.
-
-The term "private use" includes any personal or non-commercial use, which is not related to commercial activites, but excludes intranet, extranet and/or public net applications that are related to any kind of commercial or profit oriented activity.
-
-For commercial use see <a href="http://www.masswerk.at">http://www.masswerk.at</a> for contact information.</blockquote>
-</td>
-<td valign="top">
-<p><b>Stack</b></p>
-<div id="stack">
-</div>
-<p><b>Playground</b></p>
-<div id="playground">
-</div>
-<h3>Compiled Code</h3>
-<textarea id="compiled" cols="40" rows="10">
-</textarea>
-<p>Some useful words:
-<dl>
-<dt>vocabs ( -- seq )</dt>
-<dd>Return a sequence of available vocabularies</dd>
-<dt>words ( string -- seq )</dt>
-<dd>Return a sequence of words in the given vocabulary</dd>
-<dt>all-words ( -- seq )</dt>
-<dd>Return a sequence of all words</dd>
-</dl>
-</p>
-<p>The contents of <a href="/responder/fjsc-resources/bootstrap.factor">bootstrap.factor</a> have been loaded on startup.</p>
-</td>
-</tr>
-</table>
+++ /dev/null
-/* Copyright (C) 2007 Chris Double. All Rights Reserved.\r
- See http://factorcode.org/license.txt for BSD license. */\r
-\r
-var fjsc_repl = false;\r
-\r
-function fjsc_repl_handler() {\r
- var my_term = this;\r
- this.newLine();\r
- if(this.lineBuffer != '') {\r
- factor.server_eval(\r
- this.lineBuffer, \r
- function(text, result) { \r
- document.getElementById("compiled").value = result;\r
- display_datastack(); \r
- }, \r
- function() { my_term.prompt(); });\r
- }\r
- else\r
- my_term.prompt();\r
-}\r
-\r
-function fjsc_init_handler() {\r
- this.write(\r
- [\r
- TermGlobals.center('********************************************************'),\r
- TermGlobals.center('* *'),\r
- TermGlobals.center('* Factor to Javascript Compiler Example *'),\r
- TermGlobals.center('* *'),\r
- TermGlobals.center('********************************************************')\r
- ]);\r
- \r
- this.prompt();\r
-}\r
-\r
-function startup() {\r
- var conf = {\r
- x: 0,\r
- y: 0,\r
- cols: 64,\r
- rows: 18,\r
- termDiv: "repl",\r
- crsrBlinkMode: true,\r
- ps: "scratchpad ",\r
- initHandler: fjsc_init_handler,\r
- handler: fjsc_repl_handler\r
- };\r
- fjsc_repl = new Terminal(conf);\r
- fjsc_repl.open();\r
-}\r
-\r
-function display_datastack() {\r
- var html=[];\r
- html.push("<table border='1'>")\r
- for(var i = 0; i < factor.cont.data_stack.length; ++i) {\r
- html.push("<tr><td>")\r
- html.push(factor.cont.data_stack[i])\r
- html.push("</td></tr>")\r
- }\r
- html.push("</table>")\r
- document.getElementById('stack').innerHTML=html.join("");\r
-}\r
-\r
-jQuery(function() {\r
- startup();\r
- display_datastack();\r
-});\r
-\r
-factor.add_word("kernel", ".s", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- for(var i=0; i<stack.length; ++i) {\r
- term.type(""+stack[i]);\r
- term.newLine();\r
- }\r
- factor.call_next(next);\r
-});\r
-\r
-factor.add_word("io", "print", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- term.type(""+stack.pop());\r
- term.newLine();\r
- factor.call_next(next);\r
-});\r
-\r
-factor.add_word("io", "write", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- term.type(""+stack.pop());\r
- factor.call_next(next);\r
-});\r
-\r
-factor.add_word("io", ".", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- term.type(""+stack.pop());\r
- term.newLine();\r
- factor.call_next(next);\r
-});\r
+++ /dev/null
-<HTML>\r
-<HEAD>\r
- <TITLE>mass:werk termlib faq</TITLE>\r
-\r
-<STYLE TYPE="text/css">\r
-body,p,a,td {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #cccccc;\r
-}\r
-.lh13 {\r
- line-height: 13px;\r
-}\r
-.lh15 {\r
- line-height: 15px;\r
-}\r
-pre {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- color: #ccffaa;\r
- font-size: 12px;\r
- line-height: 15px;\r
-}\r
-.prop {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- color: #bbee99;\r
- font-size: 12px;\r
- line-height: 15px;\r
-}\r
-h1 {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 16px;\r
- color: #cccccc;\r
-}\r
-b.quest {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 14px;\r
- font-weight: bold;\r
- color: #bbee99;\r
-}\r
-a,a:link,a:visited {\r
- text-decoration: none;\r
- color: #77dd11;\r
-}\r
-a:hover {\r
- text-decoration: underline;\r
- color: #77dd11;\r
-}\r
-a:active {\r
- text-decoration: underline;\r
- color: #dddddd;\r
-}\r
-\r
-@media print {\r
- body { background-color: #ffffff; }\r
- body,p,a,td {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #000000;\r
- }\r
- .lh13 {\r
- line-height: 13px;\r
- }\r
- .lh15 {\r
- line-height: 15px;\r
- }\r
- pre,.prop {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #000000;\r
- line-height: 15px;\r
- }\r
- h1 {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 16px;\r
- color: #000000;\r
- }\r
- b.quest {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 14px;\r
- font-weight: bold;\r
- color: #000000;\r
- }\r
- a,a:link,a:visited {\r
- text-decoration: none;\r
- color: #000000;\r
- }\r
- a:hover {\r
- text-decoration: underline;\r
- color: #000000;\r
- }\r
- a:active {\r
- text-decoration: underline;\r
- color: #000000;\r
- }\r
-}\r
-</STYLE>\r
-</HEAD>\r
-\r
-\r
-<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
-TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0"><A NAME="top"></A>\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
-<TR>\r
- <TD NOWRAP><A HREF="index.html">termlib.js home</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="multiterm_test.html">multiple terminal test</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="parser_sample.html">sample parser</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP>faq</TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
-</TR>\r
-</TABLE>\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" WIDTH="700" ALIGN="center">\r
- <TR><TD>\r
- <H1>frequently asked questions</H1>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <BR>\r
- <UL>\r
- <LI CLASS="lh15"><A HREF="#chrome">Can I add chrome to the terminal? (e.g. a window header, a close box)</A></LI>\r
- <LI CLASS="lh15"><A HREF="#embed">How can I embed a terminal relative to my HTML layout?</A></LI>\r
- <LI CLASS="lh15"><A HREF="#syntax">I pasted your sample code and just got an error. - ???</A></LI>\r
- <LI CLASS="lh15"><A HREF="#keyboard">I can't get any input, but I don't get any erros too.</A></LI>\r
- <LI CLASS="lh15"><A HREF="#keylock">How can I temporary disable the keyboard handlers?</A></LI>\r
- <LI CLASS="lh15"><A HREF="#linesranges">How can I set the cusor to the start / the end of the command line?</A></LI>\r
- <LI CLASS="lh15"><A HREF="#historyunique">How can I limit the command history to unique entries only?</A></LI>\r
- <LI CLASS="lh15"><A HREF="#rebuild">How can I change my color theme on the fly?</A></LI>\r
- <LI CLASS="lh15"><A HREF="#connect">How can I connect to a server?</A></LI>\r
- </UL>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="chrome"></A>\r
- <BR>\r
-<B CLASS="quest">Can I add chrome to the terminal? (e.g. a window header, a close box)</B><BR><BR>\r
-\r
-Not by the means of the Terminal object's interface (since there are way too many things that you may possibly want to add).<BR>\r
-The Terminal object allows you to specify the background color, the frame color, the frame's width and the font class used. If you want to add more chrome, you must align this in a separate division element.<BR><BR>\r
-\r
-To calculate the dimensions of the terminal use this formula:<BR><BR>\r
-\r
-width: 2 * frameWidth + conf.cols * <width of > + 2 * 2px padding (left and right)<BR>\r
-height: 2 * frameWidth + conf.rows * conf.rowHeight + 2 * 2px padding (top and bottom).<BR><BR>\r
-\r
-Or you could get the empirical values for width and height by calling a terminal's `<SPAN CLASS="prop">getDimensions()</SPAN>' method, once the terminal is open. (see documentation in "readme.txt").<BR><BR>\r
-\r
-Finnally, you could obviously embed the terminal's division element in your custom chrome layout (see below). [This will not be compatible to Netscape 4.]<BR><BR>\r
-\r
-p.e.:<PRE>\r
- <div id="myTerminal1" style="position:absolute; top:100px; left:100px;">\r
- <table class="termChrome">\r
- <tbody>\r
- <tr>\r
- <td class="termTitle">terminal 1</td>\r
- </tr>\r
- <tr>\r
- <td class="termBody"><div id="termDiv1" style="position:relative"></div></td>\r
- </tr>\r
- </tbody>\r
- </table>\r
- </div>\r
-\r
- // get a terminal for this\r
-\r
- var term1 = new Terminal(\r
- {\r
- x: 0,\r
- y: 0,\r
- id: 1,\r
- termDiv: "termDiv1",\r
- handler: myTermHandler\r
- }\r
- );\r
- term1.open();\r
- \r
- // and this is how to move the chrome and the embedded terminal\r
-\r
- TermGlobals.setElementXY( "myTerminal1", 200, 80 );\r
-</PRE>\r
-To keep track of the instance for any widgets use the terminal's `id' property. (You must set this in the configuration object to a unique value for this purpose.)<BR><BR>\r
-\r
-For a demonstration see the <A HREF="chrome_sample.html">Chrome Sample Page</A>.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="embed"></A>\r
- <BR>\r
-<B CLASS="quest">How can I embed a terminal relative to my HTML layout?</B><BR><BR>\r
-\r
-Define your devision element with attribute "position" set to "relative" and place this inside your layout. Call "new Terminal()" with config-values { x: 0, y: 0 } to leave it at its relative origin.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="syntax"></A>\r
- <BR>\r
-<B CLASS="quest">I pasted your sample code and just got an error. - ???</B><BR><BR>\r
-\r
-The short examples are kept arbitrarily simple to show the syntax.<BR>\r
-Make sure that your divison element(s) is/are rendered by the browser before `Terminal.open()' is called.<BR><BR>\r
-\r
-Does not work:\r
-<PRE> <head>\r
- <script>\r
- var term = new Terminal();\r
- term.open();\r
- </script>\r
- </head>\r
-</PRE>\r
-Does work:\r
-<PRE> <head>\r
- <script>\r
- var term;\r
- \r
- function termOpen() {\r
- // to be called from outside after compile time\r
- term = new Terminal();\r
- term.open();\r
- }\r
- </script>\r
- </head>\r
-</PRE>\r
-c.f. "readme.txt"<BR>\r
-(Opening a terminal by clicking a link implies also that the page has currently focus.)<BR><BR>\r
-With v.1.01 and higher this doesn't cause an error any more.<BR>`Terminal.prototype.open()' now returns a value for success.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="keyboard"></A>\r
- <BR>\r
-<B CLASS="quest">I can't get any input, but I don't get any erros too.</B><BR><BR>\r
-\r
-The Terminal object's functionality relies on the browsers ability to generate and handle keyboard events.<BR>\r
-Sadly some browsers lack a full implementation of the event model. (e.g. Konquerer [khtml] and early versions of Apple Safari, which is a descendant of khtml.)\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="keylock"></A>\r
- <BR>\r
-<B CLASS="quest">How can I temporary disable the keyboard handlers?</B><BR>\r
-<SPAN CLASS="prop">(The terminal is blocking my HTML form fields, etc.)</SPAN><BR><BR>\r
-\r
-With version 1.03 there's a global property `<SPAN CLASS="prop">TermGlobals.keylock</SPAN>'. Set this to `true' to disable the keyboard handlers without altering any other state. Reset it to `false' to continue with your terminal session(s).\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="linesranges"></A>\r
- <BR>\r
-<B CLASS="quest">How can I set the cusor to the start / the end of the command line?</B><BR><BR>\r
-\r
-In case you need to implement a shortcut (like ^A of some UN*X-shells) to jump to the beginning or the end of the current input line, there are two private instance methods you could utilize:<BR><BR>\r
-`<SPAN CLASS="prop">_getLineEnd(<row>, <col>)</SPAN>' returns an array [<row>, <col>] with the position of the last character in the logical input line with ASCII value >= 32 (0x20).<BR><BR>\r
-`<SPAN CLASS="prop">_getLineStart(<row>, <col>)</SPAN>' returns an array [<row>, <col>] with the position of the first character in the logical input line with ASCII value >= 32 (0x20).<BR><BR>\r
-Both take a row and a column of a cursor position as arguments.<BR><BR>\r
-\r
-p.e.:\r
-<PRE>\r
- // jump to the start of the input line\r
-\r
- myCtrlHandler() {\r
- // catch ^A and jump to start of the line\r
- if (this.inputChar == 1) {\r
- var firstChar = this._getLineStart(this.r, this.c);\r
- this.cursorSet(firstChar[0], firstChar[1]);\r
- }\r
- }</PRE>\r
-(Keep in mind that this is not exactly a good example, since some browser actually don't issue a keyboard event for \r
-"^A". And other browsers, which do catch such codes, are not very reliable in that.)\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="historyunique"></A>\r
- <BR>\r
-<B CLASS="quest">How can I limit the command history to unique entries only?</B><BR>\r
- <SPAN CLASS="prop">(My application effords commands to be commonly repeated.)</SPAN><BR><BR>\r
-\r
-With version 1.05 there is a new configuration and control flag `<SPAN CLASS="prop">historyUnique</SPAN>'. All you need is setting this to `true' in your terminal's configuration object.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="rebuild"></A>\r
- <BR>\r
-<B CLASS="quest">How can I change my color theme on the fly?</B><BR><BR>\r
-\r
-With version 1.07 there is a new method `<SPAN CLASS="prop">Terminal.rebuild()</SPAN>'.<BR>\r
-This method updates the GUI to current config settings while preserving all other state.<BR><BR>\r
-p.e.:\r
-<PRE>\r
- // change color settings on the fly\r
- // here: set bgColor to white and font style to class "termWhite"\r
- // method rebuild() updates the GUI without side effects\r
- // assume var term holds a referene to a Terminal object already active\r
-\r
- term.conf.bgColor = '#ffffff';\r
- term.conf.fontClass = 'termWhite';\r
- term.rebuild();</PRE>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13"><A NAME="connect"></A>\r
- <BR>\r
-<B CLASS="quest">How can I connect to a server?</B><BR><BR>\r
-\r
-The Terminal object only provides an interface to handle console input and output.<BR>\r
-External connections have to be handled outside the Terminal object. You could use the XMLHttpRequest-Object (and use a communication model like AJAX or JSON) or connect via a frame or iframe element to a foreign host.<BR><BR>\r
-Handling connections is considered to be out of the realm of the "termlib.js" library.<BR>\r
-The code you need is in fact quite simple:\r
-<PRE>\r
- function connectToHost(url) {\r
- if (window.XMLHttpRequest) {\r
- request = new XMLHttpRequest();\r
- }\r
- else if (window.ActiveXObject) {\r
- request = new ActiveXObject('Microsoft.XMLHTTP');\r
- }\r
- if (request) {\r
- request.onreadystatechange = requestChangeHandler;\r
- request.open('GET', url);\r
- request.send('');\r
- }\r
- else {\r
- // XMLHttpRequest not implemented\r
- }\r
- }\r
- \r
- function requestChangeHandler() {\r
- if (request.readyState == 4) {\r
- // readyState 4: complete; now test for server's response status\r
- if (request.status == 200) {\r
- // response in request.responseText or request.responseXML if XML-code\r
- // if it's JS-code we could get this by eval(request.responseText)\r
- // by this we could import whole functions to be used via the terminal\r
- }\r
- else {\r
- // connection error\r
- // status code and message in request.status and request.statusText\r
- }\r
- }\r
- }\r
-</PRE>\r
-You should use this only together with a timer (window.setTimeout()) to handle connection timeouts.<BR>\r
-Additionally you would need some syntax to authenticate and tell the server what you want.<BR>\r
-For this purpose you could use the following methods of the XMLHttpRequest object:<BR><BR>\r
-\r
- <TABLE BORDER="0" CELLSPACING="0" CELLPADDING="3">\r
- <TR VALIGN="top"><TD NOWRAP CLASS="prop">setRequestHeader("<I>headerLabel</I>", "<I>value</I>")</TD><TD>set a HTTP header to be sent to the server</TD></TR>\r
- <TR VALIGN="top"><TD NOWRAP CLASS="prop">getResponseHeader("<I>headerLabel</I>")</TD><TD>get a HTTP header sent from the server</TD></TR>\r
- <TR VALIGN="top"><TD NOWRAP CLASS="prop">open(<I>method</I>, "<I>url</I>" [, <I>asyncFlag</I> [,<BR> "<I>userid</I>" [, "<I>password</I>"]]])</TD><TD>assign the destination properties to the request.<BR>be aware that userid and password are not encrypted!</TD></TR>\r
- <TR VALIGN="top"><TD NOWRAP CLASS="prop">send(<I>content</I>)</TD><TD>transmit a message body (post-string or DOM object)</TD></TR>\r
- <TR VALIGN="top"><TD NOWRAP CLASS="prop">abort()</TD><TD>use this to stop a pending connection</TD></TR>\r
- </TABLE>\r
-\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <BR>\r
- Norbert Landsteiner - August 2005<BR>\r
- <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <BR>\r
- <A HREF="#top">> top of page</A>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- \r
- </TD></TR>\r
-</TABLE>\r
-\r
-<DIV ID="termDiv" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
-\r
-</BODY>\r
-</HTML>
\ No newline at end of file
+++ /dev/null
-<HTML>\r
-<HEAD>\r
- <TITLE>mass:werk termlib</TITLE>\r
-\r
-<STYLE TYPE="text/css">\r
-body,p,a,td {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #cccccc;\r
-}\r
-.lh13 {\r
- line-height: 13px;\r
-}\r
-.lh15 {\r
- line-height: 15px;\r
-}\r
-pre {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #ccffaa;\r
- line-height: 15px;\r
-}\r
-.prop {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- color: #bbee99;\r
- font-size: 12px;\r
- line-height: 15px;\r
-}\r
-h1 {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 16px;\r
- color: #cccccc;\r
-}\r
-a,a:link,a:visited {\r
- text-decoration: none;\r
- color: #77dd11;\r
-}\r
-a:hover {\r
- text-decoration: underline;\r
- color: #77dd11;\r
-}\r
-a:active {\r
- text-decoration: underline;\r
- color: #dddddd;\r
-}\r
-\r
-@media print {\r
- body { background-color: #ffffff; }\r
- body,p,a,td {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #000000;\r
- }\r
- .lh13 {\r
- line-height: 13px;\r
- }\r
- .lh15 {\r
- line-height: 15px;\r
- }\r
- pre,.prop {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #000000;\r
- line-height: 15px;\r
- }\r
- h1 {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 16px;\r
- color: #000000;\r
- }\r
- a,a:link,a:visited {\r
- text-decoration: none;\r
- color: #000000;\r
- }\r
- a:hover {\r
- text-decoration: underline;\r
- color: #000000;\r
- }\r
- a:active {\r
- text-decoration: underline;\r
- color: #000000;\r
- }\r
-}\r
-</STYLE>\r
-</HEAD>\r
-\r
-\r
-<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
-TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0"><A NAME="top"></A>\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
-<TR>\r
- <TD NOWRAP>termlib.js home</TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="multiterm_test.html">multiple terminal test</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="parser_sample.html">sample parser</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="faq.html">faq</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
-</TR>\r
-</TABLE>\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" WIDTH="700" ALIGN="center">\r
- <TR><TD>\r
- <H1>mass:werk termlib.js</H1>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- The JavaScript library "termlib.js" provides a `Terminal' object, which\r
- facillitates a simple and object oriented approach to generate and control a\r
- terminal-like interface for web services.<BR><BR>\r
- \r
- "termlib.js" features direct keyboard input and powerful output methods\r
- for multiple and simultanious instances of the `Terminal' object.<BR><BR>\r
- \r
- The library was written with the aim of simple usage and a maximum of compatibility\r
- with minimal foot print in the global namespace.<BR><BR><BR>\r
- \r
- \r
- A short example:<BR>\r
- <PRE>\r
- var term = new Terminal( {handler: termHandler} );\r
- term.open();\r
-\r
- function termHandler() {\r
- this.newLine();\r
- var line = this.lineBuffer;\r
- if (line != "") {\r
- this.write("You typed: "+line);\r
- }\r
- this.prompt();\r
- }\r
- </PRE>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <B>License</B><BR><BR>\r
-\r
- This JavaScript-library is <U>free for private and academic use</U>.\r
- Please include a readable copyright statement and a backlink to <http://www.masswerk.at> in the\r
- web page. The library should always be accompanied by the "readme.txt" and the sample HTML-documents.<BR><BR>\r
-\r
- The term "private use" includes any personal or non-commercial use, which is not related\r
- to commercial activites, but excludes intranet, extranet and/or public net applications\r
- that are related to any kind of commercial or profit oriented activity.<BR><BR>\r
-\r
- For commercial use see <<A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>> for contact information.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <B>Distribution</B><BR><BR>\r
-\r
- This JavaScript-library may be distributed freely as long it is distributed together with the "readme.txt" and the sample HTML-documents and this document.<BR><BR>\r
-\r
- Any changes to the library should be commented and be documented in the readme-file.<BR>\r
- Any changes must be reflected in the `Terminal.version' string as "Version.Subversion (compatibility)".\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <B>Disclaimer</B><BR><BR>\r
-\r
- This software is distributed AS IS and in the hope that it will be useful, but WITHOUT ANY\r
- WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
- PURPOSE. The entire risk as to the quality and performance of the product is borne by the\r
- user. No use of the product is authorized hereunder except under this disclaimer.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <B>History</B><BR><BR>\r
-\r
- This library evolved from the terminal script "TermApp" ((c) N. Landsteiner 2003) and is in its\r
- current form a down scaled spinn-off of the "JS/UIX" project. (JS/UIX is not a free software by now.)\r
- c.f.: <<A HREF="http://www.masswerk.at/jsuix/" TARGET="_blank">http://www.masswerk.at/jsuix</A>><BR><BR>\r
-\r
- For version history: see the <A HREF="readme.txt">readme.txt</A>.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <BR>\r
- <B>Download</B><BR><BR>\r
- Be sure to have read the license information and the disclamer and that you are willing to respect copyrights.<BR><BR>\r
-\r
- <SPAN CLASS="prop">Download:</SPAN> <A HREF="termlib.zip">termlib.zip</A> (~ 40 KB, incl. docs)<BR><BR>\r
- Current version is "1.07 (original)".<BR>\r
- The files are now provided with line breaks in format <CRLF>.<BR>\r
- \r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <B>Author</B><BR><BR>\r
- © Norbert Landsteiner 2003-2005<BR>\r
- mass:werk – media environments<BR>\r
- <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <BR>\r
- Author's note:<BR>\r
- Please do not contact me on questions of simple usage. There is an extensive documentation (readme.txt) including plenty of sample code that should provide all information you need.\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- <BR>\r
- <A HREF="#top">> top of page</A>\r
- </TD></TR>\r
- <TR><TD CLASS="lh13">\r
- \r
- </TD></TR>\r
-</TABLE>\r
-\r
-<DIV ID="termDiv" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
-\r
-</BODY>\r
-</HTML>
\ No newline at end of file
+++ /dev/null
-<HTML>\r
-<HEAD>\r
- <TITLE>termlib Multiple Terminal Test</TITLE>\r
- <SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="termlib.js"></SCRIPT>\r
-\r
-<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript">\r
-<!--\r
-\r
-/*\r
- multiple terminal test for termlib.js\r
-\r
- (c) Norbert Landsteiner 2003-2005\r
- mass:werk - media environments\r
- <http://www.masswerk.at>\r
-\r
-*/\r
-\r
-var term=new Array();\r
-\r
-var helpPage=[\r
- '%CS%+r Terminal Help %-r%n',\r
- ' This is just a tiny test for multiple terminals.',\r
- ' use one of the following commands:',\r
- ' clear .... clear the terminal',\r
- ' exit ..... close the terminal (or <ESC>)',\r
- ' id ....... show terminal\'s id',\r
- ' switch ... switch to other terminal',\r
- ' help ..... show this help page',\r
- ' other input will be echoed to the terminal.',\r
- ' '\r
-];\r
-\r
-function termOpen(n) {\r
- if (!term[n]) {\r
- var y=(n==1)? 70: 280;\r
- term[n]=new Terminal(\r
- {\r
- x: 220,\r
- y: y,\r
- rows: 12,\r
- greeting: '%+r +++ Terminal #'+n+' ready. +++ %-r%nType "help" for help.%n',\r
- id: n,\r
- termDiv: 'termDiv'+n,\r
- crsrBlinkMode: true,\r
- handler: termHandler,\r
- exitHandler: termExitHandler\r
- }\r
- );\r
- if (term[n]) term[n].open();\r
- }\r
- else if (term[n].closed) {\r
- term[n].open();\r
- }\r
- else {\r
- term[n].focus();\r
- }\r
-}\r
-\r
-function termHandler() {\r
- // called on <CR> or <ENTER>\r
- this.newLine();\r
- var cmd=this.lineBuffer;\r
- if (cmd!='') {\r
- if (cmd=='switch') {\r
- var other=(this.id==1)? 2:1;\r
- termOpen(other);\r
- }\r
- else if (cmd=='clear') {\r
- this.clear();\r
- }\r
- else if (cmd=='exit') {\r
- this.close();\r
- }\r
- else if (cmd=='help') {\r
- this.write(helpPage);\r
- }\r
- else if (cmd=='id') {\r
- this.write('terminal id: '+this.id);\r
- }\r
- else {\r
- this.type('You typed: '+cmd);\r
- this.newLine();\r
- }\r
- }\r
- this.prompt();\r
-}\r
-\r
-function termExitHandler() {\r
- // optional handler called on exit\r
- // activate other terminal if open\r
- var other=(this.id==1)? 2:1;\r
- if ((term[other]) && (term[other].closed==false)) term[other].focus();\r
-}\r
-\r
-//-->\r
-</SCRIPT>\r
-\r
-<STYLE TYPE="text/css">\r
-body,p,a,td {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #cccccc;\r
-}\r
-.lh15 {\r
- line-height: 15px;\r
-}\r
-.term {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #33d011;\r
- background: none;\r
-}\r
-.termReverse {\r
- color: #111111;\r
- background: #33d011;\r
-}\r
-a,a:link,a:visited {\r
- text-decoration: none;\r
- color: #77dd11;\r
-}\r
-a:hover {\r
- text-decoration: underline;\r
- color: #77dd11;\r
-}\r
-a:active {\r
- text-decoration: underline;\r
- color: #dddddd;\r
-}\r
-\r
-a.termopen,a.termopen:link,a.termopen:visited {\r
- text-decoration: none;\r
- color: #77dd11;\r
- background: none;\r
-}\r
-a.termopen:hover {\r
- text-decoration: none;\r
- color: #222222;\r
- background: #77dd11;\r
-}\r
-a.termopen:active {\r
- text-decoration: none;\r
- color: #222222;\r
- background: #dddddd;\r
-}\r
-\r
-</STYLE>\r
-</HEAD>\r
-\r
-\r
-<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
-TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0">\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
-<TR>\r
- <TD NOWRAP><A HREF="index.html">termlib.js home</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP>multiple terminal test</TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="parser_sample.html">sample parser</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="faq.html">faq</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
-</TR>\r
-</TABLE>\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0">\r
- <TR><TD NOWRAP>\r
- Multiple Terminal Test<BR> \r
- </TD></TR>\r
- <TR><TD NOWRAP>\r
- <A HREF="javascript:termOpen(1)" onfocus="if(this.blur)this.blur();" onmouseover="window.status='terminal 1'; return true" onmouseout="window.status=''; return true" CLASS="termopen">> open terminal 1 </A>\r
- </TD></TR>\r
- <TR><TD NOWRAP>\r
- <A HREF="javascript:termOpen(2)" onfocus="if(this.blur)this.blur();" onmouseover="window.status='terminal 2'; return true" onmouseout="window.status=''; return true" CLASS="termopen">> open terminal 2 </A>\r
- </TD></TR>\r
- <TR><TD NOWRAP CLASS="lh15">\r
- <BR>\r
- (c) mass:werk,<BR>N. Landsteiner 2003-2005<BR>\r
- <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
- </TD></TR>\r
-</TABLE>\r
-\r
-<DIV ID="termDiv1" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
-<DIV ID="termDiv2" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
-\r
-</BODY>\r
-</HTML>
\ No newline at end of file
+++ /dev/null
-<HTML>\r
-<HEAD>\r
- <TITLE>termlib Sample Parser</TITLE>\r
- <SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="termlib.js"></SCRIPT>\r
- <SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="termlib_parser.js"></SCRIPT>\r
-\r
-<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript">\r
-<!--\r
-\r
-/*\r
- test sample for termlib.js and termlib_parser.js\r
-\r
- (c) Norbert Landsteiner 2005\r
- mass:werk - media environments\r
- <http://www.masswerk.at>\r
-\r
-*/\r
-\r
-var term;\r
-\r
-var helpPage=[\r
- '%CS%+r Terminal Help %-r%n',\r
- ' This is just a sample to demonstrate command line parsing.',\r
- ' ',\r
- ' Use one of the following commands:',\r
- ' clear [-a] .......... clear the terminal',\r
- ' option "a" also removes the status line',\r
- ' number -n<value> .... return value of option "n" (test for options)',\r
- ' repeat -n<value> .... repeats the first argument n times (another test)',\r
- ' login <username> .... sample login (test for raw mode)',\r
- ' exit ................ close the terminal (same as <ESC>)',\r
- ' help ................ show this help page',\r
- ' ',\r
- ' other input will be echoed to the terminal as a list of parsed arguments',\r
- ' in the format <argument index> <quoting level> "<parsed value>".',\r
- ' '\r
-];\r
-\r
-function termOpen() {\r
- if (!term) {\r
- term=new Terminal(\r
- {\r
- x: 220,\r
- y: 70,\r
- termDiv: 'termDiv',\r
- ps: '[guest]$',\r
- initHandler: termInitHandler,\r
- handler: commandHandler\r
- }\r
- );\r
- if (term) term.open();\r
- }\r
- else if (term.closed) {\r
- term.open();\r
- }\r
- else {\r
- term.focus();\r
- }\r
-}\r
-\r
-function termInitHandler() {\r
- // output a start up screen\r
- this.write(\r
- [\r
- TermGlobals.center('####################################################', 80),\r
- TermGlobals.center('# #', 80),\r
- TermGlobals.center('# termlib.js - Sample Parser #', 80),\r
- TermGlobals.center('# Input is echoed as a list of parsed arguments. #', 80),\r
- TermGlobals.center('# #', 80),\r
- TermGlobals.center('# Type "help" for commands. #', 80),\r
- TermGlobals.center('# #', 80),\r
- TermGlobals.center('# (c) N. Landsteiner 2005; www.masswerk.at #', 80),\r
- TermGlobals.center('# #', 80),\r
- TermGlobals.center('####################################################', 80),\r
- '%n'\r
- ]\r
- );\r
- // set a double status line\r
- this.statusLine('', 8,2); // just a line of strike\r
- this.statusLine(' +++ This is just a test sample for command parsing. Type "help" for help. +++');\r
- this.maxLines -= 2;\r
- // and leave with prompt\r
- this.prompt();\r
-}\r
-\r
-function commandHandler() {\r
- this.newLine();\r
- // check for raw mode first (should not be parsed)\r
- if (this.rawMode) {\r
- if (this.env.getPassword) {\r
- // sample password handler (lineBuffer == stored username ?)\r
- if (this.lineBuffer == this.env.username) {\r
- this.user = this.env.username;\r
- this.ps = '['+this.user+']>';\r
- }\r
- else {\r
- this.type('Sorry.');\r
- }\r
- this.env.username = '';\r
- this.env.getPassword = false;\r
- }\r
- // leave in normal mode\r
- this.rawMode = false;\r
- this.prompt();\r
- return;\r
- }\r
- // normal command parsing\r
- // just call the termlib_parser with a reference of the calling Terminal instance\r
- // parsed arguments will be imported in this.argv,\r
- // quoting levels per argument in this.argQL (quoting character or empty)\r
- // cursor for arguments is this.argc (used by parserGetopt)\r
- // => see 'termlib_parse.js' for configuration and details\r
- parseLine(this);\r
- if (this.argv.length == 0) {\r
- // no commmand line input\r
- }\r
- else if (this.argQL[0]) {\r
- // first argument quoted -> error\r
- this.write("Syntax error: first argument quoted.");\r
- }\r
- else {\r
- var cmd = this.argv[this.argc++];\r
- /*\r
- process commands now\r
- 1st argument: this.argv[this.argc]\r
- */\r
- if (cmd == 'help') {\r
- this.write(helpPage);\r
- }\r
- else if (cmd == 'clear') {\r
- // get options\r
- var opts = parserGetopt(this, 'aA');\r
- if (opts.a) {\r
- // discard status line on opt "a" or "A"\r
- this.maxLines = this.conf.rows;\r
- }\r
- this.clear();\r
- }\r
- else if (cmd == 'number') {\r
- // test for value options\r
- var opts = parserGetopt(this, 'n');\r
- if (opts.illegals.length) this.type('illegal option. usage: number -n<value>')\r
- else if ((opts.n) && (opts.n.value != -1)) this.type('option value: '+opts.n.value)\r
- else this.type('usage: number -n<value>');\r
- }\r
- else if (cmd == 'repeat') {\r
- // another test for value options\r
- var opts = parserGetopt(this, 'n');\r
- if (opts.illegals.length) this.type('illegal option. usage: repeat -n<value> <string>')\r
- else if ((opts.n) && (opts.n.value != -1)) {\r
- // first normal argument is again this.argv[this.argc]\r
- var s = this.argv[this.argc];\r
- if (typeof s != 'undefined') {\r
- // repeat this string n times\r
- var a = [];\r
- for (var i=0; i<opts.n.value; i++) a[a.length] = s;\r
- this.type(a.join(' '));\r
- }\r
- }\r
- else this.type('usage: repeat -n<value> <string>');\r
- }\r
- else if (cmd == 'login') {\r
- // sample login (test for raw mode)\r
- if ((this.argc == this.argv.length) || (this.argv[this.argc] == '')) {\r
- this.type('usage: login <username>');\r
- }\r
- else {\r
- this.env.getPassword = true;\r
- this.env.username = this.argv[this.argc];\r
- this.write('%+iSample login: repeat username as password.%-i%n');\r
- this.type('password: ');\r
- // exit in raw mode (blind input)\r
- this.rawMode = true;\r
- this.lock = false;\r
- return;\r
- }\r
- }\r
- else if (cmd == 'exit') {\r
- this.close();\r
- return;\r
- }\r
- else {\r
- // for test purpose just output argv as list\r
- // assemble a string of style-escaped lines and output it in more-mode\r
- s=' INDEX QL ARGUMENT%n';\r
- for (var i=0; i<this.argv.length; i++) {\r
- s += TermGlobals.stringReplace('%', '%%',\r
- TermGlobals.fillLeft(i, 6) +\r
- TermGlobals.fillLeft((this.argQL[i])? this.argQL[i]:'-', 4) +\r
- ' "' + this.argv[i] + '"'\r
- ) + '%n';\r
- }\r
- this.write(s, 1);\r
- return;\r
- }\r
- }\r
- this.prompt();\r
-}\r
-\r
-\r
-//-->\r
-</SCRIPT>\r
-\r
-<STYLE TYPE="text/css">\r
-body,p,a,td {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #cccccc;\r
-}\r
-.lh15 {\r
- line-height: 15px;\r
-}\r
-.term {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #33d011;\r
- background: none;\r
-}\r
-.termReverse {\r
- color: #111111;\r
- background: #33d011;\r
-}\r
-a,a:link,a:visited {\r
- text-decoration: none;\r
- color: #77dd11;\r
-}\r
-a:hover {\r
- text-decoration: underline;\r
- color: #77dd11;\r
-}\r
-a:active {\r
- text-decoration: underline;\r
- color: #dddddd;\r
-}\r
-\r
-a.termopen,a.termopen:link,a.termopen:visited {\r
- text-decoration: none;\r
- color: #77dd11;\r
- background: none;\r
-}\r
-a.termopen:hover {\r
- text-decoration: none;\r
- color: #222222;\r
- background: #77dd11;\r
-}\r
-a.termopen:active {\r
- text-decoration: none;\r
- color: #222222;\r
- background: #dddddd;\r
-}\r
-\r
-</STYLE>\r
-</HEAD>\r
-\r
-\r
-<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
-TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0">\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
-<TR>\r
- <TD NOWRAP><A HREF="index.html">termlib.js home</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="multiterm_test.html">multiple terminal test</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP>sample parser</TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="faq.html">faq</A></TD>\r
- <TD>|</TD>\r
- <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
-</TR>\r
-</TABLE>\r
-\r
-<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0">\r
- <TR><TD NOWRAP>\r
- Sample Parser Test<BR> \r
- </TD></TR>\r
- <TR><TD NOWRAP>\r
- <A HREF="javascript:termOpen()" onfocus="if(this.blur)this.blur();" onmouseover="window.status='terminal 1'; return true" onmouseout="window.status=''; return true" CLASS="termopen">> open terminal </A>\r
- </TD></TR>\r
- <TR><TD NOWRAP>\r
- \r
- </TD></TR>\r
- <TR><TD NOWRAP CLASS="lh15">\r
- <BR>\r
- (c) mass:werk,<BR>N. Landsteiner 2003-2005<BR>\r
- <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
- </TD></TR>\r
-</TABLE>\r
-\r
-<DIV ID="termDiv" STYLE="position:absolute;"></DIV>\r
-\r
-</BODY>\r
-</HTML>
\ No newline at end of file
+++ /dev/null
-**** mass:werk termlib.js - JS-WebTerminal Object v1.07 ****\r
-\r
- (c) Norbert Landsteiner 2003-2005\r
- mass:werk - media environments\r
- <http://www.masswerk.at>\r
-\r
-\r
-\r
-\r
-Contents:\r
-\r
- 1 About\r
- 2 Creating a new Terminal Instance\r
- 2.1 Configuration Values\r
- 3 Using the Terminal\r
- 3.1 The Default Handler\r
- 3.2 Input Modes\r
- 3.2.1 Normal Line Input (Command Line Mode)\r
- 3.2.1.2 Special Keys (ctrlHandler)\r
- 3.2.2 Raw Mode\r
- 3.2.3 Character Mode\r
- 3.3 Other Handlers\r
- 3.3.1 initHandler\r
- 3.3.2 exitHandler\r
- 3.4 Flags for Behaviour Control\r
- 4 Output Methods\r
- 4.1 Terminal.type()\r
- 4.2 Terminal.write()\r
- 4.3 Terminal.typeAt()\r
- 4.4 Terminal.setChar()\r
- 4.5 Terminal.newLine()\r
- 4.6 Terminal.clear()\r
- 4.7 Terminal.statusLine()\r
- 4.8 Terminal.printRowFromString()\r
- 4.9 Terminal.redraw()\r
- 5 Cursor Methods and Editing\r
- 5.1 Terminal.cursorOn()\r
- 5.2 Terminal.cursorOff()\r
- 5.3 Terminal.cursorSet()\r
- 5.4 Terminal.cursorLeft()\r
- 5.5 Terminal.cursorRight()\r
- 5.6 Terminal.backspace()\r
- 5.7 Terminal.fwdDelete()\r
- 5.8 Terminal.isPrintable()\r
- 6 Other Methods of the Terminal Object\r
- 6.1 Terminal.prompt()\r
- 6.2 Terminal.reset()\r
- 6.3 Terminal.open()\r
- 6.4 Terminal.close()\r
- 6.5 Terminal.focus()\r
- 6.6 Terminal.moveTo()\r
- 6.7 Terminal.resizeTo()\r
- 6.8 Terminal.getDimensions()\r
- 6.9 Terminal.rebuild()\r
- 7 Global Static Methods (TermGlobals)\r
- 7.1 TermGlobals.setFocus()\r
- 7.2 TermGlobals.keylock (Global Locking Flag)\r
- 7.3 TermGlobalsText Methods\r
- 7.3.1 TermGlobals.normalize()\r
- 7.3.2 TermGlobals.fillLeft()\r
- 7.3.3 TermGlobals.center()\r
- 7.3.4 TermGlobals.stringReplace()\r
- 8 Localization\r
- 9 Cross Browser Functions\r
- 10 Architecture, Internals\r
- 10.1 Global Entities\r
- 10.2 I/O Architecture\r
- 10.3 Compatibility\r
- 11 History\r
- 12 Example for a Command Line Parser\r
- 13 License\r
- 14 Disclaimer\r
- 15 References\r
-\r
-\r
-\r
-\r
-1 About\r
-\r
-The Terminal library "termlib.js" provides an object oriented constructor and control\r
-methods for a terminal-like DHTML interface.\r
-\r
-"termlib.js" features direct keyboard input and powerful output methods for multiple\r
-instances of the `Terminal' object (including focus control).\r
-\r
-The library was written with the aim of simple usage and a maximum of compatibility with\r
-minimal foot print in the global namespace.\r
-\r
-\r
-A simple example:\r
-\r
- // creating a terminal and using it\r
-\r
- var term = new Terminal( {handler: termHandler} );\r
- term.open();\r
-\r
- function termHandler() {\r
- var line = this.lineBuffer;\r
- this.newLine();\r
- if (line == "help") {\r
- this.write(helpPage)\r
- }\r
- else if (line == "exit") {\r
- this.close();\r
- return;\r
- }\r
- else if (line != "") {\r
- this.write("You typed: "+line);\r
- }\r
- this.prompt();\r
- }\r
-\r
- var helpPage = [\r
- "This is the monstrous help page for my groovy terminal.",\r
- "Commands available:",\r
- " help ... print this monstrous help page",\r
- " exit ... leave this groovy terminal",\r
- " ",\r
- "Have fun!"\r
- ];\r
-\r
-\r
-You should provide CSS font definitions for the classes ".term" (normal video) and\r
-".termReverse" (reverse video) in a monospaced font.\r
-A sample stylesheet "term_styles.css" comes with this library.\r
-\r
-See the sample application "multiterm_test.html" for a demo of multiple terminals.\r
-\r
-v.1.01: If you configure to use another font class (see 2.1 Configuration Values),\r
- you must provide a subclass ".termReverse" for reversed video.\r
-\r
- p.e.: .myFontClass .termReverse {\r
- /* your definitions for reverse video here */\r
- }\r
- \r
- With the addition of `conf.fontClass' you can now create multiple\r
- instances with independend appearences.\r
-\r
-\r
-\r
-\r
-2 Creating a new Terminal Instance\r
-\r
-Use the `new' constructor to create a new instance of the Terminal object. You will want\r
-to supply a configuration object as an argument to the constructor. If the `new'\r
-constructor is called without an object as its first argument, default values are used.\r
-\r
-p.e.:\r
-\r
- // creating a new instance of Terminal\r
-\r
- var conf= {\r
- x: 100,\r
- y: 100,\r
- cols: 80,\r
- rows: 24\r
- }\r
-\r
- var term = new Term(conf);\r
- term.open();\r
-\r
-`Terminal.open()' initializes the terminal and makes it visible to the user.\r
-This is handled in by separate method to allow the re-initilization of instances\r
-previously closed.\r
-\r
-NOTE:\r
-The division element (or NS-layer) that holds the terminal must be present when calling\r
-`Terminal.open()'. So you must not call this method from the header of a HTML-document at\r
-compile time.\r
-\r
-\r
-\r
-2.1 Configuration Values\r
-\r
-Set any of these values in your configuration object to override:\r
-\r
- \r
- LABEL DEFAULT VALUE COMMENT\r
- \r
- x 100 terminal's position x in px\r
- y 100 terminal's position y in px\r
- divDiv 'termDiv' id of terminals CSS division\r
- bgColor '#181818' background color (HTML hex value)\r
- frameColor '#555555' frame color (HTML hex value)\r
- frameWidth 1 frame border width in px\r
- fontClass 'term' class name of CSS font definition to use\r
- cols 80 number of cols per row\r
- rows 24 number of rows\r
- rowHeight 15 a row's line-height in px\r
- blinkDelay 500 delay for cursor blinking in milliseconds\r
- crsrBlinkMode false true for blinking cursor\r
- crsrBlockMode true true for block-cursor else underscore\r
- DELisBS false handle <DEL> as <BACKSPACE>\r
- printTab true handle <TAB> as printable (prints as space)\r
- printEuro true handle unicode 0x20AC (Euro sign) as printable\r
- catchCtrlH true handle ^H as <BACKSPACE>\r
- closeOnESC true close terminal on <ESC>\r
- historyUnique false prevent consecutive and identical entries in history\r
- id 0 terminal id\r
- ps '>' prompt string\r
- greeting '%+r Terminal ready. %-r' string for greeting if no initHandler is used\r
- handler termDefaultHandler reference to handler for command interpretation\r
- ctrlHandler null reference to handler called on uncatched special keys\r
- initHandler null reference to handler called at end of init()\r
- exitHandler null reference to handler called on close()\r
-\r
-\r
-At least you will want to specify `handler' to implement your own command parser.\r
-\r
-Note: While `id' is not used by the Termninal object, it provides an easy way to identify\r
-multiple terminals by the use of "this.id". (e.g.: "if (this.id == 1) startupterm = true;")\r
-\r
-p.e.:\r
-\r
- // creating two individual Terminal instances\r
-\r
- var term1 = new Terminal(\r
- {\r
- id: 1,\r
- x: 200,\r
- y: 10,\r
- cols: 80,\r
- rows: 12,\r
- greeting: "*** This is Terminal 1 ***",\r
- handler: myTerminalHandler\r
- }\r
- );\r
- term1.open();\r
-\r
- var term2 = new Terminal(\r
- {\r
- id: 2,\r
- x, 200,\r
- y: 220,\r
- cols: 80\r
- rows: 12,\r
- greeting: "*** This is Terminal 2 ***",\r
- handler: myTerminalHandler\r
- }\r
- );\r
- term2.open();\r
-\r
-\r
-\r
-\r
-3 Using the Terminal\r
-\r
-There are 4 different handlers that are called by a Terminal instance to process input and\r
-some flags to control the input mode and behaviour.\r
-\r
-\r
-\r
-3.1 The Default Handler (a simlple example for input handling)\r
-\r
-If no handlers are defined in the configuration object, a default handler is called to\r
-handle a line of user input. The default command line handler `termDefaultHandler' just\r
-closes the command line with a new line and echos the input back to the user:\r
-\r
- function termDefaultHandler() {\r
- this.newLine();\r
- if (this.lineBuffer != '') {\r
- this.type('You typed: '+this.lineBuffer);\r
- this.newLine();\r
- }\r
- this.prompt();\r
- }\r
-\r
-First you may note that the instance is refered to as `this'. So you need not worry about\r
-which Terminal instance is calling your handler. As the handler is entered, the terminal\r
-is locked for user input and the cursor is off. The current input is available as a string\r
-value in `this.lineBuffer'.\r
-\r
-The method `type(<text>)' just does what it says and types a string at the current cursor\r
-position to the terminal screen.\r
-\r
-`newLine()' moves the cursor to a new line.\r
-\r
-The method `prompt()' adds a new line if the cursor isn't at the start of a line, outputs\r
-the prompt string (as specified in the configuration), activates the cursor, and unlocks\r
-the terminal for further input. While you're doing normal command line processing, always\r
-call `prompt()' when leaving your handler.\r
-\r
-In fact this is all you need to create your own terminal application. Please see at least\r
-the method `write()' for a more powerful output method.\r
-\r
-Below we will refer to all methods of the Terminal object as `Terminal.<method>()'.\r
-You can call them as `this.<method>()' in a handler or as methods of your named instance\r
-in other context (e.g.: "myTerminal.close()").\r
-\r
-[In technical terms these methods are methods of the Terminal's prototype object, while\r
-the properties are properties of a Termninal instance. Since this doesn't make any\r
-difference to your script, we'll refer to both as `Terminal.<method-or-property>'.]\r
-\r
-\r
-\r
-3.2 Input Modes\r
-\r
-3.2.1 Normal Line Input (Command Line Mode)\r
-\r
-By default the terminal is in normal input mode. Any printable characters in the range of\r
-ASCII 0x20 - 0xff are echoed to the terminal and may be edited with the use of the cursor\r
-keys and the <BACKSPACE> key.\r
-The cursor keys UP and DOWN let the user browse in the command line history (the list of\r
-all commands issued previously in this Terminal instance).\r
-\r
-If the user presses <CR> or <ENTER>, the line is read from the terminal buffer, converted\r
-to a string, and placed in `Terminal.lineBuffer' (-> `this.lineBuffer') for further use.\r
-The terminal is then locked for further input and the specified handler\r
-(`Terminal.handler') is called.\r
-\r
-\r
-3.2.1.2 Special Keys (ctrlHandler)\r
-\r
-If a special character (ASCII<0x20) or an according combination of <CTRL> and a key is\r
-pressed, which is not caught for editing or "enter", and a handler for `ctrlHandler' is\r
-specified, this handler is called.\r
-The ASCII value of the special character is available in `Terminal.inputChar'. Please note\r
-that the terminal is neither locked, nor is the cursor off - all further actions have to\r
-be controlled by `ctrlHandler'. (The tracking of <CTRL>-<key> combinations as "^C" usually\r
-works but cannot be taken for granted.)\r
-\r
-A named reference of the special control values in POSIX form (as well as the values of\r
-the cursor keys [LEFT, RIGHT, UP, DOWN]) is available in the `termKey' object.\r
-\r
-p.e.:\r
-\r
- // a simple ctrlHandler\r
-\r
- function myCtrlHandler() {\r
- if (this.inputChar == termKey.ETX) {\r
- // exit on ^C (^C == ASCII 0x03 == <ETX>)\r
- this.close();\r
- }\r
- }\r
-\r
-If no `ctrlHandler' is specified, control keys are ignored (default).\r
-\r
-\r
-3.2.2 Raw Mode\r
-\r
-If the flag `Terminal.rawMode' is set to a value evaluating to `true', no special keys are\r
-tracked but <CR> and <ENTER> (and <ESC>, if the flag `Terminal.closeOnESC' is set).\r
-The input is NOT echoed to the terminal. All printable key values [0x20-0xff] are\r
-transformed to characters and added to `Terminal.lineBuffer' sequentially. The command\r
-line input is NOT added to the history.\r
-\r
-This mode is especially suitable for password input.\r
-\r
-p.e.:\r
-\r
- // using raw mode for password input\r
-\r
- function myTermHandler() {\r
- this.newLine();\r
- // we stored a flag in Terminal.env to track the status\r
- if (this.env.getpassword) {\r
- // leave raw mode\r
- this.rawMode = false;\r
- if (passwords[this.env.user] == this.lineBuffer) {\r
- // matched\r
- this.type('Welcome '+this.env.user);\r
- this.env.loggedin = true;\r
- }\r
- else {\r
- this.type('Sorry.');\r
- }\r
- this.env.getpassword = false;\r
- }\r
- else {\r
- // simple parsing\r
- var args = this.lineBuffer.split(' ');\r
- var cmd = args[0];\r
- if (cmd == 'login') {\r
- var user = args[1];\r
- if (!user) {\r
- this.type('usage: login <username>');\r
- }\r
- else {\r
- this.env.user = user;\r
- this.env.getpassword = true;\r
- this.type('password? ');\r
- // enter raw mode\r
- this.rawMode = true;\r
- // leave without prompt so we must unlock first\r
- this.lock = false;\r
- return;\r
- }\r
- }\r
- /*\r
- other actions ...\r
- */\r
- }\r
- this.prompt();\r
- }\r
-\r
-In this example a handler is set up to process the command "login <username>" and ask for\r
-a password for the given user name in raw mode. Note the use of the object `Terminal.env'\r
-which is just an empty object set up at the creation of the Terminal instance. Its only\r
-purpose is to provide an individual namespace for private data to be stored by a Terminal\r
-instance.\r
-\r
-NOTE: The flag `Terminal.lock' is used to control the keyboard locking. If we would not\r
-set this to `false' before leaving in raw mode, we would be caught in dead-lock, since no\r
-input could be entered and our handler wouldn't be called again. - A dreadful end of our\r
-terminal session.\r
-\r
-NOTE: Raw mode utilizes the property `Terminal.lastLine' to collect the input string.\r
-This is normally emty, when a handler is called. This is not the case if your script left\r
-the input process on a call of ctrlHandler. You should clear `Terminal.lastLine' in such\r
-a case, if you're going to enter raw mode immediatly after this.\r
-\r
-\r
-3.2.3 Character Mode\r
-\r
-If the flag `Terminal.charMode' is set to a value evaluating to `true', the terminal is in\r
-character mode. In this mode the numeric ASCII value of the next key typed is stored in\r
-`Terminal.inputChar'. The input is NOT echoed to the terminal. NO locking or cursor\r
-control is performed and left to the handler.\r
-You can use this mode to implement your editor or a console game.\r
-`Terminal.charMode' takes precedence over `Terminal.rawMode'.\r
-\r
-p.e.: \r
-\r
- // using char mode\r
-\r
- function myTermHandler() {\r
- // this is the normal handler\r
- this.newLine();\r
- // simple parsing\r
- var args = this.lineBuffer.split(' ');\r
- var cmd = args[0];\r
- if (cmd == 'edit') {\r
- // init the editor\r
- myEditor(this);\r
- // redirect the handler to editor\r
- this.handler = myEditor;\r
- // leave in char mode\r
- this.charMode = true;\r
- // show cursor\r
- this.cursorOn();\r
- // don't forget unlocking\r
- this.lock = false;\r
- return;\r
- }\r
- /*\r
- other actions ...\r
- */\r
- this.prompt();\r
- }\r
-\r
- function myEditor(initterm) {\r
- // our dummy editor (featuring modal behaviour)\r
- if (initterm) {\r
- // perform initialization tasks\r
- initterm.clear();\r
- initterm.write('this is a simple test editor; leave with <ESC> then "q"%n%n');\r
- initterm.env.mode = '';\r
- // store a reference of the calling handler\r
- initterm.env.handler = initterm.handler;\r
- return;\r
- }\r
- // called as handler -> lock first\r
- this.lock=true;\r
- // hide cursor\r
- this.cursorOff();\r
- var key = this.inputChar;\r
- if (this.env.mode == 'ctrl') {\r
- // control mode\r
- if (key == 113) {\r
- // "q" => quit\r
- // leave charMode and reset the handler to normal\r
- this.charMode = false;\r
- this.handler = this.env.handler;\r
- // clear the screen\r
- this.clear();\r
- // prompt and return\r
- this.prompt();\r
- return;\r
- }\r
- else {\r
- // leave control mode\r
- this.env.mode = '';\r
- }\r
- }\r
- else {\r
- // edit mode\r
- if (key == termKey.ESC) {\r
- // enter control mode\r
- // we'd better indicate this in a status line ...\r
- this.env.mode = 'ctrl';\r
- }\r
- else if (key == termKey.LEFT) {\r
- // cursor left\r
- }\r
- else if (key == termKey.RIGHT) {\r
- // cursor right\r
- }\r
- if (key == termKey.UP) {\r
- // cursor up\r
- }\r
- else if (key == termKey.DOWN) {\r
- // cursor down\r
- }\r
- else if (key == termKey.CR) {\r
- // cr or enter\r
- }\r
- else if (key == termKey.BS) {\r
- // backspace\r
- }\r
- else if (key == termKey.DEL) {\r
- // fwd delete\r
- // conf.DELisBS is not evaluated in charMode!\r
- }\r
- else if (this.isPrintable(key)) {\r
- // printable char - just type it\r
- var ch = String.fromCharCode(key);\r
- this.type(ch);\r
- }\r
- }\r
- // leave unlocked with cursor\r
- this.lock = false;\r
- this.cursorOn();\r
- }\r
-\r
-\r
-Note the redirecting of the input handler to replace the command line handler by the\r
-editor. The method `Terminal.clear()' clears the terminal.\r
-`Terminal.cursorOn()' and `Terminal.cursorOff()' are used to show and hide the cursor.\r
-\r
-\r
-\r
-3.3 Other Handlers\r
-\r
-There are two more handlers that can be specified in the configuration object:\r
-\r
-\r
-3.3.1 initHandler\r
-\r
-`initHandler' is called at the end of the initialization triggered by `Terminal.open()'.\r
-The default action - if no `initHandler' is specified - is:\r
-\r
- // default initilization\r
-\r
- this.write(this.conf.greeting);\r
- this.newLine();\r
- this.prompt();\r
-\r
-Use `initHandler' to perform your own start up tasks (e.g. show a start up screen). Keep\r
-in mind that you should unlock the terminal and possibly show a cursor to give the\r
-impression of a usable terminal.\r
-\r
-\r
-3.3.2 exitHandler\r
-\r
-`exitHandler' is called by `Terminal.close()' just before hiding the terminal. You can use\r
-this handler to implement any tasks to be performed on exit. Note that this handler is\r
-called even if the terminal is closed on <ESC> outside of your inputHandlers control.\r
-\r
-See the file "multiterm_test.html" for an example.\r
-\r
-\r
-\r
-3.4 Overview: Flags for Behaviour Control\r
-\r
-These falgs are accessible as `Terminal.<flag>' at runtime. If not stated else, the\r
-initial value may be specified in the configuration object.\r
-The configuration object and its properties are accessible at runtime via `Terminal.conf'.\r
-\r
-\r
- NAME DEFAULT VALUE MEANING\r
-\r
- blink_delay 500 delay for cursor blinking in milliseconds.\r
-\r
- crsrBlinkMode false true for blinking cursor.\r
- if false, cursor is static.\r
- \r
- crsrBlockMode true true for block-cursor else underscore.\r
-\r
- DELisBS false handle <DEL> as <BACKSPACE>.\r
-\r
- printTab true handle <TAB> as printable (prints as space)\r
- if false <TAB> is handled as a control character\r
-\r
- printEuro true handle the euro sign as valid input char.\r
- if false char 0x20AC is printed, but not accepted\r
- in the command line\r
-\r
- catchCtrlH true handle ^H as <BACKSPACE>.\r
- if false, ^H must be tracked by a custom\r
- ctrlHandler.\r
-\r
- closeOnESC true close terminal on <ESC>.\r
- if true, <ESC> is not available for ctrHandler.\r
-\r
-\r
- historyUnique false unique history entries.\r
- if true, entries that are identical to the last\r
- entry in the user history will not be added.\r
-\r
- charMode false terminal in character mode (tracks next key-code).\r
- (runtime only)\r
- \r
- rawMode false terminal in raw mode (no echo, no editing).\r
- (runtime only)\r
-\r
-\r
-Not exactly a flag but useful:\r
-\r
- ps '>' prompt string.\r
-\r
-\r
-\r
-\r
-4 Output Methods\r
-\r
-Please note that any output to the terminal implies an advance of the cursor. This means,\r
-that if your output reaches the last column of your terminal, the cursor is advanced and\r
-a new line is opened automatically. This procedure may include scrolling to make room for\r
-the new line. While this is not of much interest for most purposes, please note that, if\r
-you output a string of length 80 to a 80-columns-terminal, and a new line, and another\r
-string, this will result in an empty line between the two strings.\r
-\r
-\r
-4.1 Terminal.type( <text> [,<stylevector>] )\r
-\r
-Types the string <text> at the current cursor position to the terminal. Long lines are\r
-broken where the last column of the terminal is reached and continued in the next line.\r
-`Terminal.write()' does not support any kind of arbitrary line breaks. (This is just a\r
-basic output routine. See `Terminal.write()' for a more powerful output method.)\r
-\r
-A bitvector may be supplied as an optional second argument to represent a style or a\r
-combination of styles. The meanings of the bits set are interpreted as follows:\r
-\r
-<stylevector>:\r
-\r
- 1 ... reverse (2 power 0)\r
- 2 ... underline (2 power 1)\r
- 4 ... italics (2 power 2)\r
- 8 ... strike (2 power 3)\r
-\r
-So "Terminal.type( 'text', 5 )" types "text" in italics and reverse video.\r
-\r
-Note:\r
-There is no bold, for most monospaced fonts (including Courier) tend to render wider in\r
-bold. Since this would bring the terminal's layout out of balance, we just can't use bold\r
-as a style. - Sorry.\r
-\r
-The HTML-representation of this styles are defined in "TermGlobals.termStyleOpen" and\r
-"TermGlobals.termStyleClose".\r
-\r
-\r
-4.2 Terminal.write( <text> [,<usemore>] )\r
-\r
-Writes a text with markup to the terminal. If an optional second argument evaluates to\r
-true, a UN*X-style utility like `more' is used to page the text. The text may be supplied\r
-as a single string (with newline character "\n") or as an array of lines. Any other input\r
-is transformed to a string value before output.\r
-\r
-4.2.1 Mark-up:\r
-\r
-`Terminal.write()' employs a simple mark-up with the following syntax:\r
-\r
-<markup>: %([+|-]<style>|n|CS|%)\r
- \r
- where "+" and '-' are used to switch on and off a style, where\r
- \r
- <style>:\r
- \r
- "i" ... italics\r
- "r" ... reverse\r
- "s" ... strike\r
- "u" ... underline\r
- \r
- "p" ... reset to plain ("%+p" == "%-p")\r
- \r
- styles may be combined and may overlap. (e.g. "This is %+rREVERSE%-r, %+uUNDER%+iSCORE%-u%-i.")\r
- \r
- "%n" represents a new line (in fact "\n" is translated to "%n" before processing)\r
- \r
- "%CS" clears the terminal screen\r
- \r
- "%%" represents the percent character ('%')\r
-\r
-\r
-4.2.2 Buffering:\r
-\r
-`Terminal.write()' writes via buffered output to the terminal. This means that the\r
-provided text is rendered to a buffer first and then only the visible parts are transfered\r
-to the terminal display buffers. This avoids scrolling delays for long output.\r
-\r
-4.2.3 UseMore Mode:\r
-\r
-The buffering of `Terminal.write()' allows for pagewise output, which may be specified by\r
-a second boolean argument. If <usemore> evaluates to `true' and the output exceeds the\r
-range of empty rows on the terminal screen, `Terminal.write()' performs like the UN*X\r
-utility `more'. The next page may be accessed by hitting <SPACE> while <q> terminates\r
-paging and returns with the prompt (-> `Terminal.prompt()').\r
-\r
-To use this facillity make sure to return immediatly after calling `Terminal.write()' in\r
-order to allow the more-routine to track the user input.\r
-The terminal is set to "charMode == false" afterwards.\r
-\r
-p.e.:\r
-\r
- // using Terminal.write as a pager\r
-\r
- function myTermHandler() {\r
- this.newLine();\r
- var args = this.lineBuffer.split(' ');\r
- var cmd = args[0];\r
- if (cmd == 'more') {\r
- var page = args[1];\r
- if (myPages[page]) {\r
- // Terminal.write as a pager\r
- this.write(myPages[page], true);\r
- return;\r
- }\r
- else {\r
- // Terminal.write for simple output\r
- this.write('no such page.');\r
- }\r
- }\r
- /*\r
- other actions ...\r
- */\r
- this.prompt();\r
- }\r
-\r
-\r
-4.3 Terminal.typeAt( <r>, <c>, <text> [,<stylevector>] )\r
-\r
-Output the string <text> at row <r>, col <c>.\r
-For <stylevector> see `Terminal.type()'.\r
-`Terminal.typeAt()' does not move the cursor.\r
-\r
-\r
-4.4 Terminal.setChar( <charcode>, <r>, <c> [,<stylevector>] )\r
-\r
-Output a single character represented by the ASCII value of <charcode> at row <r>, col <c>.\r
-For <stylevector> see `Terminal.type()'.\r
-\r
-\r
-4.5 Terminal.newLine()\r
-\r
-Moves the cursor to the first column of the next line and performs scrolling, if needed.\r
-\r
-\r
-4.6 Terminal.clear()\r
-\r
-Clears the terminal screen. (Returns with cursor off.)\r
-\r
-\r
-4.7 Terminal.statusLine( <text> [,<stylevector> [,<lineoffset>]] )\r
-\r
-All output acts on a logical screen with the origin at row 0 / col 0. While the origin is\r
-fixed, the logical width and height of the terminal are defined by `Terminal.maxCols' and\r
-`Terminal.maxLines'. These are set to the configuration dimensions at initilization and by\r
-`Terminal.reset()', but may be altered at any moment. Please note that there are no bounds\r
-checked, so make sure that `Terminal.maxCols' and `Terminal.maxLines' are less or equal\r
-to the configuration dimensions.\r
-\r
-You may want to decrement `Terminal.maxLines' to keep space for a reserved status line.\r
-`Terminal.statusLine( <text>, <style> )' offers a simple way to type a text to the last\r
-line of the screen as defined by the configuration dimensions.\r
-\r
- // using statusLine()\r
-\r
- function myHandler() {\r
- // ...\r
- // reserve last line\r
- this.maxLines = term.conf.rows-1;\r
- // print to status line in reverse video\r
- this.statusLine("Status: <none>", 1);\r
- // ...\r
- }\r
-\r
-For multiple status lines the optional argument <lineoffset> specifies the addressed row,\r
-where 1 is the line closest to the bottom, 2 the second line from the bottom and so on.\r
-(default: 1)\r
-\r
-\r
-4.8 Terminal.printRowFromString( <r> , <text> [,<stylevector>] )\r
-\r
-Outputs the string <text> to row <r> in the style of an optional <stylevector>.\r
-If the string's length exceeds the length of the row (up to `Terminal.conf.cols'), extra\r
-characteres are ignored, else any extra space is filled with character code 0 (prints as\r
-<SPACE>).\r
-The valid range for <row> is: 0 >= <row> < `Terminal.maxLines'.\r
-`Terminal.printRowFromString()' does not set the cursor.\r
-\r
-You could, for example, use this method to output a line of a text editor's buffer.\r
-\r
-p.e.:\r
-\r
- // page refresh function of a text editor\r
-\r
- function myEditorRefresh(termref, topline) {\r
- // termref: reference to Terminal instance\r
- // topline: index of first line to print\r
- // lines of text are stored in termref.env.lines\r
- for (var r=0; r<termref.maxLines; r++) {\r
- var i = topline + r;\r
- if (i < termref.env.lines.length) {\r
- // output stored line\r
- termref.printRowFromString(r, termref.env.lines[i]);\r
- }\r
- else {\r
- // output <tilde> for empty line\r
- termref.printRowFromString(r, '~');\r
- }\r
- }\r
- // set cursor to origin\r
- termref.r = termref.c = 0; // same as termref.cursorSet(0, 0);\r
- }\r
-\r
-\r
-4.9 Terminal.redraw( <row> )\r
-\r
-Basic function to redraw a terminal row <row> according to screen buffer values.\r
-For hackers only. (e.g.: for a console game, hack screen buffers first and redraw all\r
-changed rows at once.)\r
-\r
-\r
-\r
-\r
-5 Cursor Methods and Editing\r
-\r
-\r
-5.1 Terminal.cursorOn()\r
-\r
-Show the cursor.\r
-\r
-\r
-5.2 Terminal.cursorOff()\r
-\r
-Hide the cursor.\r
-\r
-\r
-5.3 Terminal.cursorSet( <r>, <c> )\r
-\r
-Set the cursor position to row <r> column <c>.\r
-`Terminal.cursorSet()' preserves the cursor's active state (on/off).\r
-\r
-\r
-5.4 Terminal.cursorLeft()\r
-\r
-Move the cursor left. (Movement is restricted to the logical input line.)\r
-`Terminal.cursorLeft()' preserves the cursor's active state (on/off).\r
-\r
-\r
-5.5 Terminal.cursorRight()\r
-\r
-Move the cursor right. (Movement is restricted to the logical input line.)\r
-`Terminal.cursorRight()' preserves the cursor's active state (on/off).\r
-\r
-\r
-5.6 Terminal.backspace()\r
-\r
-Delete the character left from the cursor, if the cursor is not in first position of the\r
-logical input line.\r
-`Terminal.backspace()' preserves the cursor's active state (on/off).\r
-\r
-\r
-5.7 Terminal.fwdDelete()\r
-\r
-Delete the character under the cursor.\r
-`Terminal.fwdDelete()' preserves the cursor's active state (on/off).\r
-\r
-\r
-5.8 Terminal.isPrintable( <key code> [,<unicode page 1 only>] )\r
-\r
-Returns `true' if the character represented by <key code> is printable with the current\r
-settings. An optional second argument <unicode page 1 only> limits the range of valid\r
-values to 255 with the exception of the Euro sign, if the flag `Terminal.printEuro' is set.\r
-(This second flag is used for input methods but not for output methods. So you may only\r
-enter portable characters, but you may print others to the terminals screen.)\r
-\r
-\r
-\r
-\r
-6 Other Methods of the Terminal Object\r
-\r
-6.1 Terminal.prompt()\r
-\r
-Performes the following actions:\r
-\r
- * advance the cursor to a new line, if the cursor is not at 1st column\r
- * type the prompt string (as specified in the configuaration object)\r
- * show the cursor\r
- * unlock the terminal\r
-\r
-(The value of the prompt string can be accessed and changed in `Terminal.ps'.)\r
-\r
-\r
-6.2 Terminal.reset()\r
-\r
-Resets the terminal to sane values and clears the terminal screen.\r
-\r
-\r
-6.3 Terminal.open()\r
-\r
-Opens the terminal. If this is a fresh instance, the HTML code for the terminal is\r
-generated. On re-entry the terminal's visibility is set to `true'. Initialization tasks\r
-are performed and the optional initHandler called. If no initHandler is specified in the\r
-configuration object, the greeting (configuration or default value) is shown and the user\r
-is prompted for input.\r
-\r
-v.1.01: `Terminal.open()' now checks for the existence of the DHTML element as defined in\r
- `Terminal.conf.termDiv' and returns success.\r
-\r
-\r
-6.4 Terminal.close()\r
-\r
-Closes the terminal and hides its visibility. An optional exitHandler (specified in the\r
-configuration object) is called, and finally the flag `Terminal.closed' is set to true. So\r
-you can check for existing terminal instances as you would check for a `window' object\r
-created by `window.open()'.\r
-\r
-p.e.:\r
-\r
- // check for a terminals state\r
- // let array "term" hold references to terminals\r
-\r
- if (term[n]) {\r
- if (term[n].closed) {\r
- // terminal exists and is closed\r
- // re-enter via "term[n].open()"\r
- }\r
- else {\r
- // terminal exists and is currently open\r
- }\r
- }\r
- else {\r
- // no such terminal\r
- // create it via "term[n] = new Terminal()"\r
- }\r
-\r
-\r
-6.5 Terminal.focus()\r
-\r
-Set the keyboard focus to this instance of Terminal. (As `window.focus()'.)\r
-\r
-\r
-6.6 Terminal.moveTo( <x>, <y> )\r
-\r
-Move the terminal to position <x>/<y> in px.\r
-(As `window.moveTo()', but inside the HTML page.)\r
-\r
-\r
-6.7 Terminal.resizeTo( <x>, <y> )\r
-\r
-Resize the terminal to dimensions <x> cols and <y> rows.\r
-<x> must be at least 4, <y> at least 2.\r
-`Terminal.resizeTo()' resets `Terminal.conf.rows', `Terminal.conf.cols',\r
-`Terminal.maxLines', and `Terminal.maxCols' to <y> and <x>, but leaves the instance' state\r
-else unchanged. Clears the terminal's screen and returns success.\r
-\r
-(A bit like `window.resizeTo()', but with rows and cols instead of px.)\r
-\r
-\r
-6.8 Terminal.getDimensions()\r
-\r
-Returns an object with properties "width" and "height" with numeric values for the\r
-terminal's outer dimensions in px. Values are zero (0) if the element is not present or\r
-if the method fails otherwise.\r
-\r
-\r
-6.9 Terminal.rebuild()\r
-\r
-Rebuilds the Terminal object's GUI preserving its state and content.\r
-Use this to change the color theme on the fly.\r
-\r
-p.e.:\r
-\r
- // change color settings on the fly\r
- // here: set bgColor to white and font style to "termWhite"\r
- // method rebuild() updates the GUI without side effects\r
-\r
- term.conf.bgColor = '#ffffff';\r
- term.conf.fontClass = 'termWhite';\r
- term.rebuild();\r
-\r
-\r
-\r
-\r
-7 Global Static Methods (TermGlobals)\r
-\r
-\r
-7.1 TermGlobals.setFocus( <termref> )\r
-\r
-Sets the keyboard focus to the instance referenced by <termref>.\r
-The focus is controlled by `TermGlobals.activeTerm' which may be accessed directly.\r
-See also: `Terminal.focus()'\r
-\r
-\r
-7.2 TermGlobals.keylock (Global Locking Flag)\r
-\r
-The global flag `TermGlobals.keylock' allows temporary keyboard locking without any\r
-other change of state. Use this to free the keyboard for any other resources.\r
-(added in v.1.03)\r
-\r
-\r
-7.3 TermGlobals Text Methods\r
-\r
-There is a small set of methods for common terminal related string tasks:\r
-\r
-\r
-7.3.1 TermGlobals.normalize( <n>, <fieldlength> )\r
-\r
-Converts a number to a string, which is filled at its left with zeros ("0") to the total\r
-length of <filedlength>. (e.g.: "TermGlobals.normalize(1, 2)" => "01")\r
-\r
-\r
-7.3.2 TermGlobals.fillLeft( <value>, <fieldlength> )\r
-\r
-Converts a value to a string and fills it to the left with blanks to <fieldlength>.\r
-\r
-\r
-7.3.3 TermGlobals.center( <text>, <length> )\r
-\r
-Adds blanks at the left of the string <text> until the text would be centered at a line\r
-of length <length>. (No blanks are added to the the right.)\r
-\r
-\r
-7.3.4 TermGlobals.stringReplace( <string1>, <string2>, <text> )\r
-\r
-Replaces all occurences of the string <string1> in <text> with <string2>.\r
-This is just a tiny work around for browsers with no support of RegExp.\r
-\r
-\r
-\r
-\r
-8 Localization\r
-\r
-The strings and key-codes used by the more utility of `Terminal.write()' are the only\r
-properties of "termlib.js" that may need localization. These properties are defined in\r
-`TermGlobals'. You may override them as needed:\r
-\r
-PROPERTY STANDARD VALUE COMMENT\r
-\r
-TermGlobals.lcMorePrompt1 ' -- MORE -- ' 1st string\r
-TermGlobals.lcMorePromtp1Style 1 reverse\r
-TermGlobals.lcMorePrompt2 ' (Type: space to continue, \'q\' to quit)' appended string\r
-TermGlobals.lcMorePrompt2Style 0 plain\r
-TermGlobals.lcMoreKeyAbort 113 (key-code: q)\r
-TermGlobals.lcMoreKeyContinue 32 (key-code <SPACE>)\r
-\r
-\r
-As "TermGlobals.lcMorePrompt2" is appended to "TermGlobals.lcMorePrompt1" make sure that\r
-the length of the combined strings does not exceed `Terminal.conf.cols'.\r
-\r
-\r
-\r
-\r
-9 Cross Browser Functions\r
-\r
-For DHTML rendering some methods - as needed by the Terminal library - are provided.\r
-These may also be accessed for other purposes.\r
-\r
-\r
-9.1 TermGlobals.writeElement( <element id>, <text> [,<NS4 parent document>] )\r
-\r
-Writes <text> to the DHTML element with id/name <element id>. \r
-<NS4 parent document> is used for NS4 only and specifies an optional reference to a parent\r
-document (default `window.document').\r
-\r
-9.2 TermGlobals.setElementXY( <element id>, <x>, <y> )\r
-\r
-Sets the DHTML element with id/name <element id> to position <x>/<y>.\r
-For NS4 works only with children of the top document (window.document).\r
-\r
-\r
-9.3 TermGlobals.setVisible( <element id>, <value> )\r
-\r
-If <value> evaluates to `true' show DHTML element with id/name <element id> else hide it.\r
-For NS4 works only with children of the top document (window.document).\r
-\r
-\r
-9.4 Custom Fixes for Missing String Methods\r
-\r
-Although `String.fromCharCode' and `String.prototype.charCodeAt' are defined by ECMA-262-2\r
-specifications, a few number of browsers lack them in their JavaScript implementation. At\r
-compile time custom methods are installed to fix this. Please note that they work only\r
-with ASCII characters and values in the range of [0x20-0xff].\r
-\r
-\r
-9.5 TermGlobals.setDisplay( <element id>, <value> )\r
-\r
-Sets the style.display property of the element with id/name <element id> to the given\r
-<value>. (added with v. 1.06)\r
-\r
-\r
-\r
-\r
-10 Architecture, Internals\r
-\r
-10.1 Global Entities\r
-\r
-The library is designed to leave only a small foot print in the namespace while providing\r
-suitable usability:\r
-\r
- Globals defined in this library:\r
-\r
- Terminal (Terminal object, `new' constructor and prototype methods)\r
- TerminalDefaults (default configuration, static object)\r
- termDefaultHandler (default command line handler, static function)\r
- TermGlobals (common vars and code for all instances, static object and methods)\r
- termKey (named mappings for special keys, static object)\r
- termDomKeyRef (special key mapping for DOM key constants, static object)\r
-\r
-\r
- Globals defined for fixing String methods, if missing\r
- (String.fromCharCode, String.prototype.charCodeAt):\r
-\r
- termString_keyref, termString_keycoderef, termString_makeKeyref\r
-\r
- \r
- Required CSS classes for font definitions: ".term", ".termReverse".\r
-\r
-\r
-\r
-10.2 I/O Architecture\r
-\r
-The Terminal object renders keyboard input from keyCodes to a line buffer and/or to a\r
-special keyCode buffer. In normal input mode printable input is echoed to the screen\r
-buffers. Special characters like <LEFT>, <RIGHT>, <BACKSPACE> are processed for command\r
-line editing by the internal key-handler `TermGlobals.keyHandler' and act directly on the\r
-screen buffers. On <CR> or <ENTER> the start and end positions of the current line are\r
-evaluated (terminated by ASCII 0x01 at the beginning which separates the prompt from the\r
-user input, and any value less than ASCII 0x20 (<SPACE>) at the right end). Then the\r
-character representation for the buffer values in this range are evaluated and\r
-concatenated to a string stored in `Terminal.lineBuffer'. As this involves some\r
-ASCII-to-String-transformations, the range of valid printable input characters is limited\r
-to the first page of unicode characters (0x0020-0x00ff).\r
-\r
-There are two screen buffers for output, one for character codes (ASCII values) and one\r
-for style codes. Style codes represent combination of styles as a bitvector (see\r
-`Terminal.type' for bit values.) The method `Terminal.redraw(<row>)' finally renders the\r
-buffers values to a string of HTML code, which is written to the HTML entity holding the\r
-according terminal row. The character buffer is a 2 dimensional array\r
-`Terminal.charBuf[<row>][<col>]' with ranges for <row> from 0 to less than\r
-`Terminal.conf.rows' and for <col> from 0 to less than `Terminal.conf.cols'. The style\r
-buffer is a 2 dimensional array `Terminal.styleBuf[<row>][<col>]' with according ranges.\r
-\r
-So every single character is represented by a ASCII code in `Terminal.charBuf' and a\r
-style-vector in `Terminal.styleBuf'. The range of printable character codes is unlimitted\r
-but should be kept to the first page of unicode characters (0x0020-0x00ff) for\r
-compatibility purpose. (c.f. 8.4)\r
-\r
-Keyboard input is first handled on the `KEYDOWN' event by the handler `TermGlobals.keyFix'\r
-to remap the keyCodes of cursor keys to consistent values. (To make them distinctable from\r
-any other possibly printable values, the values of POSIX <IS4> to <IS1> where chosen.)\r
-The mapping of the cursor keys is stored in the properties LEFT, RIGHT, UP, and DOWN of\r
-the global static object `termKey'.\r
-\r
-The main keyboard handler `TermGlobals.keyHandler' (invoked on `KEYPRESS' or by\r
-`TermGlobals.keyFix') does some final mapping first. Then the input is evaluated as\r
-controlled by the flags `Terminal.rawMode' and `Terminal.charMode' with precedence of the\r
-latter. In dependancy of the mode defined and the handlers currently defined, the input\r
-either is ignored, or is internally processed for command line editing, or one of the\r
-handlers is called.\r
-\r
-In the case of the simultanous presecence of two instances of Terminal, the keyboard focus\r
-is controlled via a reference stored in `TermGlobals.activeTerm'. This reference is also\r
-used to evaluate the `this'-context of the key handlers which are methods of the static\r
-Object `TermGlobals'.\r
-\r
-A terminal's screen consists of a HTML-table element residing in the HTML/CSS division\r
-spcified in `Terminal.conf.termDiv'. Any output is handled on a per row bases. The\r
-individual rows are either nested sub-divisions of the main divisions (used for NS4 or\r
-browsers not compatible to the "Gecko" engine) or the indiviual table data elements (<TD>)\r
-of the terminal's inner table (used for browsers employing the "Gecko" engine).\r
-(This implementation was chosen for rendering speed and in order to minimize any screen\r
-flicker.) Any output or change of state in a raw results in the inner HTML contents of a\r
-row's HTML element to be rewritten. Please note that as a result of this a blinking cursor\r
-may cause a flicker in the line containing the cursor's position while displayed by a\r
-browser, which employs the "Gecko" engine.\r
-\r
-\r
-\r
-10.3 Compatibility\r
-\r
-Standard web browsers with a JavaScript implementation compliant to ECMA-262 2nd edition\r
-[ECMA262-2] and support for the anonymous array and object constructs and the anonymous\r
-function construct in the form of "myfunc = function(x) {}" (c.f. ECMA-262 3rd edion\r
-[ECMA262-3] for details). This comprises almost all current browsers but Konquerer (khtml)\r
-and versions of Apple Safari for Mac OS 10.0-10.28 (Safari < 1.1) which lack support for\r
-keyboard events.\r
-\r
-To provide a maximum of compatibilty the extend of language keywords used was kept to a\r
-minimum and does not exceed the lexical conventions of ECMA-262-2. Especially there is no\r
-use of the `switch' statement or the `RegExp' method of the global object. Also the use of\r
-advanced Array methods like `push', `shift', `splice' was avoided.\r
-\r
-\r
-\r
-\r
-11 History\r
-\r
-This library evolved from the terminal script "TermApp" ((c) N. Landsteiner 2003) and is\r
-in its current form a down scaled spinn-off of the "JS/UIX" project [JS/UIX] (evolution\r
-"JS/UIX v0.5"). c.f.: <http://www.masswerk.at/jsuix>\r
-\r
-v 1.01: added Terminal.prototype.resizeTo(x,y)\r
- added Terminal.conf.fontClass (=> configureable class name)\r
- Terminal.prototype.open() now checks for element conf.termDiv in advance\r
- and returns success.\r
-\r
-v 1.02: added support for <TAB> and Euro sign\r
- Terminal.conf.printTab\r
- Terminal.conf.printEuro\r
- and method Terminal.prototype.isPrintable(keycode)\r
- added support for getopt to sample parser ("parser_sample.html")\r
-\r
-\r
-v 1.03: added global keyboard locking (TermGlobals.keylock)\r
- modified Terminal.prototype.redraw for speed (use of locals)\r
-\r
-\r
-v 1.04: modified the key handler to fix a bug with MSIE5/Mac\r
- fixed a bug in TermGlobals.setVisible with older MSIE-alike browsers without\r
- DOM support.\r
- moved the script of the sample parser to an individual document\r
- => "termlib_parser.js" (HTML document is "parser_sample.html" as before)\r
-\r
-v 1.05: added config flag historyUnique.\r
-\r
-v 1.06: fixed CTRl+ALT (Windows alt gr) isn't CTRL any more\r
- -> better support for international keyboards with MSIE/Win.\r
- fixed double backspace bug for Safari;\r
- added TermGlobals.setDisplay for setting style.display props\r
- termlib.js now outputs lower case html (xhtml compatibility)\r
- (date: 12'2006)\r
-\r
-v 1.07: added method Terminal.rebuild() to rebuild the GUI with new color settings.\r
- (date: 01'2007)\r
-\r
-\r
-\r
-\r
-12 Example for a Command Line Parser\r
-\r
- // parser example, splits command line to args with quoting and escape\r
- // for use as `Terminal.handler'\r
- \r
- function commandHandler() {\r
- this.newLine();\r
- var argv = ['']; // arguments vector\r
- var argQL = ['']; // quoting level\r
- var argc = 0; // arguments cursor\r
- var escape = false ; // escape flag\r
- for (var i=0; i<this.lineBuffer.length; i++) {\r
- var ch= this.lineBuffer.charAt(i);\r
- if (escape) {\r
- argv[argc] += ch;\r
- escape = false;\r
- }\r
- else if ((ch == '"') || (ch == "'") || (ch == "`")) {\r
- if (argQL[argc]) {\r
- if (argQL[argc] == ch) {\r
- argc ++;\r
- argv[argc] = argQL[argc] = '';\r
- }\r
- else {\r
- argv[argc] += ch;\r
- }\r
- }\r
- else {\r
- if (argv[argc] != '') {\r
- argc ++;\r
- argv[argc] = '';\r
- argQL[argc] = ch;\r
- }\r
- else {\r
- argQL[argc] = ch;\r
- }\r
- }\r
- }\r
- else if ((ch == ' ') || (ch == '\t')) {\r
- if (argQL[argc]) {\r
- argv[argc] += ch;\r
- }\r
- else if (argv[argc] != '') {\r
- argc++;\r
- argv[argc] = argQL[argc] = '';\r
- }\r
- }\r
- else if (ch == '\\') {\r
- escape = true;\r
- }\r
- else {\r
- argv[argc] += ch;\r
- }\r
- }\r
- if ((argv[argc] == '') && (!argQL[argc])) {\r
- argv.length--;\r
- argQL.length--;\r
- }\r
- if (argv.length == 0) {\r
- // no commmand line input\r
- }\r
- else if (argQL[0]) {\r
- // first argument quoted -> error\r
- this.write("Error: first argument quoted by "+argQL[0]);\r
- }\r
- else {\r
- argc = 0;\r
- var cmd = argv[argc++];\r
- /*\r
- parse commands\r
- 1st argument is argv[argc]\r
- arguments' quoting levels in argQL[argc] are of (<empty> | ' | " | `)\r
- */\r
- if (cmd == 'help') {\r
- this.write(helpPage);\r
- }\r
- else if (cmd == 'clear') {\r
- this.clear();\r
- }\r
- else if (cmd == 'exit') {\r
- this.close();\r
- return;\r
- }\r
- else {\r
- // for test purpose just output argv as list\r
- // assemple a string of style-escaped lines and output it in more-mode\r
- s=' ARG QL VALUE%n';\r
- for (var i=0; i<argv.length; i++) {\r
- s += TermGlobals.stringReplace('%', '%%',\r
- TermGlobals.fillLeft(i, 6) +\r
- TermGlobals.fillLeft((argQL[i])? argQL[i]:'-', 4) +\r
- ' "' + argv[i] + '"'\r
- ) + '%n';\r
- }\r
- this.write(s, 1);\r
- return;\r
- }\r
- }\r
- this.prompt();\r
- }\r
-\r
-\r
-The file "parser_sample.html" features a stand-alone parser ("termlib_parser.js") very\r
-much like this. You are free to use it according to the termlib-license (see sect. 13).\r
-It provides configurable values for quotes and esape characters and imports the parsed\r
-argument list into a Terminal instance's namespace. ("parser_sample.html" and\r
-"termlib_parser.js" should accompany this file.)\r
-\r
-\r
-\r
-\r
-13 License\r
-\r
-This JavaScript-library is free for private and academic use.\r
-Please include a readable copyright statement and a backlink to <http://www.masswerk.at>\r
-in the web page. The library should always be accompanied by the 'readme.txt' and the\r
-sample HTML-documents.\r
-\r
-The term "private use" includes any personal or non-commercial use, which is not related\r
-to commercial activites, but excludes intranet, extranet and/or public net applications\r
-that are related to any kind of commercial or profit oriented activity.\r
-\r
-For commercial use see <http://www.masswerk.at> for contact information.\r
-\r
-Any changes to the library should be commented and be documented in the readme-file.\r
-Any changes must be reflected in the `Terminal.version' string as\r
-"Version.Subversion (compatibility)".\r
-\r
-\r
-\r
-\r
-14 Disclaimer\r
-\r
-This software is distributed AS IS and in the hope that it will be useful, but WITHOUT ANY\r
-WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
-PURPOSE. The entire risk as to the quality and performance of the product is borne by the\r
-user. No use of the product is authorized hereunder except under this disclaimer.\r
-\r
-\r
-\r
-\r
-15 References\r
-\r
-[ECMA262-2] "ECMAScript Language Specification" Standard ECMA-262 2nd Edition\r
- August 1998 (ISO/IEC 16262 - April 1998)\r
-\r
-[ECMA262-3] "ECMAScript Language Specification" Standard ECMA-262 3rd Edition Final\r
- 24 March 2000\r
-\r
-[JS/UIX] JS/UIX - JavaScript Uniplexed Interface eXtension\r
- <http://www.masswerk.at/jsuix>\r
-\r
-\r
-\r
-\r
-\r
-Norbert Landsteiner / Vienna, August 2005\r
-mass:werk - media environments\r
-<http://www.masswerk.at>\r
-See web site for contact information.\r
+++ /dev/null
-.term {\r
- font-family: courier,fixed,swiss,sans-serif;\r
- font-size: 12px;\r
- color: #33d011;\r
- background: none;\r
-}\r
-\r
-.termReverse {\r
- color: #111111;\r
- background: #33d011;\r
-}\r
+++ /dev/null
-/*\r
- termlib.js - JS-WebTerminal Object v1.07\r
-\r
- (c) Norbert Landsteiner 2003-2005\r
- mass:werk - media environments\r
- <http://www.masswerk.at>\r
-\r
- Creates [multiple] Terminal instances.\r
-\r
- Synopsis:\r
-\r
- myTerminal = new Terminal(<config object>);\r
- myTerminal.open();\r
-\r
- <config object> overrides any values of object `TerminalDefaults'.\r
- individual values of `id' must be supplied for multiple terminals.\r
- `handler' specifies a function to be called for input handling.\r
- (see `Terminal.prototype.termDefaultHandler()' and documentation.)\r
-\r
- globals defined in this library:\r
- Terminal (Terminal object)\r
- TerminalDefaults (default configuration)\r
- termDefaultHandler (default command line handler)\r
- TermGlobals (common vars and code for all instances)\r
- termKey (named mappings for special keys)\r
- termDomKeyRef (special key mapping for DOM constants)\r
-\r
- globals defined for fixing String methods, if missing\r
- (String.fromCharCode, String.prototype.charCodeAt):\r
- termString_keyref, termString_keycoderef, termString_makeKeyref\r
-\r
- required CSS classes for font definitions: ".term", ".termReverse".\r
-\r
- Compatibilty:\r
- Standard web browsers with a JavaScript implementation compliant to\r
- ECMA-262 2nd edition and support for the anonymous array and object\r
- constructs and the anonymous function construct in the form of\r
- "myfunc=function(x) {}" (c.f. ECMA-262 3rd edion for details).\r
- This comprises almost all current browsers but Konquerer (khtml) and\r
- versions of Apple Safari for Mac OS 10.0-10.28 (Safari 1.0) which\r
- lack support for keyboard events.\r
-\r
- License:\r
- This JavaScript-library is free for private and academic use.\r
- Please include a readable copyright statement and a backlink to\r
- <http://www.masswerk.at> in the web page.\r
- The library should always be accompanied by the 'readme.txt' and the\r
- sample HTML-documents.\r
- \r
- The term "private use" includes any personal or non-commercial use, which\r
- is not related to commercial activites, but excludes intranet, extranet\r
- and/or public net applications that are related to any kind of commercial\r
- or profit oriented activity.\r
-\r
- For commercial use see <http://www.masswerk.at> for contact information.\r
- \r
- Any changes should be commented and must be reflected in `Terminal.version'\r
- in the format: "Version.Subversion (compatibility)".\r
-\r
- Disclaimer:\r
- This software is distributed AS IS and in the hope that it will be useful,\r
- but WITHOUT ANY WARRANTY; without even the implied warranty of\r
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. The entire risk as to\r
- the quality and performance of the product is borne by the user. No use of\r
- the product is authorized hereunder except under this disclaimer.\r
-\r
- ### The sections above must not be removed. ###\r
- \r
- version 1.01: added Terminal.prototype.resizeTo(x,y)\r
- added Terminal.conf.fontClass (=> configureable class name)\r
- Terminal.prototype.open() now checks for element conf.termDiv\r
- in advance and returns success.\r
-\r
- version 1.02: added support for <TAB> and Euro sign\r
- (Terminal.conf.printTab, Terminal.conf.printEuro)\r
- and a method to evaluate printable chars:\r
- Terminal.prototype.isPrintable(keycode)\r
-\r
- version 1.03: added global keyboard locking (TermGlobals.keylock)\r
- modified Terminal.prototype.redraw for speed (use of locals)\r
-\r
- version 1.04: modified the key handler to fix a bug with MSIE5/Mac\r
- fixed a bug in TermGlobals.setVisible with older MSIE-alike\r
- browsers without DOM support.\r
-\r
- version 1.05: added config flag historyUnique.\r
- \r
- version 1.06: fixed CTRl+ALT (Windows alt gr) isn't CTRL any more\r
- fixed double backspace bug for Safari;\r
- added TermGlobals.setDisplay for setting style.display props\r
- termlib.js now outputs lower case html (xhtml compatibility)\r
-\r
- version 1.07: added method rebuild() to rebuild with new color settings.\r
-\r
-*/\r
-\r
-var TerminalDefaults = {\r
- // dimensions\r
- cols:80,\r
- rows:24,\r
- // appearance\r
- x:100,\r
- y:100,\r
- termDiv:'termDiv',\r
- bgColor:'#181818',\r
- frameColor:'#555555',\r
- frameWidth:1,\r
- rowHeight:15,\r
- blinkDelay:500,\r
- // css class\r
- fontClass:'term',\r
- // initial cursor mode\r
- crsrBlinkMode:false,\r
- crsrBlockMode:true,\r
- // key mapping\r
- DELisBS:false,\r
- printTab:true,\r
- printEuro:true,\r
- catchCtrlH:true,\r
- closeOnESC:true,\r
- // prevent consecutive history doublets\r
- historyUnique:false,\r
- // optional id\r
- id:0,\r
- // strings\r
- ps:'>',\r
- greeting:'%+r Terminal ready. %-r',\r
- // handlers\r
- handler:termDefaultHandler,\r
- ctrlHandler:null,\r
- initHandler:null,\r
- exitHandler:null\r
-}\r
-\r
-var Terminal = function(conf) {\r
- if (typeof conf != 'object') conf=new Object();\r
- else {\r
- for (var i in TerminalDefaults) {\r
- if (typeof conf[i] == 'undefined') conf[i]=TerminalDefaults[i];\r
- }\r
- }\r
- this.conf=conf;\r
- this.version='1.07 (original)';\r
- this.isSafari= (navigator.userAgent.indexOf('Safari')>=0)? true:false;\r
- this.setInitValues();\r
-}\r
-\r
-Terminal.prototype.setInitValues=function() {\r
- this.id=this.conf.id;\r
- this.maxLines=this.conf.rows;\r
- this.maxCols=this.conf.cols;\r
- this.termDiv=this.conf.termDiv;\r
- this.crsrBlinkMode=this.conf.crsrBlinkMode;\r
- this.crsrBlockMode=this.conf.crsrBlockMode;\r
- this.blinkDelay=this.conf.blinkDelay;\r
- this.DELisBS=this.conf.DELisBS;\r
- this.printTab=this.conf.printTab;\r
- this.printEuro=this.conf.printEuro;\r
- this.catchCtrlH=this.conf.catchCtrlH;\r
- this.closeOnESC=this.conf.closeOnESC;\r
- this.historyUnique=this.conf.historyUnique;\r
- this.ps=this.conf.ps;\r
- this.closed=false;\r
- this.r;\r
- this.c;\r
- this.charBuf=new Array();\r
- this.styleBuf=new Array();\r
- this.scrollBuf=null;\r
- this.blinkBuffer=0;\r
- this.blinkTimer;\r
- this.cursoractive=false;\r
- this.lock=true;\r
- this.insert=false;\r
- this.charMode=false;\r
- this.rawMode=false;\r
- this.lineBuffer='';\r
- this.inputChar=0;\r
- this.lastLine='';\r
- this.guiCounter=0;\r
- this.history=new Array();\r
- this.histPtr=0;\r
- this.env=new Object();\r
- this.ns4ParentDoc=null;\r
- this.handler=this.conf.handler;\r
- this.ctrlHandler=this.conf.ctrlHandler;\r
- this.initHandler=this.conf.initHandler;\r
- this.exitHandler=this.conf.exitHandler;\r
-}\r
-\r
-function termDefaultHandler() {\r
- this.newLine();\r
- if (this.lineBuffer != '') {\r
- this.type('You typed: '+this.lineBuffer);\r
- this.newLine();\r
- }\r
- this.prompt();\r
-}\r
-\r
-Terminal.prototype.open=function() {\r
- if (this.termDivReady()) {\r
- if (!this.closed) this._makeTerm();\r
- this.init();\r
- return true;\r
- }\r
- else return false;\r
-}\r
-\r
-Terminal.prototype.close=function() {\r
- this.lock=true;\r
- this.cursorOff();\r
- if (this.exitHandler) this.exitHandler();\r
- TermGlobals.setVisible(this.termDiv,0);\r
- this.closed=true;\r
-}\r
-\r
-Terminal.prototype.init=function() {\r
- // wait for gui\r
- if (this.guiReady()) {\r
- this.guiCounter=0;\r
- // clean up at re-entry\r
- if (this.closed) {\r
- this.setInitValues();\r
- }\r
- this.clear();\r
- TermGlobals.setVisible(this.termDiv,1);\r
- TermGlobals.enableKeyboard(this);\r
- if (this.initHandler) {\r
- this.initHandler();\r
- }\r
- else {\r
- this.write(this.conf.greeting);\r
- this.newLine();\r
- this.prompt();\r
- }\r
- }\r
- else {\r
- this.guiCounter++;\r
- if (this.guiCounter>18000) {\r
- if (confirm('Terminal:\nYour browser hasn\'t responded for more than 2 minutes.\nRetry?')) this.guiCounter=0\r
- else return;\r
- };\r
- TermGlobals.termToInitialze=this;\r
- window.setTimeout('TermGlobals.termToInitialze.init()',200);\r
- }\r
-}\r
-\r
-Terminal.prototype.getRowArray=function(l,v) {\r
- var a=new Array();\r
- for (var i=0; i<l; i++) a[i]=v;\r
- return a;\r
-}\r
-\r
-Terminal.prototype.type=function(text,style) {\r
- for (var i=0; i<text.length; i++) {\r
- var ch=text.charCodeAt(i);\r
- if (!this.isPrintable(ch)) ch=94;\r
- this.charBuf[this.r][this.c]=ch;\r
- this.styleBuf[this.r][this.c]=(style)? style:0;\r
- var last_r=this.r;\r
- this._incCol();\r
- if (this.r!=last_r) this.redraw(last_r);\r
- }\r
- this.redraw(this.r)\r
-}\r
-\r
-Terminal.prototype.write=function(text,usemore) {\r
- // write to scroll buffer with markup\r
- // new line = '%n' prepare any strings or arrys first\r
- if (typeof text != 'object') {\r
- if (typeof text!='string') text=''+text;\r
- if (text.indexOf('\n')>=0) {\r
- var ta=text.split('\n');\r
- text=ta.join('%n');\r
- }\r
- }\r
- else {\r
- if (text.join) text=text.join('%n')\r
- else text=''+text;\r
- }\r
- this._sbInit(usemore);\r
- var chunks=text.split('%');\r
- var esc=(text.charAt(0)!='%');\r
- var style=0;\r
- for (var i=0; i<chunks.length; i++) {\r
- if (esc) {\r
- if (chunks[i].length>0) this._sbType(chunks[i],style)\r
- else if (i>0) this._sbType('%', style);\r
- esc=false;\r
- }\r
- else {\r
- var func=chunks[i].charAt(0);\r
- if ((chunks[i].length==0) && (i>0)) {\r
- this._sbType("%",style);\r
- esc=true;\r
- }\r
- else if (func=='n') {\r
- this._sbNewLine();\r
- if (chunks[i].length>1) this._sbType(chunks[i].substring(1),style);\r
- }\r
- else if (func=='+') {\r
- var opt=chunks[i].charAt(1);\r
- opt=opt.toLowerCase();\r
- if (opt=='p') style=0\r
- else if (opt=='r') style|=1\r
- else if (opt=='u') style|=2\r
- else if (opt=='i') style|=4\r
- else if (opt=='s') style|=8;\r
- if (chunks[i].length>2) this._sbType(chunks[i].substring(2),style);\r
- }\r
- else if (func=='-') {\r
- var opt=chunks[i].charAt(1);\r
- opt=opt.toLowerCase();\r
- if (opt=='p') style|=0\r
- else if (opt=='r') style&=~1\r
- else if (opt=='u') style&=~2\r
- else if (opt=='i') style&=~4\r
- else if (opt=='s') style&=~8;\r
- if (chunks[i].length>2) this._sbType(chunks[i].substring(2),style);\r
- }\r
- else if ((chunks[i].length>1) && (chunks[i].charAt(0)=='C') && (chunks[i].charAt(1)=='S')) {\r
- this.clear();\r
- this._sbInit();\r
- if (chunks[i].length>2) this._sbType(chunks[i].substring(2),style);\r
- }\r
- else {\r
- if (chunks[i].length>0) this._sbType(chunks[i],style);\r
- }\r
- }\r
- }\r
- this._sbOut();\r
-}\r
-\r
-Terminal.prototype._sbType=function(text,style) {\r
- // type to scroll buffer\r
- var sb=this.scrollBuf;\r
- for (var i=0; i<text.length; i++) {\r
- var ch=text.charCodeAt(i);\r
- if (!this.isPrintable(ch)) ch=94;\r
- sb.lines[sb.r][sb.c]=ch;\r
- sb.styles[sb.r][sb.c]=(style)? style:0;\r
- sb.c++;\r
- if (sb.c>=this.maxCols) this._sbNewLine();\r
- }\r
-}\r
-\r
-Terminal.prototype._sbNewLine=function() {\r
- var sb=this.scrollBuf;\r
- sb.r++;\r
- sb.c=0;\r
- sb.lines[sb.r]=this.getRowArray(this.conf.cols,0);\r
- sb.styles[sb.r]=this.getRowArray(this.conf.cols,0);\r
-}\r
-\r
-\r
-Terminal.prototype._sbInit=function(usemore) {\r
- var sb=this.scrollBuf=new Object();\r
- var sbl=sb.lines=new Array();\r
- var sbs=sb.styles=new Array();\r
- sb.more=usemore;\r
- sb.line=0;\r
- sb.status=0;\r
- sb.r=0;\r
- sb.c=this.c;\r
- sbl[0]=this.getRowArray(this.conf.cols,0);\r
- sbs[0]=this.getRowArray(this.conf.cols,0);\r
- for (var i=0; i<this.c; i++) {\r
- sbl[0][i]=this.charBuf[this.r][i];\r
- sbs[0][i]=this.styleBuf[this.r][i];\r
- }\r
-}\r
-\r
-Terminal.prototype._sbOut=function() {\r
- var sb=this.scrollBuf;\r
- var sbl=sb.lines;\r
- var sbs=sb.styles;\r
- var tcb=this.charBuf;\r
- var tsb=this.styleBuf;\r
- var ml=this.maxLines;\r
- var buflen=sbl.length;\r
- if (sb.more) {\r
- if (sb.status) {\r
- if (this.inputChar==TermGlobals.lcMoreKeyAbort) {\r
- this.r=ml-1;\r
- this.c=0;\r
- tcb[this.r]=this.getRowArray(this.maxLines,0);\r
- tsb[this.r]=this.getRowArray(this.maxLines,0);\r
- this.redraw(this.r);\r
- this.handler=sb.handler;\r
- this.charMode=false;\r
- this.inputChar=0;\r
- this.scrollBuf=null;\r
- this.prompt();\r
- return;\r
- }\r
- else if (this.inputChar==TermGlobals.lcMoreKeyContinue) {\r
- this.clear();\r
- }\r
- else {\r
- return;\r
- }\r
- }\r
- else {\r
- if (this.r>=ml-1) this.clear();\r
- }\r
- }\r
- if (this.r+buflen-sb.line<=ml) {\r
- for (var i=sb.line; i<buflen; i++) {\r
- var r=this.r+i-sb.line;\r
- tcb[r]=sbl[i];\r
- tsb[r]=sbs[i];\r
- this.redraw(r);\r
- }\r
- this.r+=sb.r-sb.line;\r
- this.c=sb.c;\r
- if (sb.more) {\r
- if (sb.status) this.handler=sb.handler;\r
- this.charMode=false;\r
- this.inputChar=0;\r
- this.scrollBuf=null;\r
- this.prompt();\r
- return;\r
- }\r
- }\r
- else if (sb.more) {\r
- ml--;\r
- if (sb.status==0) {\r
- sb.handler=this.handler;\r
- this.handler=this._sbOut;\r
- this.charMode=true;\r
- sb.status=1;\r
- }\r
- if (this.r) {\r
- var ofs=ml-this.r;\r
- for (var i=sb.line; i<ofs; i++) {\r
- var r=this.r+i-sb.line;\r
- tcb[r]=sbl[i];\r
- tsb[r]=sbs[i];\r
- this.redraw(r);\r
- }\r
- }\r
- else {\r
- var ofs=sb.line+ml;\r
- for (var i=sb.line; i<ofs; i++) {\r
- var r=this.r+i-sb.line;\r
- tcb[r]=sbl[i];\r
- tsb[r]=sbs[i];\r
- this.redraw(r);\r
- }\r
- }\r
- sb.line=ofs;\r
- this.r=ml;\r
- this.c=0;\r
- this.type(TermGlobals.lcMorePrompt1, TermGlobals.lcMorePromtp1Style);\r
- this.type(TermGlobals.lcMorePrompt2, TermGlobals.lcMorePrompt2Style);\r
- this.lock=false;\r
- return;\r
- }\r
- else if (buflen>=ml) {\r
- var ofs=buflen-ml;\r
- for (var i=0; i<ml; i++) {\r
- var r=ofs+i;\r
- tcb[i]=sbl[r];\r
- tsb[i]=sbs[r];\r
- this.redraw(i);\r
- }\r
- this.r=ml-1;\r
- this.c=sb.c;\r
- }\r
- else {\r
- var dr=ml-buflen;\r
- var ofs=this.r-dr;\r
- for (var i=0; i<dr; i++) {\r
- var r=ofs+i;\r
- for (var c=0; c<this.maxCols; c++) {\r
- tcb[i][c]=tcb[r][c];\r
- tsb[i][c]=tsb[r][c];\r
- }\r
- this.redraw(i);\r
- }\r
- for (var i=0; i<buflen; i++) {\r
- var r=dr+i;\r
- tcb[r]=sbl[i];\r
- tsb[r]=sbs[i];\r
- this.redraw(r);\r
- }\r
- this.r=ml-1;\r
- this.c=sb.c;\r
- }\r
- this.scrollBuf=null;\r
-}\r
-\r
-// basic console output\r
-\r
-Terminal.prototype.typeAt=function(r,c,text,style) {\r
- var tr1=this.r;\r
- var tc1=this.c;\r
- this.cursorSet(r,c);\r
- for (var i=0; i<text.length; i++) {\r
- var ch=text.charCodeAt(i);\r
- if (!this.isPrintable(ch)) ch=94;\r
- this.charBuf[this.r][this.c]=ch;\r
- this.styleBuf[this.r][this.c]=(style)? style:0;\r
- var last_r=this.r;\r
- this._incCol();\r
- if (this.r!=last_r) this.redraw(last_r);\r
- }\r
- this.redraw(this.r);\r
- this.r=tr1;\r
- this.c=tc1;\r
-}\r
-\r
-Terminal.prototype.statusLine = function(text,style,offset) {\r
- var ch,r;\r
- style=((style) && (!isNaN(style)))? parseInt(style)&15:0;\r
- if ((offset) && (offset>0)) r=this.conf.rows-offset\r
- else r=this.conf.rows-1;\r
- for (var i=0; i<this.conf.cols; i++) {\r
- if (i<text.length) {\r
- ch=text.charCodeAt(i);\r
- if (!this.isPrintable(ch)) ch = 94;\r
- }\r
- else ch=0;\r
- this.charBuf[r][i]=ch;\r
- this.styleBuf[r][i]=style;\r
- }\r
- this.redraw(r);\r
-}\r
-\r
-Terminal.prototype.printRowFromString = function(r,text,style) {\r
- var ch;\r
- style=((style) && (!isNaN(style)))? parseInt(style)&15:0;\r
- if ((r>=0) && (r<this.maxLines)) {\r
- if (typeof text != 'string') text=''+text;\r
- for (var i=0; i<this.conf.cols; i++) {\r
- if (i<text.length) {\r
- ch=text.charCodeAt(i);\r
- if (!this.isPrintable(ch)) ch = 94;\r
- }\r
- else ch=0;\r
- this.charBuf[r][i]=ch;\r
- this.styleBuf[r][i]=style;\r
- }\r
- this.redraw(r);\r
- }\r
-}\r
-\r
-Terminal.prototype.setChar=function(ch,r,c,style) {\r
- this.charBuf[r][c]=ch;\r
- this.styleBuf[this.r][this.c]=(style)? style:0;\r
- this.redraw(r);\r
-}\r
-\r
-Terminal.prototype._charOut=function(ch, style) {\r
- this.charBuf[this.r][this.c]=ch;\r
- this.styleBuf[this.r][this.c]=(style)? style:0;\r
- this.redraw(this.r);\r
- this._incCol();\r
-}\r
-\r
-Terminal.prototype._incCol=function() {\r
- this.c++;\r
- if (this.c>=this.maxCols) {\r
- this.c=0;\r
- this._incRow();\r
- }\r
-}\r
-\r
-Terminal.prototype._incRow=function() {\r
- this.r++;\r
- if (this.r>=this.maxLines) {\r
- this._scrollLines(0,this.maxLines);\r
- this.r=this.maxLines-1;\r
- }\r
-}\r
-\r
-Terminal.prototype._scrollLines=function(start, end) {\r
- window.status='Scrolling lines ...';\r
- start++;\r
- for (var ri=start; ri<end; ri++) {\r
- var rt=ri-1;\r
- this.charBuf[rt]=this.charBuf[ri];\r
- this.styleBuf[rt]=this.styleBuf[ri];\r
- }\r
- // clear last line\r
- var rt=end-1;\r
- this.charBuf[rt]=this.getRowArray(this.conf.cols,0);\r
- this.styleBuf[rt]=this.getRowArray(this.conf.cols,0);\r
- this.redraw(rt);\r
- for (var r=end-1; r>=start; r--) this.redraw(r-1);\r
- window.status='';\r
-}\r
-\r
-Terminal.prototype.newLine=function() {\r
- this.c=0;\r
- this._incRow();\r
-}\r
-\r
-Terminal.prototype.clear=function() {\r
- window.status='Clearing display ...';\r
- this.cursorOff();\r
- this.insert=false;\r
- for (var ri=0; ri<this.maxLines; ri++) {\r
- this.charBuf[ri]=this.getRowArray(this.conf.cols,0);\r
- this.styleBuf[ri]=this.getRowArray(this.conf.cols,0);\r
- this.redraw(ri);\r
- }\r
- this.r=0;\r
- this.c=0;\r
- window.status='';\r
-}\r
-\r
-Terminal.prototype.reset=function() {\r
- if (this.lock) return;\r
- this.lock=true;\r
- this.rawMode=false;\r
- this.charMode=false;\r
- this.maxLines=this.conf.rows;\r
- this.maxCols=this.conf.cols;\r
- this.lastLine='';\r
- this.lineBuffer='';\r
- this.inputChar=0;\r
- this.clear();\r
-}\r
-\r
-Terminal.prototype.cursorSet=function(r,c) {\r
- var crsron=this.cursoractive;\r
- if (crsron) this.cursorOff();\r
- this.r=r%this.maxLines;\r
- this.c=c%this.maxCols;\r
- this._cursorReset(crsron);\r
-}\r
-\r
-Terminal.prototype._cursorReset=function(crsron) {\r
- if (crsron) this.cursorOn()\r
- else {\r
- this.blinkBuffer=this.styleBuf[this.r][this.c];\r
- }\r
-}\r
-\r
-Terminal.prototype.cursorOn=function() {\r
- if (this.blinkTimer) clearTimeout(this.blinkTimer);\r
- this.blinkBuffer=this.styleBuf[this.r][this.c];\r
- this._cursorBlink();\r
- this.cursoractive=true;\r
-}\r
-\r
-Terminal.prototype.cursorOff=function() {\r
- if (this.blinkTimer) clearTimeout(this.blinkTimer);\r
- if (this.cursoractive) {\r
- this.styleBuf[this.r][this.c]=this.blinkBuffer;\r
- this.redraw(this.r);\r
- this.cursoractive=false;\r
- }\r
-}\r
-\r
-Terminal.prototype._cursorBlink=function() {\r
- if (this.blinkTimer) clearTimeout(this.blinkTimer);\r
- if (this == TermGlobals.activeTerm) {\r
- if (this.crsrBlockMode) {\r
- this.styleBuf[this.r][this.c]=(this.styleBuf[this.r][this.c]&1)?\r
- this.styleBuf[this.r][this.c]&254:this.styleBuf[this.r][this.c]|1;\r
- }\r
- else {\r
- this.styleBuf[this.r][this.c]=(this.styleBuf[this.r][this.c]&2)?\r
- this.styleBuf[this.r][this.c]&253:this.styleBuf[this.r][this.c]|2;\r
- }\r
- this.redraw(this.r);\r
- }\r
- if (this.crsrBlinkMode) this.blinkTimer=setTimeout('TermGlobals.activeTerm._cursorBlink()', this.blinkDelay);\r
-}\r
-\r
-Terminal.prototype.cursorLeft=function() {\r
- var crsron=this.cursoractive;\r
- if (crsron) this.cursorOff();\r
- var r=this.r;\r
- var c=this.c;\r
- if (c>0) c--\r
- else if (r>0) {\r
- c=this.maxCols-1;\r
- r--;\r
- }\r
- if (this.isPrintable(this.charBuf[r][c])) {\r
- this.r=r;\r
- this.c=c;\r
- }\r
- this.insert=true;\r
- this._cursorReset(crsron);\r
-}\r
-\r
-Terminal.prototype.cursorRight=function() {\r
- var crsron=this.cursoractive;\r
- if (crsron) this.cursorOff();\r
- var r=this.r;\r
- var c=this.c;\r
- if (c<this.maxCols-1) c++\r
- else if (r<this.maxLines-1) {\r
- c=0;\r
- r++;\r
- }\r
- if (!this.isPrintable(this.charBuf[r][c])) {\r
- this.insert=false;\r
- }\r
- if (this.isPrintable(this.charBuf[this.r][this.c])) {\r
- this.r=r;\r
- this.c=c;\r
- }\r
- this._cursorReset(crsron);\r
-}\r
-\r
-Terminal.prototype.backspace=function() {\r
- var crsron=this.cursoractive;\r
- if (crsron) this.cursorOff();\r
- var r=this.r;\r
- var c=this.c;\r
- if (c>0) c--\r
- else if (r>0) {\r
- c=this.maxCols-1;\r
- r--;\r
- };\r
- if (this.isPrintable(this.charBuf[r][c])) {\r
- this._scrollLeft(r, c);\r
- this.r=r;\r
- this.c=c;\r
- }; \r
- this._cursorReset(crsron);\r
-}\r
-\r
-Terminal.prototype.fwdDelete=function() {\r
- var crsron=this.cursoractive;\r
- if (crsron) this.cursorOff();\r
- if (this.isPrintable(this.charBuf[this.r][this.c])) {\r
- this._scrollLeft(this.r,this.c);\r
- if (!this.isPrintable(this.charBuf[this.r][this.c])) this.insert=false;\r
- }\r
- this._cursorReset(crsron);\r
-}\r
-\r
-Terminal.prototype.prompt=function() {\r
- this.lock=true;\r
- if (this.c>0) this.newLine();\r
- this.type(this.ps);\r
- this._charOut(1);\r
- this.lock=false;\r
- this.cursorOn();\r
-}\r
-\r
-Terminal.prototype._scrollLeft=function(r,c) {\r
- var rows=new Array();\r
- rows[0]=r;\r
- while (this.isPrintable(this.charBuf[r][c])) {\r
- var ri=r;\r
- var ci=c+1;\r
- if (ci==this.maxCols) {\r
- if (ri<this.maxLines-1) {\r
- ci=0;\r
- ri++;\r
- rows[rows.length]=ri;\r
- }\r
- else {\r
- break;\r
- }\r
- }\r
- this.charBuf[r][c]=this.charBuf[ri][ci];\r
- this.styleBuf[r][c]=this.styleBuf[ri][ci];\r
- c=ci;\r
- r=ri;\r
- }\r
- if (this.charBuf[r][c]!=0) this.charBuf[r][c]=0;\r
- for (var i=0; i<rows.length; i++) this.redraw(rows[i]);\r
-}\r
-\r
-Terminal.prototype._scrollRight=function(r,c) {\r
- var rows=new Array();\r
- var end=this._getLineEnd(r,c);\r
- var ri=end[0];\r
- var ci=end[1];\r
- if ((ci==this.maxCols-1) && (ri==this.maxLines-1)) {\r
- if (r==0) return;\r
- this._scrollLines(0,this.maxLines);\r
- this.r--;\r
- r--;\r
- ri--;\r
- }\r
- rows[r]=1;\r
- while (this.isPrintable(this.charBuf[ri][ci])) {\r
- var rt=ri;\r
- var ct=ci+1;\r
- if (ct==this.maxCols) {\r
- ct=0;\r
- rt++;\r
- rows[rt]=1;\r
- }\r
- this.charBuf[rt][ct]=this.charBuf[ri][ci];\r
- this.styleBuf[rt][ct]=this.styleBuf[ri][ci];\r
- if ((ri==r) && (ci==c)) break;\r
- ci--;\r
- if (ci<0) {\r
- ci=this.maxCols-1;\r
- ri--;\r
- rows[ri]=1;\r
- }\r
- }\r
- for (var i=r; i<this.maxLines; i++) {\r
- if (rows[i]) this.redraw(i);\r
- }\r
-}\r
-\r
-Terminal.prototype._getLineEnd=function(r,c) {\r
- if (!this.isPrintable(this.charBuf[r][c])) {\r
- c--;\r
- if (c<0) {\r
- if (r>0) {\r
- r--;\r
- c=this.maxCols-1;\r
- }\r
- else {\r
- c=0;\r
- }\r
- }\r
- }\r
- if (this.isPrintable(this.charBuf[r][c])) {\r
- while (true) {\r
- var ri=r;\r
- var ci=c+1;\r
- if (ci==this.maxCols) {\r
- if (ri<this.maxLines-1) {\r
- ri++;\r
- ci=0;\r
- }\r
- else {\r
- break;\r
- }\r
- }\r
- if (!this.isPrintable(this.charBuf[ri][ci])) break;\r
- c=ci;\r
- r=ri;\r
- }\r
- }\r
- return [r,c];\r
-}\r
-\r
-Terminal.prototype._getLineStart=function(r,c) {\r
- // not used by now, just in case anyone needs this ...\r
- var ci, ri;\r
- if (!this.isPrintable(this.charBuf[r][c])) {\r
- ci=c-1;\r
- ri=r;\r
- if (ci<0) {\r
- if (ri==0) return [0,0];\r
- ci=this.maxCols-1;\r
- ri--;\r
- }\r
- if (!this.isPrintable(this.charBuf[ri][ci])) return [r,c]\r
- else {\r
- r=ri;\r
- c=ci;\r
- }\r
- }\r
- while (true) {\r
- var ri=r;\r
- var ci=c-1;\r
- if (ci<0) {\r
- if (ri==0) break;\r
- ci=this.maxCols-1;\r
- ri--;\r
- }\r
- if (!this.isPrintable(this.charBuf[ri][ci])) break;;\r
- r=ri;\r
- c=ci;\r
- }\r
- return [r,c];\r
-}\r
-\r
-Terminal.prototype._getLine=function() {\r
- var end=this._getLineEnd(this.r,this.c);\r
- var r=end[0];\r
- var c=end[1];\r
- var line=new Array();\r
- while (this.isPrintable(this.charBuf[r][c])) {\r
- line[line.length]=String.fromCharCode(this.charBuf[r][c]);\r
- if (c>0) c--\r
- else if (r>0) {\r
- c=this.maxCols-1;\r
- r--;\r
- }\r
- else break;\r
- }\r
- line.reverse();\r
- return line.join('');\r
-}\r
-\r
-Terminal.prototype._clearLine=function() {\r
- var end=this._getLineEnd(this.r,this.c);\r
- var r=end[0];\r
- var c=end[1];\r
- var line='';\r
- while (this.isPrintable(this.charBuf[r][c])) {\r
- this.charBuf[r][c]=0;\r
- if (c>0) {\r
- c--;\r
- }\r
- else if (r>0) {\r
- this.redraw(r);\r
- c=this.maxCols-1;\r
- r--;\r
- }\r
- else break;\r
- }\r
- if (r!=end[0]) this.redraw(r);\r
- c++;\r
- this.cursorSet(r,c);\r
- this.insert=false;\r
-}\r
-\r
-Terminal.prototype.isPrintable=function(ch, unicodePage1only) {\r
- if ((unicodePage1only) && (ch>255)) {\r
- return ((ch==termKey.EURO) && (this.printEuro))? true:false;\r
- }\r
- return (\r
- ((ch>=32) && (ch!=termKey.DEL)) ||\r
- ((this.printTab) && (ch==termKey.TAB))\r
- );\r
-}\r
-\r
-// keyboard focus\r
-\r
-Terminal.prototype.focus=function() {\r
- TermGlobals.activeTerm=this;\r
-}\r
-\r
-// global store and functions\r
-\r
-var TermGlobals={\r
- termToInitialze:null,\r
- activeTerm:null,\r
- kbdEnabled:false,\r
- keylock:false,\r
- lcMorePrompt1: ' -- MORE -- ',\r
- lcMorePromtp1Style: 1,\r
- lcMorePrompt2: ' (Type: space to continue, \'q\' to quit)',\r
- lcMorePrompt2Style: 0,\r
- lcMoreKeyAbort: 113,\r
- lcMoreKeyContinue: 32\r
-};\r
-\r
-// keybard focus\r
-\r
-TermGlobals.setFocus=function(termref) {\r
- TermGlobals.activeTerm=termref;\r
-}\r
-\r
-// text related\r
-\r
-TermGlobals.normalize=function(n,m) {\r
- var s=''+n;\r
- while (s.length<m) s='0'+s;\r
- return s;\r
-}\r
-\r
-TermGlobals.fillLeft=function(t,n) {\r
- if (typeof t != 'string') t=''+t;\r
- while (t.length<n) t=' '+t;\r
- return t;\r
-}\r
-\r
-TermGlobals.center=function(t,l) {\r
- var s='';\r
- for (var i=t.length; i<l; i+=2) s+=' ';\r
- return s+t;\r
-}\r
-\r
-TermGlobals.stringReplace=function(s1,s2,t) {\r
- var l1=s1.length;\r
- var l2=s2.length;\r
- var ofs=t.indexOf(s1);\r
- while (ofs>=0) {\r
- t=t.substring(0,ofs)+s2+t.substring(ofs+l1);\r
- ofs=t.indexOf(s1,ofs+l2);\r
- }\r
- return t;\r
-}\r
-\r
-// keyboard\r
-\r
-var termKey= {\r
- // special key codes\r
- 'NUL': 0x00,\r
- 'SOH': 0x01,\r
- 'STX': 0x02,\r
- 'ETX': 0x03,\r
- 'EOT': 0x04,\r
- 'ENQ': 0x05,\r
- 'ACK': 0x06,\r
- 'BEL': 0x07,\r
- 'BS': 0x08,\r
- 'HT': 0x09,\r
- 'TAB': 0x09,\r
- 'LF': 0x0A,\r
- 'VT': 0x0B,\r
- 'FF': 0x0C,\r
- 'CR': 0x0D,\r
- 'SO': 0x0E,\r
- 'SI': 0x0F,\r
- 'DLE': 0x10,\r
- 'DC1': 0x11,\r
- 'DC2': 0x12,\r
- 'DC3': 0x13,\r
- 'DC4': 0x14,\r
- 'NAK': 0x15,\r
- 'SYN': 0x16,\r
- 'ETB': 0x17,\r
- 'CAN': 0x18,\r
- 'EM': 0x19,\r
- 'SUB': 0x1A,\r
- 'ESC': 0x1B,\r
- 'IS4': 0x1C,\r
- 'IS3': 0x1D,\r
- 'IS2': 0x1E,\r
- 'IS1': 0x1F,\r
- 'DEL': 0x7F,\r
- // other specials\r
- 'EURO': 0x20AC,\r
- // cursor mapping\r
- 'LEFT': 0x1C,\r
- 'RIGHT': 0x1D,\r
- 'UP': 0x1E,\r
- 'DOWN': 0x1F\r
-};\r
-\r
-var termDomKeyRef = {\r
- DOM_VK_LEFT: termKey.LEFT,\r
- DOM_VK_RIGHT: termKey.RIGHT,\r
- DOM_VK_UP: termKey.UP,\r
- DOM_VK_DOWN: termKey.DOWN,\r
- DOM_VK_BACK_SPACE: termKey.BS,\r
- DOM_VK_RETURN: termKey.CR,\r
- DOM_VK_ENTER: termKey.CR,\r
- DOM_VK_ESCAPE: termKey.ESC,\r
- DOM_VK_DELETE: termKey.DEL,\r
- DOM_VK_TAB: termKey.TAB\r
-};\r
-\r
-TermGlobals.enableKeyboard=function(term) {\r
- if (!this.kbdEnabled) {\r
- if (document.addEventListener) document.addEventListener("keypress", this.keyHandler, true)\r
- else {\r
- if ((self.Event) && (self.Event.KEYPRESS)) document.captureEvents(Event.KEYPRESS);\r
- document.onkeypress = this.keyHandler;\r
- }\r
- window.document.onkeydown=this.keyFix;\r
- this.kbdEnabled=true;\r
- }\r
- this.activeTerm=term;\r
-}\r
-\r
-TermGlobals.keyFix=function(e) {\r
- var term=TermGlobals.activeTerm;\r
- if ((TermGlobals.keylock) || (term.lock)) return true;\r
- if (window.event) {\r
- var ch=window.event.keyCode;\r
- if (!e) e=window.event;\r
- if (e.DOM_VK_UP) {\r
- for (var i in termDomKeyRef) {\r
- if ((e[i]) && (ch == e[i])) {\r
- this.keyHandler({which:termDomKeyRef[i],_remapped:true});\r
- if (e.preventDefault) e.preventDefault();\r
- if (e.stopPropagation) e.stopPropagation();\r
- e.cancleBubble=true;\r
- return false;\r
- }\r
- }\r
- e.cancleBubble=false;\r
- return true;\r
- }\r
- else {\r
- // no DOM support\r
- if ((ch==8) && (!term.isSafari)) TermGlobals.keyHandler({which:termKey.BS,_remapped:true})\r
- else if (ch==9) TermGlobals.keyHandler({which:termKey.TAB,_remapped:true})\r
- else if (ch==37) TermGlobals.keyHandler({which:termKey.LEFT,_remapped:true})\r
- else if (ch==39) TermGlobals.keyHandler({which:termKey.RIGHT,_remapped:true})\r
- else if (ch==38) TermGlobals.keyHandler({which:termKey.UP,_remapped:true})\r
- else if (ch==40) TermGlobals.keyHandler({which:termKey.DOWN,_remapped:true})\r
- else if (ch==127) TermGlobals.keyHandler({which:termKey.DEL,_remapped:true})\r
- else if ((ch>=57373) && (ch<=57376)) {\r
- if (ch==57373) TermGlobals.keyHandler({which:termKey.UP,_remapped:true})\r
- else if (ch==57374) TermGlobals.keyHandler({which:termKey.DOWN,_remapped:true})\r
- else if (ch==57375) TermGlobals.keyHandler({which:termKey.LEFT,_remapped:true})\r
- else if (ch==57376) TermGlobals.keyHandler({which:termKey.RIGHT,_remapped:true});\r
- }\r
- else {\r
- e.cancleBubble=false;\r
- return true;\r
- }\r
- if (e.preventDefault) e.preventDefault();\r
- if (e.stopPropagation) e.stopPropagation();\r
- e.cancleBubble=true;\r
- return false;\r
- }\r
- }\r
-}\r
-\r
-TermGlobals.keyHandler=function(e) {\r
- var term=TermGlobals.activeTerm;\r
- if ((TermGlobals.keylock) || (term.lock)) return true;\r
- if ((window.event) && (window.event.preventDefault)) window.event.preventDefault()\r
- else if ((e) && (e.preventDefault)) e.preventDefault();\r
- if ((window.event) && (window.event.stopPropagation)) window.event.stopPropagation()\r
- else if ((e) && (e.stopPropagation)) e.stopPropagation();\r
- var ch;\r
- var ctrl=false;\r
- var shft=false;\r
- var remapped=false;\r
- if (e) {\r
- ch=e.which;\r
- ctrl=(((e.ctrlKey) && (e.altKey)) || (e.modifiers==2));\r
- shft=((e.shiftKey) || (e.modifiers==4));\r
- if (e._remapped) {\r
- remapped=true;\r
- if (window.event) {\r
- //ctrl=((ctrl) || (window.event.ctrlKey));\r
- ctrl=((ctrl) || ((window.event.ctrlKey) && (!window.event.altKey)));\r
- shft=((shft) || (window.event.shiftKey));\r
- }\r
- }\r
- }\r
- else if (window.event) {\r
- ch=window.event.keyCode;\r
- //ctrl=(window.event.ctrlKey);\r
- ctrl=((window.event.ctrlKey) && (!window.event.altKey)); // allow alt gr == ctrl alts\r
- shft=(window.event.shiftKey);\r
- }\r
- else {\r
- return true;\r
- }\r
- if ((ch=='') && (remapped==false)) {\r
- // map specials\r
- if (e==null) e=window.event;\r
- if ((e.charCode==0) && (e.keyCode)) {\r
- if (e.DOM_VK_UP) {\r
- for (var i in termDomKeyRef) {\r
- if ((e[i]) && (e.keyCode == e[i])) {\r
- ch=termDomKeyRef[i];\r
- break;\r
- }\r
- }\r
- }\r
- else {\r
- // NS4\r
- if (e.keyCode==28) ch=termKey.LEFT\r
- else if (e.keyCode==29) ch=termKey.RIGHT\r
- else if (e.keyCode==30) ch=termKey.UP\r
- else if (e.keyCode==31) ch=termKey.DOWN\r
- // Mozilla alike but no DOM support\r
- else if (e.keyCode==37) ch=termKey.LEFT\r
- else if (e.keyCode==39) ch=termKey.RIGHT\r
- else if (e.keyCode==38) ch=termKey.UP\r
- else if (e.keyCode==40) ch=termKey.DOWN\r
- // just to have the TAB mapping here too\r
- else if (e.keyCode==9) ch=termKey.TAB;\r
- }\r
- }\r
- }\r
- // key actions\r
- if (term.charMode) {\r
- term.insert=false;\r
- term.inputChar=ch;\r
- term.lineBuffer='';\r
- term.handler();\r
- if ((ch<=32) && (window.event)) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- if (!ctrl) {\r
- // special keys\r
- if (ch==termKey.CR) {\r
- term.lock=true;\r
- term.cursorOff();\r
- term.insert=false;\r
- if (term.rawMode) {\r
- term.lineBuffer=term.lastLine;\r
- }\r
- else {\r
- term.lineBuffer=term._getLine();\r
- if (\r
- (term.lineBuffer!='') && ((!term.historyUnique) ||\r
- (term.history.length==0) ||\r
- (term.lineBuffer!=term.history[term.history.length-1]))\r
- ) {\r
- term.history[term.history.length]=term.lineBuffer;\r
- }\r
- term.histPtr=term.history.length;\r
- }\r
- term.lastLine='';\r
- term.inputChar=0;\r
- term.handler();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (ch==termKey.ESC) {\r
- if (term.conf.closeOnESC) term.close();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- if ((ch<32) && (term.rawMode)) {\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else {\r
- if (ch==termKey.LEFT) {\r
- term.cursorLeft();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (ch==termKey.RIGHT) {\r
- term.cursorRight();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (ch==termKey.UP) {\r
- term.cursorOff();\r
- if (term.histPtr==term.history.length) term.lastLine=term._getLine();\r
- term._clearLine();\r
- if ((term.history.length) && (term.histPtr>=0)) {\r
- if (term.histPtr>0) term.histPtr--;\r
- term.type(term.history[term.histPtr]);\r
- }\r
- else if (term.lastLine) term.type(term.lastLine);\r
- term.cursorOn();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (ch==termKey.DOWN) {\r
- term.cursorOff();\r
- if (term.histPtr==term.history.length) term.lastLine=term._getLine();\r
- term._clearLine();\r
- if ((term.history.length) && (term.histPtr<=term.history.length)) {\r
- if (term.histPtr<term.history.length) term.histPtr++;\r
- if (term.histPtr<term.history.length) term.type(term.history[term.histPtr])\r
- else if (term.lastLine) term.type(term.lastLine);\r
- }\r
- else if (term.lastLine) term.type(term.lastLine);\r
- term.cursorOn();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (ch==termKey.BS) {\r
- term.backspace();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (ch==termKey.DEL) {\r
- if (term.DELisBS) term.backspace()\r
- else term.fwdDelete();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- }\r
- }\r
- if (term.rawMode) {\r
- if (term.isPrintable(ch)) {\r
- term.lastLine+=String.fromCharCode(ch);\r
- }\r
- if ((ch==32) && (window.event)) window.event.cancleBubble=true\r
- else if ((window.opera) && (window.event)) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else {\r
- if ((term.conf.catchCtrlH) && ((ch==termKey.BS) || ((ctrl) && (ch==72)))) {\r
- // catch ^H\r
- term.backspace();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if ((term.ctrlHandler) && ((ch<32) || ((ctrl) && (term.isPrintable(ch,true))))) {\r
- if (((ch>=65) && (ch<=96)) || (ch==63)) {\r
- // remap canonical\r
- if (ch==63) ch=31\r
- else ch-=64;\r
- }\r
- term.inputChar=ch;\r
- term.ctrlHandler();\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if ((ctrl) || (!term.isPrintable(ch,true))) {\r
- if (window.event) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- else if (term.isPrintable(ch,true)) {\r
- if (term.blinkTimer) clearTimeout(term.blinkTimer);\r
- if (term.insert) {\r
- term.cursorOff();\r
- term._scrollRight(term.r,term.c);\r
- }\r
- term._charOut(ch);\r
- term.cursorOn();\r
- if ((ch==32) && (window.event)) window.event.cancleBubble=true\r
- else if ((window.opera) && (window.event)) window.event.cancleBubble=true;\r
- return false;\r
- }\r
- }\r
- return true;\r
-}\r
-\r
-// term gui\r
-\r
-TermGlobals.hasSubDivs=false;\r
-TermGlobals.hasLayers=false;\r
-TermGlobals.termStringStart='';\r
-TermGlobals.termStringEnd='';\r
-\r
-TermGlobals.termSpecials=new Array();\r
-TermGlobals.termSpecials[0]=' ';\r
-TermGlobals.termSpecials[1]=' ';\r
-TermGlobals.termSpecials[9]=' ';\r
-TermGlobals.termSpecials[32]=' ';\r
-TermGlobals.termSpecials[34]='"';\r
-TermGlobals.termSpecials[38]='&';\r
-TermGlobals.termSpecials[60]='<';\r
-TermGlobals.termSpecials[62]='>';\r
-TermGlobals.termSpecials[127]='◊';\r
-TermGlobals.termSpecials[0x20AC]='€';\r
-\r
-TermGlobals.termStyles=new Array(1,2,4,8);\r
-TermGlobals.termStyleOpen=new Array();\r
-TermGlobals.termStyleClose=new Array();\r
-TermGlobals.termStyleOpen[1]='<span class="termReverse">';\r
-TermGlobals.termStyleClose[1]='<\/span>';\r
-TermGlobals.termStyleOpen[2]='<u>';\r
-TermGlobals.termStyleClose[2]='<\/u>';\r
-TermGlobals.termStyleOpen[4]='<i>';\r
-TermGlobals.termStyleClose[4]='<\/i>';\r
-TermGlobals.termStyleOpen[8]='<strike>';\r
-TermGlobals.termStyleClose[8]='<\/strike>';\r
-\r
-Terminal.prototype._makeTerm=function(rebuild) {\r
- window.status='Building terminal ...';\r
- TermGlobals.hasLayers=(document.layers)? true:false;\r
- TermGlobals.hasSubDivs=(navigator.userAgent.indexOf('Gecko')<0);\r
- var divPrefix=this.termDiv+'_r';\r
- var s='';\r
- s+='<table border="0" cellspacing="0" cellpadding="'+this.conf.frameWidth+'">\n';\r
- s+='<tr><td bgcolor="'+this.conf.frameColor+'"><table border="0" cellspacing="0" cellpadding="2"><tr><td bgcolor="'+this.conf.bgColor+'"><table border="0" cellspacing="0" cellpadding="0">\n';\r
- var rstr='';\r
- for (var c=0; c<this.conf.cols; c++) rstr+=' ';\r
- for (var r=0; r<this.conf.rows; r++) {\r
- var termid=((TermGlobals.hasLayers) || (TermGlobals.hasSubDivs))? '' : ' id="'+divPrefix+r+'"';\r
- s+='<tr><td nowrap height="'+this.conf.rowHeight+'"'+termid+' class="'+this.conf.fontClass+'">'+rstr+'<\/td><\/tr>\n';\r
- }\r
- s+='<\/table><\/td><\/tr>\n';\r
- s+='<\/table><\/td><\/tr>\n';\r
- s+='<\/table>\n';\r
- var termOffset=2+this.conf.frameWidth;\r
- if (TermGlobals.hasLayers) {\r
- for (var r=0; r<this.conf.rows; r++) {\r
- s+='<layer name="'+divPrefix+r+'" top="'+(termOffset+r*this.conf.rowHeight)+'" left="'+termOffset+'" class="'+this.conf.fontClass+'"><\/layer>\n';\r
- }\r
- this.ns4ParentDoc=document.layers[this.termDiv].document;\r
- TermGlobals.termStringStart='<table border="0" cellspacing="0" cellpadding="0"><tr><td nowrap height="'+this.conf.rowHeight+'" class="'+this.conf.fontClass+'">';\r
- TermGlobals.termStringEnd='<\/td><\/tr><\/table>';\r
- }\r
- else if (TermGlobals.hasSubDivs) {\r
- for (var r=0; r<this.conf.rows; r++) {\r
- s+='<div id="'+divPrefix+r+'" style="position:absolute; top:'+(termOffset+r*this.conf.rowHeight)+'px; left: '+termOffset+'px;" class="'+this.conf.fontClass+'"><\/div>\n';\r
- }\r
- TermGlobals.termStringStart='<table border="0" cellspacing="0" cellpadding="0"><tr><td nowrap height="'+this.conf.rowHeight+'" class="'+this.conf.fontClass+'">';\r
- TermGlobals.termStringEnd='<\/td><\/tr><\/table>';\r
- }\r
- TermGlobals.writeElement(this.termDiv,s);\r
- if (!rebuild) {\r
- TermGlobals.setElementXY(this.termDiv,this.conf.x,this.conf.y);\r
- TermGlobals.setVisible(this.termDiv,1);\r
- }\r
- window.status='';\r
-}\r
-\r
-Terminal.prototype.rebuild=function() {\r
- // check for bounds and array lengths\r
- var rl=this.conf.rows;\r
- var cl=this.conf.cols;\r
- for (var r=0; r<rl; r++) {\r
- var cbr=this.charBuf[r];\r
- if (!cbr) {\r
- this.charBuf[r]=this.getRowArray(cl,0);\r
- this.styleBuf[r]=this.getRowArray(cl,0);\r
- }\r
- else if (cbr.length<cl) {\r
- for (var c=cbr.length; c<cl; c++) {\r
- this.charBuf[r][c]=0;\r
- this.styleBuf[r][c]=0;\r
- }\r
- }\r
- }\r
- var resetcrsr=false;\r
- if (this.r>=rl) {\r
- r=rl-1;\r
- resetcrsr=true;\r
- }\r
- if (this.c>=cl) {\r
- c=cl-1;\r
- resetcrsr=true;\r
- }\r
- if ((resetcrsr) && (this.cursoractive)) this.cursorOn();\r
- // and actually rebuild\r
- this._makeTerm(true);\r
- for (var r=0; r<rl; r++) {\r
- this.redraw(r);\r
- }\r
-}\r
-\r
-Terminal.prototype.moveTo=function(x,y) {\r
- TermGlobals.setElementXY(this.termDiv,x,y);\r
-}\r
-\r
-Terminal.prototype.resizeTo=function(x,y) {\r
- if (this.termDivReady()) {\r
- x=parseInt(x,10);\r
- y=parseInt(y,10);\r
- if ((isNaN(x)) || (isNaN(y)) || (x<4) || (y<2)) return false;\r
- this.maxCols=this.conf.cols=x;\r
- this.maxLines=this.conf.rows=y;\r
- this._makeTerm();\r
- this.clear();\r
- return true;\r
- }\r
- else return false;\r
-}\r
-\r
-Terminal.prototype.redraw=function(r) {\r
- var s=TermGlobals.termStringStart;\r
- var curStyle=0;\r
- var tstls=TermGlobals.termStyles;\r
- var tscls=TermGlobals.termStyleClose;\r
- var tsopn=TermGlobals.termStyleOpen;\r
- var tspcl=TermGlobals.termSpecials;\r
- var t_cb=this.charBuf;\r
- var t_sb=this.styleBuf;\r
- for (var i=0; i<this.conf.cols; i++) {\r
- var c=t_cb[r][i];\r
- var cs=t_sb[r][i];\r
- if (cs!=curStyle) {\r
- if (curStyle) {\r
- for (var k=tstls.length-1; k>=0; k--) {\r
- var st=tstls[k];\r
- if (curStyle&st) s+=tscls[st];\r
- }\r
- }\r
- curStyle=cs;\r
- for (var k=0; k<tstls.length; k++) {\r
- var st=tstls[k];\r
- if (curStyle&st) s+=tsopn[st];\r
- }\r
- }\r
- s+= (tspcl[c])? tspcl[c] : String.fromCharCode(c);\r
- }\r
- if (curStyle>0) {\r
- for (var k=tstls.length-1; k>=0; k--) {\r
- var st=tstls[k];\r
- if (curStyle&st) s+=tscls[st];\r
- }\r
- }\r
- s+=TermGlobals.termStringEnd;\r
- TermGlobals.writeElement(this.termDiv+'_r'+r,s,this.ns4ParentDoc);\r
-}\r
-\r
-Terminal.prototype.guiReady=function() {\r
- ready=true;\r
- if (TermGlobals.guiElementsReady(this.termDiv, self.document)) {\r
- for (var r=0; r<this.conf.rows; r++) {\r
- if (TermGlobals.guiElementsReady(this.termDiv+'_r'+r,this.ns4ParentDoc)==false) {\r
- ready=false;\r
- break;\r
- }\r
- }\r
- }\r
- else ready=false;\r
- return ready;\r
-}\r
-\r
-Terminal.prototype.termDivReady=function() {\r
- if (document.layers) {\r
- return (document.layers[this.termDiv])? true:false;\r
- }\r
- else if (document.getElementById) {\r
- return (document.getElementById(this.termDiv))? true:false;\r
- }\r
- else if (document.all) {\r
- return (document.all[this.termDiv])? true:false;\r
- }\r
- else {\r
- return false;\r
- }\r
-}\r
-\r
-Terminal.prototype.getDimensions=function() {\r
- var w=0;\r
- var h=0;\r
- var d=this.termDiv;\r
- if (document.layers) {\r
- if (document.layers[d]) {\r
- w=document.layers[d].clip.right;\r
- h=document.layers[d].clip.bottom;\r
- }\r
- }\r
- else if (document.getElementById) {\r
- var obj=document.getElementById(d);\r
- if ((obj) && (obj.firstChild)) {\r
- w=parseInt(obj.firstChild.offsetWidth,10);\r
- h=parseInt(obj.firstChild.offsetHeight,10);\r
- }\r
- else if ((obj) && (obj.children) && (obj.children[0])) {\r
- w=parseInt(obj.children[0].offsetWidth,10);\r
- h=parseInt(obj.children[0].offsetHeight,10);\r
- }\r
- }\r
- else if (document.all) {\r
- var obj=document.all[d];\r
- if ((obj) && (obj.children) && (obj.children[0])) {\r
- w=parseInt(obj.children[0].offsetWidth,10);\r
- h=parseInt(obj.children[0].offsetHeight,10);\r
- }\r
- }\r
- return { width: w, height: h };\r
-}\r
-\r
-// basic dynamics\r
-\r
-TermGlobals.writeElement=function(e,t,d) {\r
- if (document.layers) {\r
- var doc=(d)? d : self.document;\r
- doc.layers[e].document.open();\r
- doc.layers[e].document.write(t);\r
- doc.layers[e].document.close();\r
- }\r
- else if (document.getElementById) {\r
- var obj=document.getElementById(e);\r
- obj.innerHTML=t;\r
- }\r
- else if (document.all) {\r
- document.all[e].innerHTML=t;\r
- }\r
-}\r
-\r
-TermGlobals.setElementXY=function(d,x,y) {\r
- if (document.layers) {\r
- document.layers[d].moveTo(x,y);\r
- }\r
- else if (document.getElementById) {\r
- var obj=document.getElementById(d);\r
- obj.style.left=x+'px';\r
- obj.style.top=y+'px';\r
- }\r
- else if (document.all) {\r
- document.all[d].style.left=x+'px';\r
- document.all[d].style.top=y+'px';\r
- }\r
-}\r
-\r
-TermGlobals.setVisible=function(d,v) {\r
- if (document.layers) {\r
- document.layers[d].visibility= (v)? 'show':'hide';\r
- }\r
- else if (document.getElementById) {\r
- var obj=document.getElementById(d);\r
- obj.style.visibility= (v)? 'visible':'hidden';\r
- }\r
- else if (document.all) {\r
- document.all[d].style.visibility= (v)? 'visible':'hidden';\r
- }\r
-}\r
-\r
-TermGlobals.setDisplay=function(d,v) {\r
- if (document.getElementById) {\r
- var obj=document.getElementById(d);\r
- obj.style.display=v;\r
- }\r
- else if (document.all) {\r
- document.all[d].style.display=v;\r
- }\r
-}\r
-\r
-TermGlobals.guiElementsReady=function(e,d) {\r
- if (document.layers) {\r
- var doc=(d)? d : self.document;\r
- return ((doc) && (doc.layers[e]))? true:false;\r
- }\r
- else if (document.getElementById) {\r
- return (document.getElementById(e))? true:false;\r
- }\r
- else if (document.all) {\r
- return (document.all[e])? true:false;\r
- }\r
- else return false;\r
-}\r
-\r
-\r
-// constructor mods (ie4 fix)\r
-\r
-var termString_keyref;\r
-var termString_keycoderef;\r
-\r
-function termString_makeKeyref() {\r
- termString_keyref= new Array();\r
- termString_keycoderef= new Array();\r
- var hex= new Array('A','B','C','D','E','F');\r
- for (var i=0; i<=15; i++) {\r
- var high=(i<10)? i:hex[i-10];\r
- for (var k=0; k<=15; k++) {\r
- var low=(k<10)? k:hex[k-10];\r
- var cc=i*16+k;\r
- if (cc>=32) {\r
- var cs=unescape("%"+high+low);\r
- termString_keyref[cc]=cs;\r
- termString_keycoderef[cs]=cc;\r
- }\r
- }\r
- }\r
-}\r
-\r
-if (!String.fromCharCode) {\r
- termString_makeKeyref();\r
- String.fromCharCode=function(cc) {\r
- return (cc!=null)? termString_keyref[cc] : '';\r
- };\r
-}\r
-if (!String.prototype.charCodeAt) {\r
- if (!termString_keycoderef) termString_makeKeyref();\r
- String.prototype.charCodeAt=function(n) {\r
- cs=this.charAt(n);\r
- return (termString_keycoderef[cs])? termString_keycoderef[cs] : 0;\r
- };\r
-}\r
-\r
-// eof
\ No newline at end of file
+++ /dev/null
-/*\r
- termlib_parser.js v.1.0\r
- command line parser for termlib.js\r
- (c) Norbert Landsteiner 2005\r
- mass:werk - media environments\r
- <http://www.masswerk.at>\r
-\r
- you are free to use this parser under the "termlib.js" license.\r
-\r
- usage: call "parseLine(this)" from your Terminal handler\r
- parsed args in this.argv\r
- quoting levels per arg in this.argQL (value: quote char)\r
- this.argc: pointer to this.argv and this.argQL (used by parserGetopt)\r
- call parseretopt(this, "<options>") from your handler to get opts\r
- (returns an object with properties for every option flag. any float\r
- values are stored in Object.<flag>.value; illegal opts in array\r
- Object.illegals)\r
-\r
- configuration: you may want to overide the follow objects (or add properties):\r
- parserWhiteSpace: chars to be parsed as whitespace\r
- parserQuoteChars: chars to be parsed as quotes\r
- parserSingleEscapes: chars to escape a quote or escape expression\r
- parserOptionChars: chars that start an option\r
- parserEscapeExpressions: chars that start escape expressions\r
-*/\r
-\r
-// chars to be parsed as white space\r
-var parserWhiteSpace = {\r
- ' ': true,\r
- '\t': true\r
-}\r
-\r
-// chars to be parsed as quotes\r
-var parserQuoteChars = {\r
- '"': true,\r
- "'": true,\r
- '`': true\r
-};\r
-\r
-// chars to be parsed as escape char\r
-var parserSingleEscapes = {\r
- '\\': true\r
-};\r
-\r
-// chars that mark the start of an option-expression\r
-// for use with parserGetopt\r
-var parserOptionChars = {\r
- '-': true\r
-}\r
-\r
-// chars that start escape expressions (value = handler)\r
-// plugin handlers for ascii escapes or variable substitution\r
-var parserEscapeExpressions = {\r
- '%': parserHexExpression\r
-}\r
-\r
-function parserHexExpression(termref, pointer, echar, quotelevel) {\r
- /* example for parserEscapeExpressions\r
- params:\r
- termref: ref to Terminal instance\r
- pointer: position in termref.lineBuffer (echar)\r
- echar: escape character found\r
- quotelevel: current quoting level (quote char or empty)\r
- char under pointer will be ignored\r
- the return value is added to the current argument\r
- */\r
- // convert hex values to chars (e.g. %20 => <SPACE>)\r
- if (termref.lineBuffer.length > pointer+2) {\r
- // get next 2 chars\r
- var hi = termref.lineBuffer.charAt(pointer+1);\r
- var lo = termref.lineBuffer.charAt(pointer+2);\r
- lo = lo.toUpperCase();\r
- hi = hi.toUpperCase();\r
- // check for valid hex digits\r
- if ((((hi>='0') && (hi<='9')) || ((hi>='A') && ((hi<='F')))) &&\r
- (((lo>='0') && (lo<='9')) || ((lo>='A') && ((lo<='F'))))) {\r
- // next 2 chars are valid hex, so strip them from lineBuffer\r
- parserEscExprStrip(termref, pointer+1, pointer+3);\r
- // and return the char\r
- return String.fromCharCode(parseInt(hi+lo, 16));\r
- }\r
- }\r
- // if not handled return the escape character (=> no conversion)\r
- return echar;\r
-}\r
-\r
-function parserEscExprStrip(termref, from, to) {\r
- // strip characters from termref.lineBuffer (for use with escape expressions)\r
- termref.lineBuffer =\r
- termref.lineBuffer.substring(0, from) +\r
- termref.lineBuffer.substring(to);\r
-}\r
-\r
-function parserGetopt(termref, optsstring) {\r
- // scans argv form current position of argc for opts\r
- // arguments in argv must not be quoted\r
- // returns an object with a property for every option flag found\r
- // option values (absolute floats) are stored in Object.<opt>.value (default -1)\r
- // the property "illegals" contains an array of all flags found but not in optstring\r
- // argc is set to first argument that is not an option\r
- var opts = { 'illegals':[] };\r
- while ((termref.argc < termref.argv.length) && (termref.argQL[termref.argc]=='')) {\r
- var a = termref.argv[termref.argc];\r
- if ((a.length>0) && (parserOptionChars[a.charAt(0)])) {\r
- var i = 1;\r
- while (i<a.length) {\r
- var c=a.charAt(i);\r
- var v = '';\r
- while (i<a.length-1) {\r
- var nc=a.charAt(i+1);\r
- if ((nc=='.') || ((nc>='0') && (nc<='9'))) {\r
- v += nc;\r
- i++;\r
- }\r
- else break;\r
- }\r
- if (optsstring.indexOf(c)>=0) {\r
- opts[c] = (v == '')? {value:-1} : (isNaN(v))? {value:0} : {value:parseFloat(v)};\r
- }\r
- else {\r
- opts.illegals[opts.illegals.length]=c;\r
- }\r
- i++;\r
- }\r
- termref.argc++;\r
- }\r
- else break;\r
- }\r
- return opts;\r
-}\r
-\r
-function parseLine(termref) {\r
- // stand-alone parser, takes a Terminal instance as argument\r
- // parses the command line and stores results as instance properties\r
- // argv: list of parsed arguments\r
- // argQL: argument's quoting level (<empty> or quote character)\r
- // argc: cursur for argv, set initinally to zero (0)\r
- // open quote strings are not an error but automatically closed.\r
- var argv = ['']; // arguments vector\r
- var argQL = ['']; // quoting level\r
- var argc = 0; // arguments cursor\r
- var escape = false ; // escape flag\r
- for (var i=0; i<termref.lineBuffer.length; i++) {\r
- var ch= termref.lineBuffer.charAt(i);\r
- if (escape) {\r
- argv[argc] += ch;\r
- escape = false;\r
- }\r
- else if (parserEscapeExpressions[ch]) {\r
- var v = parserEscapeExpressions[ch](termref, i, ch, argQL[argc]);\r
- if (typeof v != 'undefined') argv[argc] += v;\r
- }\r
- else if (parserQuoteChars[ch]) {\r
- if (argQL[argc]) {\r
- if (argQL[argc] == ch) {\r
- argc ++;\r
- argv[argc] = argQL[argc] = '';\r
- }\r
- else {\r
- argv[argc] += ch;\r
- }\r
- }\r
- else {\r
- if (argv[argc] != '') {\r
- argc ++;\r
- argv[argc] = '';\r
- argQL[argc] = ch;\r
- }\r
- else {\r
- argQL[argc] = ch;\r
- }\r
- }\r
- }\r
- else if (parserWhiteSpace[ch]) {\r
- if (argQL[argc]) {\r
- argv[argc] += ch;\r
- }\r
- else if (argv[argc] != '') {\r
- argc++;\r
- argv[argc] = argQL[argc] = '';\r
- }\r
- }\r
- else if (parserSingleEscapes[ch]) {\r
- escape = true;\r
- }\r
- else {\r
- argv[argc] += ch;\r
- }\r
- }\r
- if ((argv[argc] == '') && (!argQL[argc])) {\r
- argv.length--;\r
- argQL.length--;\r
- }\r
- termref.argv = argv;\r
- termref.argQL = argQL;\r
- termref.argc = 0;\r
-}\r
-\r
-// eof
\ No newline at end of file
+++ /dev/null
-Web interface for Factor to Javascript compiler
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel furnace furnace.validator http.server.responders
- help help.topics html splitting sequences words strings
- quotations macros vocabs tools.browser combinators
- arrays io.files ;
-IN: webapps.help
-
-! : string>topic ( string -- topic )
- ! " " split dup length 1 = [ first ] when ;
-
-: show-help ( topic -- )
- serving-html
- dup article-title [
- [ help ] with-html-stream
- ] simple-html-document ;
-
-\ show-help {
- { "topic" }
-} define-action
-\ show-help { { "topic" "handbook" } } default-values
-
-M: link browser-link-href
- link-name
- dup word? over f eq? or [
- browser-link-href
- ] [
- dup array? [ " " join ] when
- [ show-help ] curry quot-link
- ] if ;
-
-: show-word ( word vocab -- )
- lookup show-help ;
-
-\ show-word {
- { "word" }
- { "vocab" }
-} define-action
-\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values
-
-M: f browser-link-href
- drop \ f browser-link-href ;
-
-M: word browser-link-href
- dup word-name swap word-vocabulary
- [ show-word ] 2curry quot-link ;
-
-: show-vocab ( vocab -- )
- f >vocab-link show-help ;
-
-\ show-vocab {
- { "vocab" }
-} define-action
-
-\ show-vocab { { "vocab" "kernel" } } default-values
-
-M: vocab-spec browser-link-href
- vocab-name [ show-vocab ] curry quot-link ;
-
-: show-vocabs-tagged ( tag -- )
- <vocab-tag> show-help ;
-
-\ show-vocabs-tagged {
- { "tag" }
-} define-action
-
-M: vocab-tag browser-link-href
- vocab-tag-name [ show-vocabs-tagged ] curry quot-link ;
-
-: show-vocabs-by ( author -- )
- <vocab-author> show-help ;
-
-\ show-vocabs-by {
- { "author" }
-} define-action
-
-M: vocab-author browser-link-href
- vocab-author-name [ show-vocabs-by ] curry quot-link ;
-
-"help" "show-help" "extra/webapps/help" web-app
-
-! Hard-coding for factorcode.org
-PREDICATE: pathname resource-pathname
- pathname-string "resource:" head? ;
-
-M: resource-pathname browser-link-href
- pathname-string
- "resource:" ?head drop
- "/responder/source/" swap append ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! cont-number-guess
-!
-! 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.
-!
-! This example modifies the console based 'numbers-game' example
-! in a very minimal way to demonstrate conversion of a console
-! program to a web based application.
-!
-! All that was required was changing the input and output functions
-! to use HTML. The remaining code was untouched.
-!
-! The result is not that pretty but it shows the basic idea.
-USING: kernel math parser html html.elements io namespaces
-math.parser random webapps.continuation ;
-
-IN: webapps.numbers
-
-: web-print ( str -- )
- #! Display the string in a web page.
- [
- swap dup
- <html>
- <head> <title> write </title> </head>
- <body>
- <p> write </p>
- <p> <a =href a> "Press to continue" write </a> </p>
- </body>
- </html>
- ] show 2drop ;
-
-: read-number ( -- )
- [
- <html>
- <head> <title> "Enter a number" write </title> </head>
- <body>
- <form =action "post" =method form>
- <p>
- "Enter a number:" write
- <input "text" =type "num" =name "20" =size input/>
- <input "submit" =type "Press to continue" =value input/>
- </p>
- </form>
- </body>
- </html>
- ] show [ "num" get ] bind string>number ;
-
-: guess-banner
- "I'm thinking of a number between 0 and 100." web-print ;
-: guess-prompt ;
-: too-high "Too high" web-print ;
-: too-low "Too low" web-print ;
-: correct "Correct - you win!" web-print ;
-: inexact-guess ( actual guess -- )
- < [ too-high ] [ too-low ] if ;
-
-: judge-guess ( actual guess -- ? )
- 2dup = [
- 2drop correct f
- ] [
- inexact-guess t
- ] if ;
-
-: number-to-guess ( -- n ) 100 random ;
-
-: numbers-game-loop ( actual -- )
- dup guess-prompt read-number judge-guess [
- numbers-game-loop
- ] [
- drop
- ] if ;
-
-: numbers-game number-to-guess numbers-game-loop ;
-
-"numbers-game" [ numbers-game ] install-cont-responder
+++ /dev/null
-<% USING: io math math.parser namespaces furnace ; %>
-
-<h1>Annotate</h1>
-
-<form method="POST" action="/responder/pastebin/annotate-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="n" value="<% "n" get number>string write %>" />
-<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
-<input type="SUBMIT" value="Annotate" />
-</form>
+++ /dev/null
-<% USING: namespaces io furnace calendar ; %>
-
-<h2>Annotation: <% "summary" get write %></h2>
-
-<table>
-<tr><th align="right">Annotation by:</th><td><% "author" get write %></td></tr>
-<tr><th align="right">File type:</th><td><% "mode" get write %></td></tr>
-<tr><th align="right">Created:</th><td><% "date" get timestamp>string write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
+++ /dev/null
-Slava Pestov
+++ /dev/null
-</body>
-
-</html>
+++ /dev/null
-<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
-
-<!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">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title><% "title" get write %></title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <% default-stylesheet %>
- <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
-
- <div class="navbar">
- <% [ paste-list ] "Paste list" render-link %> |
- <% [ new-paste ] "New paste" render-link %> |
- <% [ feed.xml ] "Syndicate" render-link %>
- </div>
- <h1 class="pastebin-title"><% "title" get write %></h1>
+++ /dev/null
-<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
-
-<select name="mode">
- <% modes keys natural-sort [
- <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
- ] each %>
-</select>
+++ /dev/null
-<% USING: continuations furnace namespaces ; %>
-
-<%
- "New paste" "title" set
- "header" render-template
-%>
-
-<form method="POST" action="/responder/pastebin/submit-paste">
-
-<table>
-
-<tr>
-<th align="right">Summary:</th>
-<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
-<td align="left" class="error"><% "summary" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">Your name:</th>
-<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
-<td class="error"><% "author" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right">File type:</th>
-<td><% "modes" render-template %></td>
-</tr>
-
-<!--
-<tr>
-<th align="right">Channel:</th>
-<td><input type="TEXT" name="channel" value="#concatenative" /></td>
-</tr>
--->
-
-<tr>
-<td></td>
-<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
-</tr>
-
-<tr>
-<th align="right" valign="top">Content:</th>
-<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
-</tr>
-</table>
-
-<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
-<input type="SUBMIT" value="Submit paste" />
-</form>
-
-<% "footer" render-template %>
+++ /dev/null
-<% USING: namespaces furnace sequences ; %>
-
-<%
- "Pastebin" "title" set
- "header" render-template
-%>
-
-<table width="100%" cellspacing="10">
- <tr>
- <td valign="top">
- <table width="100%">
- <tr align="left" class="pastebin-headings">
- <th width="50%">Summary:</th>
- <th width="100">Paste by:</th>
- <th width="200">Date:</th>
- </tr>
- <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
- </table>
- </td>
- <td valign="top" width="25%">
- <div class="infobox">
- <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
- </p>
- <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
- </p>
- <p>
- <% "webapps.pastebin" browse-webapp-source %></p>
- </div>
- </td>
- </tr>
-</table>
-
-<% "footer" render-template %>
+++ /dev/null
-<% USING: continuations namespaces io kernel math math.parser
-furnace webapps.pastebin calendar sequences ; %>
-
-<tr>
- <td>
- <a href="<% model get paste-link write %>">
- <% "summary" get write %>
- </a>
- </td>
- <td><% "author" get write %></td>
- <td><% "date" get timestamp>string write %></td>
-</tr>
+++ /dev/null
-USING: calendar furnace furnace.validator io.files kernel
-namespaces sequences http.server.responders html math.parser rss
-xml.writer xmode.code2html math ;
-IN: webapps.pastebin
-
-TUPLE: pastebin pastes ;
-
-: <pastebin> ( -- pastebin )
- V{ } clone pastebin construct-boa ;
-
-<pastebin> pastebin set-global
-
-TUPLE: paste
-summary author channel mode contents date
-annotations n ;
-
-: <paste> ( summary author channel mode contents -- paste )
- f V{ } clone f paste construct-boa ;
-
-TUPLE: annotation summary author mode contents ;
-
-C: <annotation> annotation
-
-: get-paste ( n -- paste )
- pastebin get pastebin-pastes nth ;
-
-: show-paste ( n -- )
- serving-html
- get-paste
- [ "show-paste" render-component ] with-html-stream ;
-
-\ show-paste { { "n" v-number } } define-action
-
-: new-paste ( -- )
- serving-html
- [ "new-paste" render-template ] with-html-stream ;
-
-\ new-paste { } define-action
-
-: paste-list ( -- )
- serving-html
- [
- [ show-paste ] "show-paste-quot" set
- [ new-paste ] "new-paste-quot" set
- pastebin get "paste-list" render-component
- ] with-html-stream ;
-
-\ paste-list { } define-action
-
-: paste-link ( paste -- link )
- paste-n number>string [ show-paste ] curry quot-link ;
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: paste-feed ( -- entries )
- pastebin get pastebin-pastes <reversed> 20 safe-head [
- {
- paste-summary
- paste-link
- paste-date
- } get-slots timestamp>rfc3339 f swap <entry>
- ] map ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- "pastebin"
- "http://pastebin.factorcode.org"
- paste-feed <feed> feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: add-paste ( paste pastebin -- )
- >r now over set-paste-date r>
- pastebin-pastes 2dup length swap set-paste-n push ;
-
-: submit-paste ( summary author channel mode contents -- )
- <paste> [ pastebin get add-paste ] keep
- paste-link permanent-redirect ;
-
-\ new-paste
-\ submit-paste {
- { "summary" v-required }
- { "author" v-required }
- { "channel" }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ new-paste {
- { "channel" "#concatenative" }
- { "mode" "factor" }
-} default-values
-
-: annotate-paste ( n summary author mode contents -- )
- <annotation> swap get-paste
- [ paste-annotations push ] keep
- paste-link permanent-redirect ;
-
-[ "n" show-paste ]
-\ annotate-paste {
- { "n" v-required v-number }
- { "summary" v-required }
- { "author" v-required }
- { "mode" v-required }
- { "contents" v-required }
-} define-form
-
-\ show-paste {
- { "mode" "factor" }
-} default-values
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-"pastebin" "paste-list" "extra/webapps/pastebin" web-app
+++ /dev/null
-<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
-
-<%
- "Paste: " "summary" get append "title" set
- "header" render-template
-%>
-
-<table>
-<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
-<!-- <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -->
-<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
-<tr><th>File type:</th><td><% "mode" get write %></td></tr>
-</table>
-
-<% "syntax" render-template %>
-
-<% "annotations" get [ "annotation" render-component ] each %>
-
-<% model get "annotate-paste" render-component %>
-
-<% "footer" render-template %>
+++ /dev/null
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.pastebin-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-pre.code {
- border:1px dashed #ccc;
- background-color:#f5f5f5;
- padding:5px;
- font-size:150%;
- color:#000000;
-}
-
-.navbar {
- background-color:#eeeeee;
- padding:5px;
- border:1px solid #ccc;
-}
-
-.infobox {
- border: 1px solid #C1DAD7;
- padding: 10px;
-}
-
-.error {
- color: red;
-}
+++ /dev/null
-<% USING: xmode.code2html splitting namespaces ; %>
-
-<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: sequences rss arrays concurrency.combinators kernel
-sorting html.elements io assocs namespaces math threads vocabs
-html furnace http.server.templating calendar math.parser
-splitting continuations debugger system http.server.responders
-xml.writer prettyprint logging ;
-IN: webapps.planet
-
-: print-posting-summary ( posting -- )
- <p "news" =class p>
- <b> dup entry-title write </b> <br/>
- <a entry-link =href "more" =class a>
- "Read More..." write
- </a>
- </p> ;
-
-: print-posting-summaries ( postings -- )
- [ print-posting-summary ] each ;
-
-: print-blogroll ( blogroll -- )
- <ul "description" =class ul>
- [
- <li> <a dup third =href a> first write </a> </li>
- ] each
- </ul> ;
-
-: format-date ( date -- string )
- rfc3339>timestamp timestamp>string ;
-
-: print-posting ( posting -- )
- <h2 "posting-title" =class h2>
- <a dup entry-link =href a>
- dup entry-title write-html
- </a>
- </h2>
- <p "posting-body" =class p>
- dup entry-description write-html
- </p>
- <p "posting-date" =class p>
- entry-pub-date format-date write
- </p> ;
-
-: print-postings ( postings -- )
- [ print-posting ] each ;
-
-SYMBOL: default-blogroll
-SYMBOL: cached-postings
-
-: safe-head ( seq n -- seq' )
- over length min head ;
-
-: mini-planet-factor ( -- )
- cached-postings get 4 safe-head print-posting-summaries ;
-
-: planet-factor ( -- )
- serving-html [ "planet" render-template ] with-html-stream ;
-
-\ planet-factor { } define-action
-
-: planet-feed ( -- feed )
- "[ planet-factor ]"
- "http://planet.factorcode.org"
- cached-postings get 30 safe-head <feed> ;
-
-: feed.xml ( -- )
- "text/xml" serving-content
- planet-feed feed>xml write-xml ;
-
-\ feed.xml { } define-action
-
-: style.css ( -- )
- "text/css" serving-content
- "style.css" send-resource ;
-
-\ style.css { } define-action
-
-SYMBOL: last-update
-
-: <posting> ( author entry -- entry' )
- clone
- [ ": " swap entry-title 3append ] keep
- [ set-entry-title ] keep ;
-
-: fetch-feed ( url -- feed )
- download-feed feed-entries ;
-
-\ fetch-feed DEBUG add-error-logging
-
-: fetch-blogroll ( blogroll -- entries )
- dup 0 <column> swap 1 <column>
- [ fetch-feed ] parallel-map
- [ [ <posting> ] with map ] 2map concat ;
-
-: sort-entries ( entries -- entries' )
- [ [ entry-pub-date ] compare ] sort <reversed> ;
-
-: update-cached-postings ( -- )
- default-blogroll get
- fetch-blogroll sort-entries
- cached-postings set-global ;
-
-: update-thread ( -- )
- millis last-update set-global
- [ update-cached-postings ] "RSS feed update slave" spawn drop
- 10 60 * 1000 * sleep
- update-thread ;
-
-: start-update-thread ( -- )
- [
- "webapps.planet" [
- update-thread
- ] with-logging
- ] "RSS feed update master" spawn drop ;
-
-"planet" "planet-factor" "extra/webapps/planet" web-app
-
-{
- { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
- { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
- { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
- { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
- { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
- { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
- { "Kio M. Smallwood"
- "http://sekenre.wordpress.com/feed/atom/"
- "http://sekenre.wordpress.com/" }
- { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
- { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
- { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
-} default-blogroll set-global
+++ /dev/null
-<% USING: namespaces html.elements webapps.planet sequences
-furnace ; %>
-
-<!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">
-<head>
- <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
-
- <title>planet-factor</title>
- <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
-</head>
-
-<body id="index">
- <h1 class="planet-title">[ planet-factor ]</h1>
- <table width="100%" cellpadding="10">
- <tr>
- <td> <% cached-postings get 20 safe-head print-postings %> </td>
- <td valign="top" width="25%" class="infobox">
- <p>
- <b>planet-factor</b> is an Atom/RSS aggregator that collects the
- contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
- <a href="http://planet.lisp.org">Planet Lisp</a>.
- </p>
- <p>
- <img src="http://planet.lisp.org/feed-icon-14x14.png" />
- <a href="feed.xml"> Syndicate </a>
- </p>
- <p>
- This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
- <% "webapps.planet" browse-webapp-source %>
- </p>
- <h2 class="blogroll-title">Blogroll</h2>
- <% default-blogroll get print-blogroll %>
- <p>
- If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
- </p>
- </td>
- </tr>
- </table>
-</body>
-
-</html>
+++ /dev/null
-body {
- font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#888;
-}
-
-h1.planet-title {
- font-size:300%;
-}
-
-a {
- color:#222;
- border-bottom:1px dotted #ccc;
- text-decoration:none;
-}
-
-a:hover {
- border-bottom:1px solid #ccc;
-}
-
-.posting-title {
- background-color:#f5f5f5;
-}
-
-pre, code {
- color:#000000;
- font-size:120%;
-}
-
-.infobox {
- border-left: 1px solid #C1DAD7;
-}
-
-.posting-date {
- text-align: right;
- font-size:90%;
-}
-
-a.more {
- display:block;
- padding:0 0 5px 0;
- color:#333;
- text-decoration:none;
- text-align:right;
- border:none;
-}
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files namespaces webapps.file http.server.responders
-xmode.code2html kernel html sequences ;
-IN: webapps.source
-
-! This responder is a potential security problem. Make sure you
-! don't have sensitive files stored under vm/, core/, extra/
-! or misc/.
-
-: check-source-path ( path -- ? )
- { "vm/" "core/" "extra/" "misc/" }
- [ head? ] with contains? ;
-
-: source-responder ( path mime-type -- )
- drop
- serving-html
- [ dup <file-reader> htmlize-stream ] with-html-stream ;
-
-global [
- ! Serve up our own source code
- "source" [
- "argument" get check-source-path [
- [
- "" resource-path "doc-root" set
- [ source-responder ] serve-file-hook set
- file-responder
- ] with-scope
- ] [
- "403 forbidden" httpd-error
- ] if
- ] add-simple-responder
-] bind
{ { "TCHAR" 260 } "cFileName" }
{ { "TCHAR" 14 } "cAlternateFileName" } ;
+C-STRUCT: BY_HANDLE_FILE_INFORMATION
+ { "DWORD" "dwFileAttributes" }
+ { "FILETIME" "ftCreationTime" }
+ { "FILETIME" "ftLastAccessTime" }
+ { "FILETIME" "ftLastWriteTime" }
+ { "DWORD" "dwVolumeSerialNumber" }
+ { "DWORD" "nFileSizeHigh" }
+ { "DWORD" "nFileSizeLow" }
+ { "DWORD" "nNumberOfLinks" }
+ { "DWORD" "nFileIndexHigh" }
+ { "DWORD" "nFileIndexLow" } ;
+
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA
TYPEDEF: void* POVERLAPPED
-USING: calendar calendar.windows kernel tools.test ;\r
-\r
-[ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test\r
-[ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test\r
-[ t ] [ windows-1601 400 years +dt [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test\r
-\r
+USING: calendar calendar.windows kernel tools.test
+windows.time ;
+IN: windows.time.tests
+
+[ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
+[ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test
+[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test
+
-! Copyright (C) 2007 Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien alien.c-types kernel math windows windows.kernel32\r
-namespaces calendar.backend ;\r
-IN: windows.time\r
-\r
-: >64bit ( lo hi -- n )\r
- 32 shift bitor ;\r
-\r
-: windows-1601 ( -- timestamp )\r
- 1601 1 1 0 0 0 0 <timestamp> ;\r
-\r
-: FILETIME>windows-time ( FILETIME -- n )\r
- [ FILETIME-dwLowDateTime ] keep\r
- FILETIME-dwHighDateTime >64bit ;\r
-\r
-: windows-time>timestamp ( n -- timestamp )\r
- 10000000 /i seconds windows-1601 swap +dt ;\r
-\r
-: windows-time ( -- n )\r
- "FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep\r
- FILETIME>windows-time ;\r
-\r
-: timestamp>windows-time ( timestamp -- n )\r
- #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)\r
- >gmt windows-1601 timestamp- >bignum 10000000 * ;\r
-\r
-: windows-time>FILETIME ( n -- FILETIME )\r
- "FILETIME" <c-object>\r
- [\r
- [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep\r
- >r -32 shift r> set-FILETIME-dwHighDateTime\r
- ] keep ;\r
-\r
-: timestamp>FILETIME ( timestamp -- FILETIME/f )\r
- [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;\r
-\r
-: FILETIME>timestamp ( FILETIME -- timestamp/f )\r
- FILETIME>windows-time windows-time>timestamp ;\r
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types kernel math windows windows.kernel32
+namespaces calendar calendar.backend ;
+IN: windows.time
+
+: >64bit ( lo hi -- n )
+ 32 shift bitor ;
+
+: windows-1601 ( -- timestamp )
+ 1601 1 1 0 0 0 0 <timestamp> ;
+
+: FILETIME>windows-time ( FILETIME -- n )
+ [ FILETIME-dwLowDateTime ] keep
+ FILETIME-dwHighDateTime >64bit ;
+
+: windows-time>timestamp ( n -- timestamp )
+ 10000000 /i seconds windows-1601 swap time+ ;
+
+: windows-time ( -- n )
+ "FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
+ FILETIME>windows-time ;
+
+: timestamp>windows-time ( timestamp -- n )
+ #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
+ >gmt windows-1601 (time-) 10000000 * >integer ;
+
+: windows-time>FILETIME ( n -- FILETIME )
+ "FILETIME" <c-object>
+ [
+ [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
+ >r -32 shift r> set-FILETIME-dwHighDateTime
+ ] keep ;
+
+: timestamp>FILETIME ( timestamp -- FILETIME/f )
+ [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
+
+: FILETIME>timestamp ( FILETIME -- timestamp/f )
+ FILETIME>windows-time windows-time>timestamp ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.c-types arrays combinators
-io io.nonblocking kernel math namespaces parser prettyprint
-sequences windows.errors windows.types windows.kernel32 words ;
+kernel math namespaces parser prettyprint sequences
+windows.errors windows.types windows.kernel32 words ;
IN: windows
: lo-word ( wparam -- lo ) <short> *short ; inline
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+Word wrapping
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays kernel math
-namespaces sequences io.encodings.utf8 x11.xlib x11.constants ;
+namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib
+x11.constants ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
>r XSelectionEvent-property zero? [
r> drop f
] [
- r> selection-property 1 window-property decode-utf8
+ r> selection-property 1 window-property utf8 decode
] if ;
: own-selection ( prop win -- )
IN: xml-rpc
USING: kernel xml arrays math generic http.client combinators
hashtables namespaces io base64 sequences strings calendar
- xml.data xml.writer xml.utilities assocs math.parser debugger ;
+ xml.data xml.writer xml.utilities assocs math.parser debugger
+ calendar.format ;
! * Sending RPC requests
! TODO: time
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-IN: xml-arith
+IN: xml.tests
USING: xml io kernel math sequences strings xml.utilities tools.test math.parser ;
PROCESS: calculate ( tag -- n )
USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
+IN: xml.tests
: xml-error-test ( expected-error xml-string -- )
[ string>xml ] curry swap [ = ] curry must-fail-with ;
USING: sequences xml kernel arrays xml.utilities io.files tools.test ;
+IN: xml.tests
: assemble-data ( tag -- 3array )
{ "URL" "snippet" "title" }
USING: kernel xml sequences assocs tools.test io arrays namespaces
xml.data xml.utilities xml.writer generic sequences.deep ;
+IN: xml.tests
: sub-tag
T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ;
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-IN: temporary
+IN: xml.tests
USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
parser strings xml.data io.files xml.writer xml.utilities state-parser
continuations assocs sequences.deep ;
HELP: names-match?\r
{ $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } }\r
{ $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." }\r
-{ $example "USE: xml.data" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }\r
+{ $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }\r
{ $see-also name } ;\r
\r
HELP: xml-chunk\r
USING: io io.streams.string io.files kernel math namespaces
prettyprint sequences arrays generic strings vectors
xml.char-classes xml.data xml.errors xml.tokenize xml.writer
-xml.utilities state-parser assocs ascii ;
+xml.utilities state-parser assocs ascii io.encodings.utf8 ;
IN: xml
! -- Overall parser with data tree
<string-reader> read-xml ;
: file>xml ( filename -- xml )
- <file-reader> read-xml ;
+ ! Autodetect encoding!
+ utf8 <file-reader> read-xml ;
: xml-reprint ( string -- )
string>xml print-xml ;
-IN: temporary
+IN: xmode.catalog.tests
USING: xmode.catalog tools.test hashtables assocs
kernel sequences io ;
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators ;
+words globs combinators io.encodings.utf8 ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
: load-catalog ( -- modes )
"extra/xmode/modes/catalog" resource-path
- <file-reader> read-xml parse-modes-tag ;
+ file>xml parse-modes-tag ;
: modes ( -- assoc )
\ modes get-global [
MEMO: (load-mode) ( name -- rule-sets )
modes at mode-file
"extra/xmode/modes/" swap append
- resource-path <file-reader> parse-mode ;
+ resource-path utf8 <file-reader> parse-mode ;
SYMBOL: rule-sets
-USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io
- io.files sequences words ;
+USING: xmode.tokens xmode.marker xmode.catalog kernel html
+html.elements io io.files sequences words io.encodings.utf8
+namespaces ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
: default-stylesheet ( -- )
<style>
"extra/xmode/code2html/stylesheet.css"
- resource-path file-contents write
+ resource-path utf8 file-contents write
</style> ;
: htmlize-stream ( path stream -- )
</html> ;
: htmlize-file ( path -- )
- dup <file-reader> over ".html" append <file-writer>
- [ htmlize-stream ] with-stream ;
+ dup utf8 [
+ stdio get
+ over ".html" append utf8 [
+ htmlize-stream
+ ] with-file-writer
+ ] with-file-reader ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: io.files io.encodings.utf8 namespaces http.server\r
+http.server.static http xmode.code2html kernel html sequences\r
+accessors fry combinators.cleave ;\r
+IN: xmode.code2html.responder\r
+\r
+: <sources> ( root -- responder )\r
+ [\r
+ drop\r
+ "text/html" <content> swap\r
+ [ file-http-date "last-modified" set-header ]\r
+ [\r
+ '[\r
+ ,\r
+ dup file-name swap utf8\r
+ <file-reader>\r
+ [ htmlize-stream ] with-html-stream\r
+ ] >>body\r
+ ] bi\r
+ ] <file-responder> ;\r
-IN: temporary
+IN: xmode.keyword-map.tests
USING: xmode.keyword-map xmode.tokens
tools.test namespaces assocs kernel strings ;
USING: xmode.tokens xmode.catalog
xmode.marker tools.test kernel ;
-IN: temporary
+IN: xmode.marker.tests
[
{
-USING: xmode.marker.context xmode.rules
+USING: xmode.marker.context xmode.rules symbols
xmode.tokens namespaces kernel sequences assocs math ;
IN: xmode.marker.state
! Based on org.gjt.sp.jedit.syntax.TokenMarker
-SYMBOL: line
-SYMBOL: last-offset
-SYMBOL: position
-SYMBOL: context
-
-SYMBOL: whitespace-end
-SYMBOL: seen-whitespace-end?
-
-SYMBOL: escaped?
-SYMBOL: process-escape?
-SYMBOL: delegate-end-escaped?
+SYMBOLS: line last-offset position context
+ whitespace-end seen-whitespace-end?
+ escaped? process-escape? delegate-end-escaped? ;
: current-rule ( -- rule )
context get line-context-in-rule ;
-IN: temporary
+IN: xmode.rules.tests
USING: xmode.rules tools.test ;
[ { 1 2 3 } ] [ f { 1 2 3 } ?push-all ] unit-test
IN: xmode.tokens
! Based on org.gjt.sp.jedit.syntax.Token
+<<
SYMBOL: tokens
-[
- { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [
- create-in dup define-symbol
- dup word-name swap
- ] H{ } map>assoc tokens set-global
-] with-compilation-unit
+{ "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [
+ create-in dup define-symbol
+ dup word-name swap
+] H{ } map>assoc tokens set-global
+>>
: string>token ( string -- id ) tokens get at ;
-IN: temporary
+IN: xmode.utilities.tests
USING: xmode.utilities tools.test xml xml.data kernel strings
vectors sequences io.files prettyprint assocs unicode.case ;
}
] [
"extra/xmode/utilities/test.xml"
- resource-path <file-reader> read-xml parse-company-tag
+ resource-path file>xml parse-company-tag
] unit-test
"Official Foo Fighters"
"http://www.foofighters.com/"
"Official site with news, tour dates, discography, store, community, and more."
-} ] [ "extra/yahoo/test-results.xml" resource-path <file-reader> read-xml parse-yahoo first ] unit-test
+} ] [ "extra/yahoo/test-results.xml" resource-path file>xml parse-yahoo first ] unit-test
[ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
test_program_installed() {
- if ! [[ -n `type -p $1` ]] ; then
- return 0;
- fi
- return 1;
+ if ! [[ -n `type -p $1` ]] ; then
+ return 0;
+ fi
+ return 1;
}
ensure_program_installed() {
- installed=0;
- for i in $* ;
- do
- echo -n "Checking for $i..."
- test_program_installed $i
- if [[ $? -eq 0 ]]; then
- echo -n "not "
- else
- installed=$(( $installed + 1 ))
- fi
- echo "found!"
- done
- if [[ $installed -eq 0 ]] ; then
- echo -n "Install "
- if [[ $# -eq 1 ]] ; then
- echo -n $1
- else
- echo -n "any of [ $* ]"
- fi
- echo " and try again."
- exit 1
- fi
+ installed=0;
+ for i in $* ;
+ do
+ echo -n "Checking for $i..."
+ test_program_installed $i
+ if [[ $? -eq 0 ]]; then
+ echo -n "not "
+ else
+ installed=$(( $installed + 1 ))
+ fi
+ echo "found!"
+ done
+ if [[ $installed -eq 0 ]] ; then
+ echo -n "Install "
+ if [[ $# -eq 1 ]] ; then
+ echo -n $1
+ else
+ echo -n "any of [ $* ]"
+ fi
+ echo " and try again."
+ exit 1
+ fi
}
check_ret() {
- RET=$?
- if [[ $RET -ne 0 ]] ; then
- echo $1 failed
- exit 2
- fi
+ RET=$?
+ if [[ $RET -ne 0 ]] ; then
+ echo $1 failed
+ exit 2
+ fi
}
check_gcc_version() {
- echo -n "Checking gcc version..."
- GCC_VERSION=`gcc --version`
- check_ret gcc
- if [[ $GCC_VERSION == *3.3.* ]] ; then
- echo "bad!"
- echo "You have a known buggy version of gcc (3.3)"
- echo "Install gcc 3.4 or higher and try again."
- exit 3
- fi
- echo "ok."
+ echo -n "Checking gcc version..."
+ GCC_VERSION=`$CC --version`
+ check_ret gcc
+ if [[ $GCC_VERSION == *3.3.* ]] ; then
+ echo "bad!"
+ echo "You have a known buggy version of gcc (3.3)"
+ echo "Install gcc 3.4 or higher and try again."
+ exit 3
+ fi
+ echo "ok."
}
set_downloader() {
- test_program_installed wget
- if [[ $? -ne 0 ]] ; then
- DOWNLOAD=wget
- else
- DOWNLOAD="curl -O"
- fi
+ test_program_installed wget curl
+ if [[ $? -ne 0 ]] ; then
+ DOWNLOADER=wget
+ else
+ DOWNLOADER="curl -O"
+ fi
}
set_md5sum() {
- test_program_installed md5sum
- if [[ $? -ne 0 ]] ; then
- MD5SUM=md5sum
- else
- MD5SUM="md5 -r"
- fi
+ test_program_installed md5sum
+ if [[ $? -ne 0 ]] ; then
+ MD5SUM=md5sum
+ else
+ MD5SUM="md5 -r"
+ fi
+}
+
+set_gcc() {
+ case $OS in
+ openbsd) ensure_program_installed egcc; CC=egcc;;
+ *) CC=gcc;;
+ esac
+}
+
+set_make() {
+ case $OS in
+ netbsd) MAKE='gmake';;
+ freebsd) MAKE='gmake';;
+ openbsd) MAKE='gmake';;
+ dragonflybsd) MAKE='gmake';;
+ *) MAKE='make';;
+ esac
+ if ! [[ $MAKE -eq 'gmake' ]] ; then
+ ensure_program_installed gmake
+ fi
}
check_installed_programs() {
- ensure_program_installed chmod
- ensure_program_installed uname
- ensure_program_installed git
- ensure_program_installed wget curl
- ensure_program_installed gcc
- ensure_program_installed make
- ensure_program_installed md5sum md5
- ensure_program_installed cut
- case $OS in
- netbsd) ensure_program_installed gmake;;
- esac
- check_gcc_version
+ ensure_program_installed chmod
+ ensure_program_installed uname
+ ensure_program_installed git
+ ensure_program_installed wget curl
+ ensure_program_installed gcc
+ ensure_program_installed make gmake
+ ensure_program_installed md5sum md5
+ ensure_program_installed cut
+ check_gcc_version
}
check_library_exists() {
- GCC_TEST=factor-library-test.c
- GCC_OUT=factor-library-test.out
- echo -n "Checking for library $1..."
- echo "int main(){return 0;}" > $GCC_TEST
- gcc $GCC_TEST -o $GCC_OUT -l $1
- if [[ $? -ne 0 ]] ; then
- echo "not found!"
- echo "Warning: library $1 not found."
- echo "***Factor will compile NO_UI=1"
- NO_UI=1
- fi
- rm -f $GCC_TEST
- check_ret rm
- rm -f $GCC_OUT
- check_ret rm
- echo "found."
+ GCC_TEST=factor-library-test.c
+ GCC_OUT=factor-library-test.out
+ echo -n "Checking for library $1..."
+ echo "int main(){return 0;}" > $GCC_TEST
+ $CC $GCC_TEST -o $GCC_OUT -l $1
+ if [[ $? -ne 0 ]] ; then
+ echo "not found!"
+ echo "Warning: library $1 not found."
+ echo "***Factor will compile NO_UI=1"
+ NO_UI=1
+ fi
+ rm -f $GCC_TEST
+ check_ret rm
+ rm -f $GCC_OUT
+ check_ret rm
+ echo "found."
}
check_X11_libraries() {
- check_library_exists freetype
- check_library_exists GLU
- check_library_exists GL
- check_library_exists X11
+ check_library_exists freetype
+ check_library_exists GLU
+ check_library_exists GL
+ check_library_exists X11
}
check_libraries() {
- case $OS in
- linux) check_X11_libraries;;
- esac
+ case $OS in
+ linux) check_X11_libraries;;
+ esac
}
check_factor_exists() {
- if [[ -d "factor" ]] ; then
- echo "A directory called 'factor' already exists."
- echo "Rename or delete it and try again."
- exit 4
- fi
+ if [[ -d "factor" ]] ; then
+ echo "A directory called 'factor' already exists."
+ echo "Rename or delete it and try again."
+ exit 4
+ fi
}
find_os() {
- echo "Finding OS..."
- uname_s=`uname -s`
- check_ret uname
- case $uname_s in
- CYGWIN_NT-5.2-WOW64) OS=winnt;;
- *CYGWIN_NT*) OS=winnt;;
- *CYGWIN*) OS=winnt;;
- *darwin*) OS=macosx;;
- *Darwin*) OS=macosx;;
- *linux*) OS=linux;;
- *Linux*) OS=linux;;
- *NetBSD*) OS=netbsd;;
- esac
+ echo "Finding OS..."
+ uname_s=`uname -s`
+ check_ret uname
+ case $uname_s in
+ CYGWIN_NT-5.2-WOW64) OS=winnt;;
+ *CYGWIN_NT*) OS=winnt;;
+ *CYGWIN*) OS=winnt;;
+ *darwin*) OS=macosx;;
+ *Darwin*) OS=macosx;;
+ *linux*) OS=linux;;
+ *Linux*) OS=linux;;
+ *NetBSD*) OS=netbsd;;
+ *FreeBSD*) OS=freebsd;;
+ *OpenBSD*) OS=openbsd;;
+ *DragonFly*) OS=dragonflybsd;;
+ esac
}
find_architecture() {
- echo "Finding ARCH..."
- uname_m=`uname -m`
- check_ret uname
- case $uname_m in
- i386) ARCH=x86;;
- i686) ARCH=x86;;
- *86) ARCH=x86;;
- *86_64) ARCH=x86;;
- "Power Macintosh") ARCH=ppc;;
- esac
+ echo "Finding ARCH..."
+ uname_m=`uname -m`
+ check_ret uname
+ case $uname_m in
+ i386) ARCH=x86;;
+ i686) ARCH=x86;;
+ amd64) ARCH=x86;;
+ *86) ARCH=x86;;
+ *86_64) ARCH=x86;;
+ "Power Macintosh") ARCH=ppc;;
+ esac
}
write_test_program() {
- echo "#include <stdio.h>" > $C_WORD.c
- echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+ echo "#include <stdio.h>" > $C_WORD.c
+ echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
}
find_word_size() {
- echo "Finding WORD..."
- C_WORD=factor-word-size
- write_test_program
- gcc -o $C_WORD $C_WORD.c
- WORD=$(./$C_WORD)
- check_ret $C_WORD
- rm -f $C_WORD*
+ echo "Finding WORD..."
+ C_WORD=factor-word-size
+ write_test_program
+ gcc -o $C_WORD $C_WORD.c
+ WORD=$(./$C_WORD)
+ check_ret $C_WORD
+ rm -f $C_WORD*
}
set_factor_binary() {
- case $OS in
- winnt) FACTOR_BINARY=factor-nt;;
- macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
- *) FACTOR_BINARY=factor;;
- esac
+ case $OS in
+ # winnt) FACTOR_BINARY=factor-nt;;
+ # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
+ *) FACTOR_BINARY=factor;;
+ esac
}
echo_build_info() {
- echo OS=$OS
- echo ARCH=$ARCH
- echo WORD=$WORD
- echo FACTOR_BINARY=$FACTOR_BINARY
- echo MAKE_TARGET=$MAKE_TARGET
- echo BOOT_IMAGE=$BOOT_IMAGE
- echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
- echo GIT_PROTOCOL=$GIT_PROTOCOL
- echo GIT_URL=$GIT_URL
+ echo OS=$OS
+ echo ARCH=$ARCH
+ echo WORD=$WORD
+ echo FACTOR_BINARY=$FACTOR_BINARY
+ echo MAKE_TARGET=$MAKE_TARGET
+ echo BOOT_IMAGE=$BOOT_IMAGE
+ echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
+ echo GIT_PROTOCOL=$GIT_PROTOCOL
+ echo GIT_URL=$GIT_URL
+ echo DOWNLOADER=$DOWNLOADER
+ echo CC=$CC
+ echo MAKE=$MAKE
}
set_build_info() {
- if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
- echo "OS: $OS"
- echo "ARCH: $ARCH"
- echo "WORD: $WORD"
- echo "OS, ARCH, or WORD is empty. Please report this"
- exit 5
- fi
-
- MAKE_TARGET=$OS-$ARCH-$WORD
- MAKE_IMAGE_TARGET=$ARCH.$WORD
- BOOT_IMAGE=boot.$ARCH.$WORD.image
- if [[ $OS == macosx && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=$OS-$ARCH
- MAKE_TARGET=$OS-$ARCH
- BOOT_IMAGE=boot.macosx-ppc.image
- fi
- if [[ $OS == linux && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=$OS-$ARCH
- MAKE_TARGET=$OS-$ARCH
- BOOT_IMAGE=boot.linux-ppc.image
- fi
+ if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
+ echo "OS: $OS"
+ echo "ARCH: $ARCH"
+ echo "WORD: $WORD"
+ echo "OS, ARCH, or WORD is empty. Please report this"
+ exit 5
+ fi
+
+ MAKE_TARGET=$OS-$ARCH-$WORD
+ MAKE_IMAGE_TARGET=$ARCH.$WORD
+ BOOT_IMAGE=boot.$ARCH.$WORD.image
+ if [[ $OS == macosx && $ARCH == ppc ]] ; then
+ MAKE_IMAGE_TARGET=$OS-$ARCH
+ MAKE_TARGET=$OS-$ARCH
+ BOOT_IMAGE=boot.macosx-ppc.image
+ fi
+ if [[ $OS == linux && $ARCH == ppc ]] ; then
+ MAKE_IMAGE_TARGET=$OS-$ARCH
+ MAKE_TARGET=$OS-$ARCH
+ BOOT_IMAGE=boot.linux-ppc.image
+ fi
}
find_build_info() {
- find_os
- find_architecture
- find_word_size
- set_factor_binary
- set_build_info
- echo_build_info
+ find_os
+ find_architecture
+ find_word_size
+ set_factor_binary
+ set_build_info
+ set_downloader
+ set_gcc
+ set_make
+ echo_build_info
}
invoke_git() {
- git $*
- check_ret git
+ git $*
+ check_ret git
}
git_clone() {
- echo "Downloading the git repository from factorcode.org..."
- invoke_git clone $GIT_URL
+ echo "Downloading the git repository from factorcode.org..."
+ invoke_git clone $GIT_URL
}
git_pull_factorcode() {
- echo "Updating the git repository from factorcode.org..."
- invoke_git pull $GIT_URL master
+ echo "Updating the git repository from factorcode.org..."
+ invoke_git pull $GIT_URL master
}
cd_factor() {
- cd factor
- check_ret cd
+ cd factor
+ check_ret cd
}
invoke_make() {
- case $OS in
- netbsd) make='gmake';;
- *) make='make';;
- esac
- $make $*
- check_ret $make
+ $MAKE $*
+ check_ret $MAKE
}
make_clean() {
- invoke_make clean
+ invoke_make clean
}
make_factor() {
- invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
+ invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
}
update_boot_images() {
- echo "Deleting old images..."
- rm checksums.txt* > /dev/null 2>&1
- rm $BOOT_IMAGE.* > /dev/null 2>&1
- rm staging.*.image > /dev/null 2>&1
- if [[ -f $BOOT_IMAGE ]] ; then
- get_url http://factorcode.org/images/latest/checksums.txt
- factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
- set_md5sum
- disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
- echo "Factorcode md5: $factorcode_md5";
- echo "Disk md5: $disk_md5";
- if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
- echo "Your disk boot image matches the one on factorcode.org."
- else
- rm $BOOT_IMAGE > /dev/null 2>&1
- get_boot_image;
- fi
- else
- get_boot_image
- fi
+ echo "Deleting old images..."
+ rm checksums.txt* > /dev/null 2>&1
+ rm $BOOT_IMAGE.* > /dev/null 2>&1
+ rm staging.*.image > /dev/null 2>&1
+ if [[ -f $BOOT_IMAGE ]] ; then
+ get_url http://factorcode.org/images/latest/checksums.txt
+ factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
+ set_md5sum
+ disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
+ echo "Factorcode md5: $factorcode_md5";
+ echo "Disk md5: $disk_md5";
+ if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
+ echo "Your disk boot image matches the one on factorcode.org."
+ else
+ rm $BOOT_IMAGE > /dev/null 2>&1
+ get_boot_image;
+ fi
+ else
+ get_boot_image
+ fi
}
get_boot_image() {
- echo "Downloading boot image $BOOT_IMAGE."
- get_url http://factorcode.org/images/latest/$BOOT_IMAGE
+ echo "Downloading boot image $BOOT_IMAGE."
+ get_url http://factorcode.org/images/latest/$BOOT_IMAGE
}
get_url() {
- if [[ $DOWNLOAD -eq "" ]] ; then
- set_downloader;
- fi
- echo $DOWNLOAD $1 ;
- $DOWNLOAD $1
- check_ret $DOWNLOAD
+ if [[ $DOWNLOADER -eq "" ]] ; then
+ set_downloader;
+ fi
+ echo $DOWNLOADER $1 ;
+ $DOWNLOADER $1
+ check_ret $DOWNLOADER
}
maybe_download_dlls() {
- if [[ $OS == winnt ]] ; then
- get_url http://factorcode.org/dlls/freetype6.dll
- get_url http://factorcode.org/dlls/zlib1.dll
- get_url http://factorcode.org/dlls/OpenAL32.dll
- get_url http://factorcode.org/dlls/alut.dll
- get_url http://factorcode.org/dlls/ogg.dll
- get_url http://factorcode.org/dlls/theora.dll
- get_url http://factorcode.org/dlls/vorbis.dll
- get_url http://factorcode.org/dlls/sqlite3.dll
- chmod 777 *.dll
- check_ret chmod
- fi
+ if [[ $OS == winnt ]] ; then
+ get_url http://factorcode.org/dlls/freetype6.dll
+ get_url http://factorcode.org/dlls/zlib1.dll
+ get_url http://factorcode.org/dlls/OpenAL32.dll
+ get_url http://factorcode.org/dlls/alut.dll
+ get_url http://factorcode.org/dlls/ogg.dll
+ get_url http://factorcode.org/dlls/theora.dll
+ get_url http://factorcode.org/dlls/vorbis.dll
+ get_url http://factorcode.org/dlls/sqlite3.dll
+ chmod 777 *.dll
+ check_ret chmod
+ fi
}
get_config_info() {
- find_build_info
- check_installed_programs
- check_libraries
+ find_build_info
+ check_installed_programs
+ check_libraries
}
bootstrap() {
- ./$FACTOR_BINARY -i=$BOOT_IMAGE
+ ./$FACTOR_BINARY -i=$BOOT_IMAGE
}
install() {
- check_factor_exists
- get_config_info
- git_clone
- cd_factor
- make_factor
- get_boot_image
- maybe_download_dlls
- bootstrap
+ check_factor_exists
+ get_config_info
+ git_clone
+ cd_factor
+ make_factor
+ get_boot_image
+ maybe_download_dlls
+ bootstrap
}
update() {
- get_config_info
- git_pull_factorcode
- make_clean
- make_factor
+ get_config_info
+ git_pull_factorcode
+ make_clean
+ make_factor
}
update_bootstrap() {
- update_boot_images
- bootstrap
+ update_boot_images
+ bootstrap
}
refresh_image() {
- ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
- check_ret factor
+ ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
+ check_ret factor
}
make_boot_image() {
- ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
- check_ret factor
+ ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
+ check_ret factor
+
+}
+install_build_system_apt() {
+ ensure_program_installed yes
+ yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ check_ret sudo
}
-install_libraries() {
- yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
- check_ret sudo
+install_build_system_port() {
+ test_program_installed git
+ if [[ $? -ne 1 ]] ; then
+ ensure_program_installed yes
+ echo "git not found."
+ echo "This script requires either git-core or port."
+ echo "If it fails, install git-core or port and try again."
+ ensure_program_installed port
+ echo "Installing git-core with port...this will take awhile."
+ yes | sudo port install git-core
+ fi
}
usage() {
- echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|net-bootstrap"
- echo "If you are behind a firewall, invoke as:"
- echo "env GIT_PROTOCOL=http $0 <command>"
+ echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap"
+ echo "If you are behind a firewall, invoke as:"
+ echo "env GIT_PROTOCOL=http $0 <command>"
}
case "$1" in
- install) install ;;
- install-x11) install_libraries; install ;;
- self-update) update; make_boot_image; bootstrap;;
- quick-update) update; refresh_image ;;
- update) update; update_bootstrap ;;
- bootstrap) get_config_info; bootstrap ;;
- net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
- *) usage ;;
+ install) install ;;
+ install-x11) install_build_system_apt; install ;;
+ install-macosx) install_build_system_port; install ;;
+ self-update) update; make_boot_image; bootstrap;;
+ quick-update) update; refresh_image ;;
+ update) update; update_bootstrap ;;
+ bootstrap) get_config_info; bootstrap ;;
+ net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
+ *) usage ;;
esac
+++ /dev/null
-source misc/version.sh
-
-TARGET=$1
-
-if [ "$1" = "x86" ]; then
- CPU="x86.32"
- TARGET=macosx-x86-32
-else
- CPU="macosx-ppc"
- TARGET=macosx-ppc
-fi
-
-BOOT_IMAGE=boot.$CPU.image
-wget http://factorcode.org/images/$VERSION/$BOOT_IMAGE
-
-make $TARGET
-Factor.app/Contents/MacOS/factor -i=$BOOT_IMAGE -no-user-init
-
-DISK_IMAGE_DIR=Factor-$VERSION
-DISK_IMAGE=Factor-$VERSION-$TARGET.dmg
-
-rm -f $DISK_IMAGE
-rm -rf $DISK_IMAGE_DIR
-mkdir $DISK_IMAGE_DIR
-mkdir -p $DISK_IMAGE_DIR/Factor/
-cp -R Factor.app $DISK_IMAGE_DIR/Factor/Factor.app
-chmod +x cp_dir
-cp factor.image license.txt README.txt $DISK_IMAGE_DIR/Factor/
-find core extra fonts misc unmaintained -type f \
- -exec ./cp_dir {} $DISK_IMAGE_DIR/Factor/{} \;
-hdiutil create -srcfolder "$DISK_IMAGE_DIR" -fs HFS+ \
- -volname "$DISK_IMAGE_DIR" "$DISK_IMAGE"
-
-ssh linode mkdir -p w/downloads/$VERSION/
-scp $DISK_IMAGE linode:w/downloads/$VERSION/
+++ /dev/null
-source misc/version.sh
-rm -rf .git .gitignore
-cd ..
-tar cfz Factor-$VERSION.tar.gz factor/
-
-ssh linode mkdir -p w/downloads/$VERSION/
-scp Factor-$VERSION.tar.gz linode:w/downloads/$VERSION/
--- /dev/null
+#!/bin/bash
+
+if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
+then
+ echo macosx-ppc
+elif [ `uname -s` = Darwin ]
+then
+ echo macosx-x86-`./misc/wordsize`
+elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
+then
+ echo linux-x86-32
+elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
+then
+ echo linux-x86-64
+elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
+then
+ echo winnt-x86-`./misc/wordsize`
+else
+ echo help
+fi
\ No newline at end of file
+++ /dev/null
-source misc/version.sh
-
-CPU=$1
-
-if [ "$CPU" = "x86" ]; then
- FLAGS="-no-sse2"
-fi
-
-make windows-nt-x86-32
-
-wget http://factorcode.org/dlls/freetype6.dll
-wget http://factorcode.org/dlls/zlib1.dll
-wget http://factorcode.org/images/$VERSION/boot.x86.32.image
-
-CMD="./factor-nt -i=boot.x86.32.image -no-user-init $FLAGS"
-echo $CMD
-$CMD
-rm -rf .git/ .gitignore
-rm -rf Factor.app/
-rm -rf vm/
-rm -f Makefile
-rm -f cp_dir
-rm -f boot.*.image
-
-FILE=Factor-$VERSION-win32-$CPU.zip
-
-cd ..
-zip -r $FILE Factor/
-
-ssh linode mkdir -p w/downloads/$VERSION/
-scp $FILE linode:w/downloads/$VERSION/
--- /dev/null
+
+#include <stdio.h>
+
+int main ()
+{
+ printf("%d", 8*sizeof(void*));
+ return 0;
+}
--- /dev/null
+USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
+IN: temporary
+
+[
+T{
+ assoc-heap
+ f
+ H{ { 2 1 } }
+ T{ min-heap T{ heap f V{ { 1 2 } } } }
+}
+] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push ] unit-test
+
+[
+T{
+ assoc-heap
+ f
+ H{ { 1 0 } { 2 1 } }
+ T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
+}
+] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push 0 1 pick heap-push ] unit-test
+
+[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ]
+[
+ H{ } clone <assoc-min-heap>
+ 1 2 pick heap-push 0 1 pick heap-push
+ dup heap-pop 2drop dup heap-pop 2drop
+] unit-test
+
+
+[ 0 1 ] [
+T{
+ assoc-heap
+ f
+ H{ { 1 0 } { 2 1 } }
+ T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
+} heap-pop
+] unit-test
+
+[ 1 2 ] [
+T{
+ assoc-heap
+ f
+ H{ { 1 0 } { 2 1 } }
+ T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
+} heap-pop
+] unit-test
+
+[
+T{
+ assoc-heap
+ f
+ H{ { 1 2 } { 3 4 } }
+ T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
+}
+] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test
--- /dev/null
+USING: assocs heaps kernel sequences ;
+IN: assoc-heaps
+
+TUPLE: assoc-heap assoc heap ;
+
+INSTANCE: assoc-heap assoc
+INSTANCE: assoc-heap priority-queue
+
+C: <assoc-heap> assoc-heap
+
+: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
+: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
+
+M: assoc-heap at* ( key assoc-heap -- value ? )
+ assoc-heap-assoc at* ;
+
+M: assoc-heap assoc-size ( assoc-heap -- n )
+ assoc-heap-assoc assoc-size ;
+
+TUPLE: assoc-heap-key-exists ;
+
+: check-key-exists ( key assoc-heap -- )
+ assoc-heap-assoc key?
+ [ \ assoc-heap-key-exists construct-empty throw ] when ;
+
+M: assoc-heap set-at ( value key assoc-heap -- )
+ [ check-key-exists ] 2keep
+ [ assoc-heap-assoc set-at ] 3keep
+ assoc-heap-heap swapd heap-push ;
+
+M: assoc-heap heap-empty? ( assoc-heap -- ? )
+ assoc-heap-assoc assoc-empty? ;
+
+M: assoc-heap heap-length ( assoc-heap -- n )
+ assoc-heap-assoc assoc-size ;
+
+M: assoc-heap heap-peek ( assoc-heap -- value key )
+ assoc-heap-heap heap-peek ;
+
+M: assoc-heap heap-push ( value key assoc-heap -- )
+ set-at ;
+
+M: assoc-heap heap-pop ( assoc-heap -- value key )
+ dup assoc-heap-heap heap-pop swap
+ rot dupd assoc-heap-assoc delete-at ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Priority search queues
USING: cryptlib.libcl cryptlib prettyprint kernel alien sequences libc math
-tools.test io io.files continuations alien.c-types splitting generic.math ;
+tools.test io io.files continuations alien.c-types splitting generic.math
+io.encodings.binary ;
"=========================================================" print
"Envelope/de-envelop test..." print
! envelope
CRYPT_FORMAT_CRYPTLIB [
"extra/cryptlib/test/large_data.txt" resource-path
- file-contents set-pop-buffer
+ binary file-contents set-pop-buffer
envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
get-pop-buffer alien>char-string length 10000 + set-attribute
envelope-handle CRYPT_ENVINFO_DATASIZE
CRYPT_FORMAT_CRYPTLIB [
envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string
"extra/cryptlib/test/large_data.txt" resource-path
- file-contents set-pop-buffer
+ binary file-contents set-pop-buffer
envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
get-pop-buffer alien>char-string length 10000 + set-attribute
envelope-handle CRYPT_ENVINFO_DATASIZE
+++ /dev/null
-! Copyright (C) 2006 Matthew Willis. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: parser-combinators kernel sequences lazy-lists
-namespaces strings arrays math io errors ;
-
-IN: farkup
-LAZY: <(*)> ( parser -- parser )
- ! kleene star matching, but take shortest match first
- { } succeed swap dup <(*)> <&:> <|> ;
-
-LAZY: <(+)> ( parser -- parser )
- dup <(*)> <&:> ;
-
-LAZY: 'consume1' ( -- parser ) [ CHAR: \n = not ] satisfy ;
-
-LAZY: '\n' ( -- parser ) [ CHAR: \n = ] satisfy ;
-
-: open-tag ( text -- tag ) [ CHAR: < , , CHAR: > , ] { } make ;
-
-: close-tag ( text -- tag ) [ "</" , , CHAR: > , ] { } make ;
-
-: both-tags ( text -- open-tag close-tag ) dup open-tag swap close-tag ;
-
-DEFER: 'inline'
-LAZY: simple-tag ( start end html -- parser )
- both-tags [ \ drop , , ] [ ] make rot token swap <@ >r
- [ \ drop , , ] [ ] make swap token swap <@
- 'inline' <(+)> <&> r> <&> ;
-
-LAZY: prefix-tag ( pre html -- parser )
- >r 'inline' <!*> >r token r> &>
- r> both-tags [ swap , \ swap , , \ 3array , ] [ ] make <@ ;
-
-LAZY: 'strong' ( -- parser ) "*" "*" "strong" simple-tag ;
-
-LAZY: 'link' ( -- parser )
- "[" token [ drop "<a href=\"" ] <@ 'consume1' <(+)> <&>
- "," token [ drop "\">" ] <@ <&>
- 'consume1' <(+)> <&> "]" token [ drop "</a>" ] <@ <&> ;
-
-LAZY: 'inline' ( -- parser )
- 'strong'
- 'link' <|>
- 'consume1' <|> ;
-
-LAZY: 'h1' ( -- parser ) "=" "h1" prefix-tag ;
-LAZY: 'h2' ( -- parser ) "==" "h2" prefix-tag ;
-LAZY: 'h3' ( -- parser ) "===" "h3" prefix-tag ;
-LAZY: 'h4' ( -- parser ) "====" "h4" prefix-tag ;
-LAZY: 'h5' ( -- parser ) "=====" "h5" prefix-tag ;
-LAZY: 'h6' ( -- parser ) "======" "h6" prefix-tag ;
-
-LAZY: 'blockquote' ( -- parser ) "[\"" "\"]" "blockquote" simple-tag ;
-
-LAZY: 'block' ( -- parser )
- 'h6' 'h5' 'h4' 'h3' 'h2' 'h1' <|> <|> <|> <|> <|>
- 'blockquote' <|>
- 'inline' <!+> [ "<p>" swap "</p>" 3array ] <@ <|> ;
-
-LAZY: 'farkup' ( -- parser )
- 'block' '\n' <!+> 'block' <&> <!*> <&> ;
-
-GENERIC: tree-write ( object -- )
-
-PREDICATE: sequence non-leaf dup number? swap string? or not ;
-M: non-leaf tree-write ( sequence -- ) [ tree-write ] each ;
-
-M: string tree-write ( string -- ) write ;
-
-M: number tree-write ( char -- ) write1 ;
-
-: farkup ( str -- html )
- 'farkup' parse dup nil?
- [ error ] [ car parse-result-parsed [ tree-write ] with-string-writer ] if ;
-
-! useful debugging code below
-
-: farkup-backtracks ( wiki -- backtracks )
- ! for debugging and optimization only
- 'farkup' parse list>array length ;
-
-: farkup-parsed ( wiki -- all-parses )
- ! for debugging and optimization only
- 'farkup' parse list>array
- [ parse-result-parsed [ tree-write ] with-string-writer ] map ;
\ No newline at end of file
+++ /dev/null
-Blocks
-------
-Must be terminated by \n or end of input.
-
-foo => <p>foo</p>
-=foo => <h1>foo</h1>
-==foo => <h2>foo</h2>
- ...
-
-["foo"] => <blockquote>foo</blockquote>
-
-Inlines
--------
-Can appear anywhere within a block
-
-*foo* => <strong>foo</strong>
-[url,text] => <a href="url">text</a>
-
-
-
+++ /dev/null
-! Copyright (C) 2006 Matthew Willis. All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Adapted from Wiky (http://goessner.net/articles/wiky/)
-!
-REQUIRES: libs/lazy-lists libs/parser-combinators ;
-
-PROVIDE: libs/farkup
-{ +files+ {
- "farkup.factor"
- "farkup.facts"
-} } ;
\ No newline at end of file
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel gap-buffer.cursortree tools.test sequences trees arrays strings ;
-
-[ t ] [ "this is a test string" <cursortree> 0 <left-cursor> at-beginning? ] unit-test
-[ t ] [ "this is a test string" <cursortree> dup length <left-cursor> at-end? ] unit-test
-[ 3 ] [ "this is a test string" <cursortree> 3 <left-cursor> cursor-pos ] unit-test
-[ CHAR: i ] [ "this is a test string" <cursortree> 3 <left-cursor> element< ] unit-test
-[ CHAR: s ] [ "this is a test string" <cursortree> 3 <left-cursor> element> ] unit-test
-[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> CHAR: a over set-element< CHAR: t over set-element> cursor-tree "that is a test string" sequence= ] unit-test
-[ t ] [ "this is a test string" <cursortree> 3 <left-cursor> 8 over set-cursor-pos dup 1array swap cursor-tree cursortree-cursors tree-values sequence= ] unit-test
-[ "this is no longer a test string" ] [ "this is a test string" <cursortree> 8 <left-cursor> "no longer " over insert cursor-tree >string ] unit-test
-[ "refactor" ] [ "factor" <cursortree> 0 <left-cursor> CHAR: e over insert CHAR: r over insert cursor-tree >string ] unit-test
-[ "refactor" ] [ "factor" <cursortree> 0 <right-cursor> CHAR: r over insert CHAR: e over insert cursor-tree >string ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 5 <right-cursor> dup delete> dup delete> dup delete> dup cursor-tree >string swap cursor-pos ] unit-test
-[ "this a test string" 5 ] [ "this is a test string" <cursortree> 8 <right-cursor> dup delete< dup delete< dup delete< dup cursor-tree >string swap cursor-pos ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel gap-buffer generic trees trees.avl-tree math sequences quotations ;
-IN: gap-buffer.cursortree
-
-TUPLE: cursortree cursors ;
-
-: <cursortree> ( seq -- cursortree )
- <gb> cursortree construct-empty tuck set-delegate <avl-tree>
- over set-cursortree-cursors ;
-
-GENERIC: cursortree-gb ( cursortree -- gb )
-M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
-GENERIC: set-cursortree-gb ( gb cursortree -- )
-M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
-
-TUPLE: cursor i tree ;
-TUPLE: left-cursor ;
-TUPLE: right-cursor ;
-
-: cursor-index ( cursor -- i ) cursor-i ; inline
-
-: add-cursor ( cursortree cursor -- ) dup cursor-index rot tree-insert ;
-
-: remove-cursor ( cursortree cursor -- )
- dup [ eq? ] curry swap cursor-index rot cursortree-cursors tree-delete-if ;
-
-: set-cursor-index ( index cursor -- )
- dup cursor-tree over remove-cursor tuck set-cursor-i
- dup cursor-tree cursortree-cursors swap add-cursor ;
-
-GENERIC: cursor-pos ( cursor -- n )
-GENERIC: set-cursor-pos ( n cursor -- )
-M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
-M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
-M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
-M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
-
-: <cursor> ( cursortree -- cursor )
- cursor construct-empty tuck set-cursor-tree ;
-
-: make-cursor ( cursortree pos cursor -- cursor )
- >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
-
-: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor construct-empty make-cursor ;
-
-: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor construct-empty make-cursor ;
-
-: cursor-positions ( cursortree -- seq )
- cursortree-cursors tree-values [ cursor-pos ] map ;
-
-M: cursortree move-gap ( n cursortree -- )
- #! Get the position of each cursor before the move, then re-set the
- #! position afterwards. This will update any changed cursor indices.
- dup cursor-positions >r tuck cursortree-gb move-gap
- cursortree-cursors tree-values r> swap [ set-cursor-pos ] 2each ;
-
-: element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
-: element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
-
-: at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
-: at-end? ( cursor -- ? ) element@> length = ;
-
-: insert ( obj cursor -- ) element@> insert* ;
-
-: element< ( cursor -- elem ) element@< nth ;
-: element> ( cursor -- elem ) element@> nth ;
-
-: set-element< ( elem cursor -- ) element@< set-nth ;
-: set-element> ( elem cursor -- ) element@> set-nth ;
-
-GENERIC: fix-cursor ( cursortree cursor -- )
-
-M: left-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-start 1- r> set-cursor-index ;
-
-M: right-cursor fix-cursor ( cursortree cursor -- )
- >r gb-gap-end r> set-cursor-index ;
-
-: fix-cursors ( old-gap-end cursortree -- )
- tuck cursortree-cursors tree-get-all [ fix-cursor ] curry* each ;
-
-M: cursortree delete* ( pos cursortree -- )
- tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
-
-: delete< ( cursor -- ) element@< delete* ;
-: delete> ( cursor -- ) element@> delete* ;
-
+++ /dev/null
-Collection of 'cursors' representing locations in a gap buffer
+++ /dev/null
-USING: kernel sequences tools.test gap-buffer strings math ;
-
-! test copy-elements
-[ { 0 3 4 3 4 5 } ] [ { 0 1 2 3 4 5 } dup >r -2 3 5 r> copy-elements ] unit-test
-[ { 0 1 2 1 2 5 } ] [ { 0 1 2 3 4 5 } dup >r 2 2 0 r> copy-elements ] unit-test
-[ "01234567856" ] [ "01234567890" dup >r 4 6 4 r> copy-elements ] unit-test
-
-! test sequence protocol (like, length, nth, set-nth)
-[ "gap buffers are cool" ] [ "gap buffers are cool" <gb> "" like ] unit-test
-
-! test move-gap-back-inside
-[ t f ] [ 5 "0123456" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "0123456" ] [ "0123456" <gb> 5 over move-gap >string ] unit-test
-! test move-gap-forward-inside
-[ t ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 swap move-gap-forward-inside? 2nip ] unit-test
-[ "I once ate a spaniel" ] [ "I once ate a spaniel" <gb> 15 over move-gap 17 over move-gap >string ] unit-test
-! test move-gap-back-around
-[ f f ] [ 2 "terriers are ok too" <gb> move-gap-forward? >r move-gap-back-inside? 2nip r> ] unit-test
-[ "terriers are ok too" ] [ "terriers are ok too" <gb> 2 over move-gap >string ] unit-test
-! test move-gap-forward-around
-[ f t ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over position>index swap move-gap-forward? >r move-gap-forward-inside? 2nip r> ] unit-test
-[ "god is nam's best friend" ] [ "god is nam's best friend" <gb> 2 over move-gap 22 over move-gap >string ] unit-test
-
-! test changing buffer contents
-[ "factory" ] [ "factor" <gb> CHAR: y 6 pick insert* >string ] unit-test
-! test inserting multiple elements in different places. buffer should grow
-[ "refractory" ] [ "factor" <gb> CHAR: y 6 pick insert* "re" 0 pick insert* CHAR: r 3 pick insert* >string ] unit-test
-! test deleting elements. buffer should shrink
-[ "for" ] [ "factor" <gb> 3 [ 1 over delete* ] times >string ] unit-test
-! more testing of nth and set-nth
-[ "raptor" ] [ "factor" <gb> CHAR: p 2 pick set-nth 5 over nth 0 pick set-nth >string ] unit-test
-
-! test stack/queue operations
-[ "slaughter" ] [ "laughter" <gb> CHAR: s over push-start >string ] unit-test
-[ "pantonio" ] [ "pant" <gb> "onio" over push-end >string ] unit-test
-[ CHAR: f "actor" ] [ "factor" <gb> dup pop-start swap >string ] unit-test
-[ CHAR: s "pant" ] [ "pants" <gb> dup pop-end swap >string ] unit-test
-[ "end this is the " ] [ "this is the end " <gb> 4 over rotate >string ] unit-test
-[ "your jedi training is finished " ] [ "finished your jedi training is " <gb> -9 over rotate >string ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman All Rights Reserved.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! gap buffer -- largely influenced by Strandh and Villeneuve's Flexichain
-! for a good introduction see:
-! http://p-cos.net/lisp-ecoop/submissions/StrandhVilleneuveMoore.pdf
-USING: kernel arrays sequences sequences.private circular math generic ;
-IN: gap-buffer
-
-! gap-start -- the first element of the gap
-! gap-end -- the first element after the gap
-! expand-factor -- should be > 1
-! min-size -- < 5 is not sensible
-
-TUPLE: gb
- gap-start
- gap-end
- expand-factor
- min-size ;
-
-GENERIC: gb-seq ( gb -- seq )
-GENERIC: set-gb-seq ( seq gb -- )
-M: gb gb-seq ( gb -- seq ) delegate ;
-M: gb set-gb-seq ( seq gb -- ) set-delegate ;
-
-: required-space ( n gb -- n )
- tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
-
-: <gb> ( seq -- gb )
- gb construct-empty
- 5 over set-gb-min-size
- 1.5 over set-gb-expand-factor
- [ >r length r> set-gb-gap-start ] 2keep
- [ swap length over required-space swap set-gb-gap-end ] 2keep
- [
- over length over required-space rot { } like resize-array <circular> swap set-gb-seq
- ] keep ;
-
-M: gb like ( seq gb -- seq ) drop <gb> ;
-
-: gap-length ( gb -- n ) [ gb-gap-end ] keep gb-gap-start - ;
-
-: buffer-length ( gb -- n ) gb-seq length ;
-
-M: gb length ( gb -- n ) [ buffer-length ] keep gap-length - ;
-
-: position>index ( pos gb -- i )
- 2dup gb-gap-start >= [
- gap-length +
- ] [ drop ] if ;
-
-: index>position ( i gb -- pos )
- 2dup gb-gap-end >= [
- gap-length -
- ] [ drop ] if ;
-
-M: gb virtual@ ( n gb -- n seq ) [ position>index ] keep gb-seq ;
-
-M: gb nth ( n gb -- elt ) bounds-check virtual@ nth-unsafe ;
-
-M: gb nth-unsafe ( n gb -- elt ) virtual@ nth-unsafe ;
-
-M: gb set-nth ( elt n seq -- ) bounds-check virtual@ set-nth-unsafe ;
-
-M: gb set-nth-unsafe ( elt n seq -- ) virtual@ set-nth-unsafe ;
-
-M: gb virtual-seq gb-seq ;
-
-INSTANCE: gb virtual-sequence
-
-! ------------- moving the gap -------------------------------
-
-: (copy-element) ( to start seq -- ) tuck nth -rot set-nth ;
-
-: copy-element ( dst start seq -- ) >r [ + ] keep r> (copy-element) ;
-
-: copy-elements-back ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1+ r> r> 1- copy-elements-back
- ] [ 3drop drop ] if ;
-
-: copy-elements-forward ( dst start seq n -- )
- dup 0 > [
- >r [ copy-element ] 3keep >r 1- r> r> 1- copy-elements-forward
- ] [ 3drop drop ] if ;
-
-: copy-elements ( dst start end seq -- )
- pick pick > [
- >r dupd - r> swap copy-elements-forward
- ] [
- >r over - r> swap copy-elements-back
- ] if ;
-
-! the gap can be moved either forward or back. Moving the gap 'inside' means
-! moving elements across the gap. Moving the gap 'around' means changing the
-! start of the circular buffer to avoid moving as many elements.
-
-! We decide which method (inside or around) to pick based on the number of
-! elements that will need to be moved. We always try to move as few elements as
-! possible.
-
-: move-gap? ( i gb -- i gb ? ) 2dup gb-gap-end = not ;
-
-: move-gap-forward? ( i gb -- i gb ? ) 2dup gb-gap-start >= ;
-
-: move-gap-back-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-start swap 2 * - ] keep [ buffer-length ] keep gb-gap-end - <= ;
-
-: move-gap-forward-inside? ( i gb -- i gb ? )
- #! is it cheaper to move the gap inside than around?
- 2dup [ gb-gap-end >r 2 * r> - ] keep [ gb-gap-start ] keep buffer-length + <= ;
-
-: move-gap-forward-inside ( i gb -- )
- [ dup gap-length neg swap gb-gap-end rot ] keep gb-seq copy-elements ;
-
-: move-gap-back-inside ( i gb -- )
- [ dup gap-length swap gb-gap-start 1- rot 1- ] keep gb-seq copy-elements ;
-
-: move-gap-forward-around ( i gb -- )
- 0 over move-gap-back-inside [
- dup buffer-length [
- swap gap-length - neg swap
- ] keep
- ] keep [
- gb-seq copy-elements
- ] keep dup gap-length swap gb-seq change-circular-start ;
-
-: move-gap-back-around ( i gb -- )
- dup buffer-length over move-gap-forward-inside [
- length swap -1
- ] keep [
- gb-seq copy-elements
- ] keep dup length swap gb-seq change-circular-start ;
-
-: move-gap-forward ( i gb -- )
- move-gap-forward-inside? [
- move-gap-forward-inside
- ] [
- move-gap-forward-around
- ] if ;
-
-: move-gap-back ( i gb -- )
- move-gap-back-inside? [
- move-gap-back-inside
- ] [
- move-gap-back-around
- ] if ;
-
-: (move-gap) ( i gb -- )
- move-gap? [
- move-gap-forward? [
- move-gap-forward
- ] [
- move-gap-back
- ] if
- ] [ 2drop ] if ;
-
-: fix-gap ( n gb -- )
- 2dup [ gap-length + ] keep set-gb-gap-end set-gb-gap-start ;
-
-GENERIC: move-gap ( n gb -- )
-
-M: gb move-gap ( n gb -- ) 2dup [ position>index ] keep (move-gap) fix-gap ;
-
-! ------------ resizing -------------------------------------
-
-: enough-room? ( n gb -- ? )
- #! is there enough room to add 'n' elements to gb?
- tuck length + swap buffer-length <= ;
-
-: set-new-gap-end ( array gb -- )
- [ buffer-length swap length swap - ] keep
- [ gb-gap-end + ] keep set-gb-gap-end ;
-
-: after-gap ( gb -- gb )
- dup gb-seq swap gb-gap-end tail ;
-
-: before-gap ( gb -- gb )
- dup gb-gap-start head ;
-
-: copy-after-gap ( array gb -- )
- #! copy everything after the gap in 'gb' into the end of 'array',
- #! and change 'gb's gap-end to reflect the gap-end in 'array'
- dup after-gap >r 2dup set-new-gap-end gb-gap-end swap r> -rot copy ;
-
-: copy-before-gap ( array gb -- )
- #! copy everything before the gap in 'gb' into the start of 'array'
- before-gap 0 rot copy ; ! gap start doesn't change
-
-: resize-buffer ( gb new-size -- )
- f <array> swap 2dup copy-before-gap 2dup copy-after-gap
- >r <circular> r> set-gb-seq ;
-
-: decrease-buffer-size ( gb -- )
- #! the gap is too big, so resize to something sensible
- dup length over required-space resize-buffer ;
-
-: increase-buffer-size ( n gb -- )
- #! increase the buffer to fit at least 'n' more elements
- tuck length + over required-space resize-buffer ;
-
-: gb-too-big? ( gb -- ? )
- dup buffer-length over gb-min-size > [
- dup length over buffer-length rot gb-expand-factor sq / <
- ] [ drop f ] if ;
-
-: ?decrease ( gb -- )
- dup gb-too-big? [
- decrease-buffer-size
- ] [ drop ] if ;
-
-: ensure-room ( n gb -- )
- #! ensure that ther will be enough room for 'n' more elements
- 2dup enough-room? [ 2drop ] [
- increase-buffer-size
- ] if ;
-
-! ------- editing operations ---------------
-
-GENERIC# insert* 2 ( seq position gb -- )
-
-: prepare-insert ( seq position gb -- seq gb )
- tuck move-gap over length over ensure-room ;
-
-: insert-elements ( seq gb -- )
- dup gb-gap-start swap gb-seq copy ;
-
-: increment-gap-start ( gb n -- )
- over gb-gap-start + swap set-gb-gap-start ;
-
-! generic dispatch identifies numbers as sequences before numbers...
-! M: number insert* ( elem position gb -- ) >r >r 1array r> r> insert* ;
-: number-insert ( num position gb -- ) >r >r 1array r> r> insert* ;
-
-M: sequence insert* ( seq position gb -- )
- pick number? [
- number-insert
- ] [
- prepare-insert [ insert-elements ] 2keep swap length increment-gap-start
- ] if ;
-
-: (delete*) ( gb -- )
- dup gb-gap-end 1+ over set-gb-gap-end ?decrease ;
-
-GENERIC: delete* ( pos gb -- )
-
-M: gb delete* ( position gb -- )
- tuck move-gap (delete*) ;
-
-! -------- stack/queue operations -----------
-
-: push-start ( obj gb -- ) 0 swap insert* ;
-
-: push-end ( obj gb -- ) [ length ] keep insert* ;
-
-: pop-elem ( position gb -- elem ) [ nth ] 2keep delete* ;
-
-: pop-start ( gb -- elem ) 0 swap pop-elem ;
-
-: pop-end ( gb -- elem ) [ length 1- ] keep pop-elem ;
-
-: rotate ( n gb -- )
- dup length 1 > [
- swap dup 0 > [
- [ dup [ pop-end ] keep push-start ]
- ] [
- neg [ dup [ pop-start ] keep push-end ]
- ] if times drop
- ] [ 2drop ] if ;
-
+++ /dev/null
-Gap buffer data structure
+++ /dev/null
-collections sequences
USING: arrays combinators io io.binary io.files io.paths
io.encodings.utf16 kernel math math.parser namespaces sequences
-splitting strings assocs unicode.categories ;
+splitting strings assocs unicode.categories io.encodings.binary ;
IN: id3
read-header read-frames <tag> ;
: supported-version? ( version -- ? )
- [ 3 4 ] member? ;
+ { 3 4 } member? ;
: read-id3v2 ( -- tag/f )
read1 dup supported-version?
[ (read-id3v2) ] [ drop f ] if ;
: id3v2? ( -- ? )
- 3 read "ID3" = ;
+ 3 read "ID3" sequence= ;
: read-tag ( stream -- tag/f )
id3v2? [ read-id3v2 ] [ f ] if ;
: id3v2 ( filename -- tag/f )
- [ read-tag ] with-file-reader ;
+ binary [ read-tag ] with-file-reader ;
: file? ( path -- ? )
stat 3drop not ;
[ mp3? ] subset ;
: id3? ( file -- ? )
- [ id3v2? ] with-file-reader ;
+ binary [ id3v2? ] with-file-reader ;
: id3s ( files -- id3s )
[ id3? ] subset ;
! Copyright (C) 2007 Adam Wendt.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad\r
- namespaces prettyprint sbufs sequences tools.interpreter vars ;\r
+ namespaces prettyprint sbufs sequences tools.interpreter vars\r
+ io.encodings.binary ;\r
IN: mad.api\r
\r
VARS: buffer-start buffer-length output-callback-var ;\r
: make-decoder ( -- decoder )\r
"mad_decoder" malloc-object ;\r
\r
-: malloc-file-contents ( path -- alien )\r
- file-contents >byte-array malloc-byte-array ;\r
-\r
: mad-run ( -- int )\r
make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ;\r
\r
--- /dev/null
+USING: io.backend ;
+
+HOOK: sniff-channel io-backend ( -- channel )
--- /dev/null
+! Copyright (C) 2007 Chris Double. All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Wrap a sniffer in a channel
+USING: kernel channels channels.sniffer.backend
+threads io io.sniffer.backend io.sniffer.bsd
+io.unix.backend ;
+IN: channels.sniffer.bsd
+
+M: unix-io sniff-channel ( -- channel )
+ "/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [
+ [
+ (sniff-channel)
+ ] 3curry spawn drop
+ ] keep ;
+
--- /dev/null
+! Copyright (C) 2007 Chris Double. All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Wrap a sniffer in a channel
+USING: kernel channels io io.backend io.sniffer
+io.sniffer.backend system vocabs.loader ;
+
+: (sniff-channel) ( stream channel -- )
+ 4096 pick stream-read-partial over to (sniff-channel) ;
+
+bsd? [ "channels.sniffer.bsd" require ] when
--- /dev/null
+Doug Coleman
+Elie Chaftari
--- /dev/null
+Doug Coleman
+Elie Chaftari
--- /dev/null
+USING: io.backend kernel system vocabs.loader ;
+IN: io.sniffer.backend
+
+SYMBOL: sniffer-type
+TUPLE: sniffer ;
+HOOK: <sniffer> io-backend ( obj -- sniffer )
--- /dev/null
+Doug Coleman
+Elie Chaftari
--- /dev/null
+! Copyright (C) 2007 Elie Chaftari, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax destructors hexdump io
+io.buffers io.nonblocking io.sockets
+io.unix.backend io.unix.files kernel libc locals math qualified
+sequences io.sniffer.backend ;
+QUALIFIED: unix
+IN: io.sniffer.bsd
+
+M: unix-io destruct-handle ( obj -- ) unix:close ;
+
+C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
+C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;
+
+TUPLE: sniffer-spec path ifname ;
+
+C: <sniffer-spec> sniffer-spec
+
+: IOCPARM_MASK HEX: 1fff ; inline
+: IOCPARM_MAX IOCPARM_MASK 1+ ; inline
+: IOC_VOID HEX: 20000000 ; inline
+: IOC_OUT HEX: 40000000 ; inline
+: IOC_IN HEX: 80000000 ; inline
+: IOC_INOUT IOC_IN IOC_OUT bitor ; inline
+: IOC_DIRMASK HEX: e0000000 ; inline
+
+:: ioc ( inout group num len -- n )
+ group first 8 shift num bitor
+ len IOCPARM_MASK bitand 16 shift bitor
+ inout bitor ;
+
+: io-len ( type -- n )
+ dup zero? [ heap-size ] unless ;
+
+: io ( group num -- n )
+ IOC_VOID -rot 0 io-len ioc ;
+
+: ior ( group num type -- n )
+ IOC_OUT -roll io-len ioc ;
+
+: iow ( group num type -- n )
+ IOC_IN -roll io-len ioc ;
+
+: iowr ( group num type -- n )
+ IOC_INOUT -roll io-len ioc ;
+
+: BIOCGBLEN ( -- n ) "B" 102 "uint" ior ; inline
+: BIOCSETIF ( -- n ) "B" 108 "ifreq" iow ; inline
+: BIOCPROMISC ( -- n ) "B" 105 io ; inline
+: BIOCIMMEDIATE ( -- n ) "B" 112 "uint" iow ; inline
+
+: make-ifreq-props ( ifname -- ifreq )
+ "ifreq" <c-object>
+ 12 <short> 16 0 pad-right over set-ifreq-props
+ swap malloc-char-string dup free-always
+ over set-ifreq-name ;
+
+: make-ioctl-buffer ( fd -- buffer )
+ BIOCGBLEN "char*" <c-object>
+ [ unix:ioctl io-error ] keep
+ *int <buffer> ;
+
+: ioctl-BIOSETIF ( fd ifreq -- )
+ >r BIOCSETIF r> unix:ioctl io-error ;
+
+: ioctl-BIOPROMISC ( fd -- )
+ BIOCPROMISC f unix:ioctl io-error ;
+
+: ioctl-BIOCIMMEDIATE
+ BIOCIMMEDIATE 1 <int> unix:ioctl io-error ;
+
+: ioctl-sniffer-fd ( fd ifname -- )
+ dupd make-ifreq-props ioctl-BIOSETIF
+ dup ioctl-BIOPROMISC
+ ioctl-BIOCIMMEDIATE ;
+
+M: unix-io <sniffer> ( obj -- sniffer )
+ [
+ [
+ sniffer-spec-path
+ open-read
+ dup close-later
+ ] keep
+ dupd sniffer-spec-ifname ioctl-sniffer-fd
+ dup make-ioctl-buffer
+ input-port <port> <line-reader>
+ \ sniffer construct-delegate
+ ] with-destructors ;
+
--- /dev/null
+Doug Coleman
+Elie Chaftari
--- /dev/null
+Doug Coleman
+Elie Chaftari
--- /dev/null
+USING: byte-arrays combinators io io.backend
+io.sockets.headers io.sniffer.backend kernel
+prettyprint sequences ;
+IN: io.sniffer.filter.backend
+
+HOOK: sniffer-loop io-backend ( stream -- )
+HOOK: packet. io-backend ( string -- )
+
+: (packet.) ( string -- )
+ dup 14 head >byte-array
+ "--Ethernet Header--" print
+ dup etherneth.
+ dup etherneth-type {
+ ! HEX: 800 [ ] ! IP
+ ! HEX: 806 [ ] ! ARP
+ [ "Unknown type: " write .h ]
+ } case 2drop ;
--- /dev/null
+Doug Coleman
+Elie Chaftari
--- /dev/null
+USING: alien.c-types hexdump io io.backend io.sockets.headers
+io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
+io.streams.string io.unix.backend math
+sequences system byte-arrays io.sniffer.filter.backend
+io.sniffer.filter.backend io.sniffer.backend ;
+IN: io.sniffer.filter.bsd
+
+! http://www.iana.org/assignments/ethernet-numbers
+
+: bpf-align ( n -- n' )
+ #! Align to next higher word size
+ "long" heap-size align ;
+
+M: unix-io packet. ( string -- )
+ 18 cut swap >byte-array bpfh.
+ (packet.) ;
+
+M: unix-io sniffer-loop ( stream -- )
+ nl nl
+ 4096 over stream-read-partial
+ dup hexdump.
+ packet.
+ sniffer-loop ;
+
+
+! Mac
+: sniff-wired ( -- )
+ "/dev/bpf0" "en0" <sniffer-spec> <sniffer> sniffer-loop ;
+
+! Macbook
+: sniff-wireless ( -- )
+ "/dev/bpf0" "en1" <sniffer-spec> <sniffer> sniffer-loop ;
+
--- /dev/null
+USING: alien.c-types byte-arrays combinators hexdump io
+io.backend io.streams.string io.sockets.headers kernel math
+prettyprint io.sniffer sequences system vocabs.loader
+io.sniffer.filter.backend ;
+IN: io.sniffer.filter
+
+
+bsd? [ "io.sniffer.filter.bsd" require ] when
--- /dev/null
+USING: io.backend kernel system vocabs.loader ;
+IN: io.sniffer
+
+bsd? [ "io.sniffer.bsd" require ] when
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2006 Chris Double. All Rights Reserved.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel furnace fjsc peg namespaces
+ lazy-lists io io.files furnace.validator sequences
+ http.client http.server http.server.responders
+ webapps.file html ;
+IN: webapps.fjsc
+
+: compile ( code -- )
+ #! Compile the factor code as a string, outputting the http
+ #! response containing the javascript.
+ serving-text
+ 'expression' parse parse-result-ast fjsc-compile
+ write flush ;
+
+! The 'compile' action results in an URL that looks like
+! 'responder/fjsc/compile'. It takes one query or post
+! parameter called 'code'. It calls the 'compile' word
+! passing the parameter to it on the stack.
+\ compile {
+ { "code" v-required }
+} define-action
+
+: compile-url ( url -- )
+ #! Compile the factor code at the given url, return the javascript.
+ dup "http:" head? [ "Unable to access remote sites." throw ] when
+ "http://" "host" header-param rot 3append http-get compile "();" write flush ;
+
+\ compile-url {
+ { "url" v-required }
+} define-action
+
+: render-page* ( model body-template head-template -- )
+ [
+ [ render-component ] [ f rot render-component ] html-document
+ ] serve-html ;
+
+: repl ( -- )
+ #! The main 'repl' page.
+ f "repl" "head" render-page* ;
+
+! An action called 'repl'
+\ repl { } define-action
+
+: fjsc-web-app ( -- )
+ ! Create the web app, providing access
+ ! under '/responder/fjsc' which calls the
+ ! 'repl' action.
+ "fjsc" "repl" "extra/webapps/fjsc" web-app
+
+ ! An URL to the javascript resource files used by
+ ! the 'fjsc' responder.
+ "fjsc-resources" [
+ [
+ "extra/fjsc/resources/" resource-path doc-root set
+ file-responder
+ ] with-scope
+ ] add-simple-responder
+
+ ! An URL to the resource files used by
+ ! 'termlib'.
+ "fjsc-repl-resources" [
+ [
+ "extra/webapps/fjsc/resources/" resource-path doc-root set
+ file-responder
+ ] with-scope
+ ] add-simple-responder ;
+
+MAIN: fjsc-web-app
--- /dev/null
+<title>Factor to Javascript REPL</title>\r
+<link rel="stylesheet" type="text/css" href="/responder/fjsc-repl-resources/termlib/term_styles.css"/>\r
+<script type="text/javascript" src="/responder/fjsc-repl-resources/termlib/termlib.js"></script>\r
+<script type="text/javascript" src="/responder/fjsc-resources/jquery.js"></script>\r
+<script type="text/javascript" src="/responder/fjsc-resources/bootstrap.js"></script>\r
+<script type="text/javascript" src="/responder/fjsc-repl-resources/repl.js"></script>\r
+<script type="text/javascript" src="/responder/fjsc/compile-url?url=/responder/fjsc-resources/bootstrap.factor"></script>\r
--- /dev/null
+<table border="0">
+<tr><td valign="top">
+<div id="repl" style="position:relative;"></div>
+<p>More information on the Factor to Javascript compiler can be found at these blog posts:
+<ul>
+<li><a href="http://www.bluishcoder.co.nz/2006/12/compiling-factor-to-javascript.html">Factor to Javascript Compiler</a></li>
+<li><a href="http://www.bluishcoder.co.nz/2006/12/factor-to-javascript-compiler-updates.html">Factor to Javascript Compiler Updates</a></li>
+<li><a href="http://www.bluishcoder.co.nz/2006/12/continuations-added-to-fjsc.html">Continuations added to fjsc</a></li>
+<li><a href="http://www.bluishcoder.co.nz/2006/12/cross-domain-json-with-fjsc.html">Cross Domain JSON with fjsc</a></li>
+<li><a href="http://www.bluishcoder.co.nz/2007/02/factor-to-javascript-compiler-makeover.html">Factor to Javascript Compiler Makeover</a></li>
+</ul>
+</p>
+<p>The terminal emulation code for the Factor REPL is provided by the awesome <a href="http://www.masswerk.at/termlib/index.html">termlib</a> library by Norbert Landsteiner. Documentation for termlib is <a href="/responder/fjsc-repl-resources/termlib/">available here</a>. Please note the license of 'termlib':</p>
+<blockquote>This JavaScript-library is free for private and academic use. Please include a readable copyright statement and a backlink to <http://www.masswerk.at> in the web page. The library should always be accompanied by the "readme.txt" and the sample HTML-documents.
+
+The term "private use" includes any personal or non-commercial use, which is not related to commercial activites, but excludes intranet, extranet and/or public net applications that are related to any kind of commercial or profit oriented activity.
+
+For commercial use see <a href="http://www.masswerk.at">http://www.masswerk.at</a> for contact information.</blockquote>
+</td>
+<td valign="top">
+<p><b>Stack</b></p>
+<div id="stack">
+</div>
+<p><b>Playground</b></p>
+<div id="playground">
+</div>
+<h3>Compiled Code</h3>
+<textarea id="compiled" cols="40" rows="10">
+</textarea>
+<p>Some useful words:
+<dl>
+<dt>vocabs ( -- seq )</dt>
+<dd>Return a sequence of available vocabularies</dd>
+<dt>words ( string -- seq )</dt>
+<dd>Return a sequence of words in the given vocabulary</dd>
+<dt>all-words ( -- seq )</dt>
+<dd>Return a sequence of all words</dd>
+</dl>
+</p>
+<p>The contents of <a href="/responder/fjsc-resources/bootstrap.factor">bootstrap.factor</a> have been loaded on startup.</p>
+</td>
+</tr>
+</table>
--- /dev/null
+/* Copyright (C) 2007 Chris Double. All Rights Reserved.\r
+ See http://factorcode.org/license.txt for BSD license. */\r
+\r
+var fjsc_repl = false;\r
+\r
+function fjsc_repl_handler() {\r
+ var my_term = this;\r
+ this.newLine();\r
+ if(this.lineBuffer != '') {\r
+ factor.server_eval(\r
+ this.lineBuffer, \r
+ function(text, result) { \r
+ document.getElementById("compiled").value = result;\r
+ display_datastack(); \r
+ }, \r
+ function() { my_term.prompt(); });\r
+ }\r
+ else\r
+ my_term.prompt();\r
+}\r
+\r
+function fjsc_init_handler() {\r
+ this.write(\r
+ [\r
+ TermGlobals.center('********************************************************'),\r
+ TermGlobals.center('* *'),\r
+ TermGlobals.center('* Factor to Javascript Compiler Example *'),\r
+ TermGlobals.center('* *'),\r
+ TermGlobals.center('********************************************************')\r
+ ]);\r
+ \r
+ this.prompt();\r
+}\r
+\r
+function startup() {\r
+ var conf = {\r
+ x: 0,\r
+ y: 0,\r
+ cols: 64,\r
+ rows: 18,\r
+ termDiv: "repl",\r
+ crsrBlinkMode: true,\r
+ ps: "scratchpad ",\r
+ initHandler: fjsc_init_handler,\r
+ handler: fjsc_repl_handler\r
+ };\r
+ fjsc_repl = new Terminal(conf);\r
+ fjsc_repl.open();\r
+}\r
+\r
+function display_datastack() {\r
+ var html=[];\r
+ html.push("<table border='1'>")\r
+ for(var i = 0; i < factor.cont.data_stack.length; ++i) {\r
+ html.push("<tr><td>")\r
+ html.push(factor.cont.data_stack[i])\r
+ html.push("</td></tr>")\r
+ }\r
+ html.push("</table>")\r
+ document.getElementById('stack').innerHTML=html.join("");\r
+}\r
+\r
+jQuery(function() {\r
+ startup();\r
+ display_datastack();\r
+});\r
+\r
+factor.add_word("kernel", ".s", "primitive", function(next) { \r
+ var stack = factor.cont.data_stack;\r
+ var term = fjsc_repl;\r
+ for(var i=0; i<stack.length; ++i) {\r
+ term.type(""+stack[i]);\r
+ term.newLine();\r
+ }\r
+ factor.call_next(next);\r
+});\r
+\r
+factor.add_word("io", "print", "primitive", function(next) { \r
+ var stack = factor.cont.data_stack;\r
+ var term = fjsc_repl;\r
+ term.type(""+stack.pop());\r
+ term.newLine();\r
+ factor.call_next(next);\r
+});\r
+\r
+factor.add_word("io", "write", "primitive", function(next) { \r
+ var stack = factor.cont.data_stack;\r
+ var term = fjsc_repl;\r
+ term.type(""+stack.pop());\r
+ factor.call_next(next);\r
+});\r
+\r
+factor.add_word("io", ".", "primitive", function(next) { \r
+ var stack = factor.cont.data_stack;\r
+ var term = fjsc_repl;\r
+ term.type(""+stack.pop());\r
+ term.newLine();\r
+ factor.call_next(next);\r
+});\r
--- /dev/null
+<HTML>\r
+<HEAD>\r
+ <TITLE>mass:werk termlib faq</TITLE>\r
+\r
+<STYLE TYPE="text/css">\r
+body,p,a,td {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #cccccc;\r
+}\r
+.lh13 {\r
+ line-height: 13px;\r
+}\r
+.lh15 {\r
+ line-height: 15px;\r
+}\r
+pre {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ color: #ccffaa;\r
+ font-size: 12px;\r
+ line-height: 15px;\r
+}\r
+.prop {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ color: #bbee99;\r
+ font-size: 12px;\r
+ line-height: 15px;\r
+}\r
+h1 {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 16px;\r
+ color: #cccccc;\r
+}\r
+b.quest {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 14px;\r
+ font-weight: bold;\r
+ color: #bbee99;\r
+}\r
+a,a:link,a:visited {\r
+ text-decoration: none;\r
+ color: #77dd11;\r
+}\r
+a:hover {\r
+ text-decoration: underline;\r
+ color: #77dd11;\r
+}\r
+a:active {\r
+ text-decoration: underline;\r
+ color: #dddddd;\r
+}\r
+\r
+@media print {\r
+ body { background-color: #ffffff; }\r
+ body,p,a,td {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #000000;\r
+ }\r
+ .lh13 {\r
+ line-height: 13px;\r
+ }\r
+ .lh15 {\r
+ line-height: 15px;\r
+ }\r
+ pre,.prop {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #000000;\r
+ line-height: 15px;\r
+ }\r
+ h1 {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 16px;\r
+ color: #000000;\r
+ }\r
+ b.quest {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 14px;\r
+ font-weight: bold;\r
+ color: #000000;\r
+ }\r
+ a,a:link,a:visited {\r
+ text-decoration: none;\r
+ color: #000000;\r
+ }\r
+ a:hover {\r
+ text-decoration: underline;\r
+ color: #000000;\r
+ }\r
+ a:active {\r
+ text-decoration: underline;\r
+ color: #000000;\r
+ }\r
+}\r
+</STYLE>\r
+</HEAD>\r
+\r
+\r
+<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
+TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0"><A NAME="top"></A>\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
+<TR>\r
+ <TD NOWRAP><A HREF="index.html">termlib.js home</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="multiterm_test.html">multiple terminal test</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="parser_sample.html">sample parser</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP>faq</TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
+</TR>\r
+</TABLE>\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" WIDTH="700" ALIGN="center">\r
+ <TR><TD>\r
+ <H1>frequently asked questions</H1>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <BR>\r
+ <UL>\r
+ <LI CLASS="lh15"><A HREF="#chrome">Can I add chrome to the terminal? (e.g. a window header, a close box)</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#embed">How can I embed a terminal relative to my HTML layout?</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#syntax">I pasted your sample code and just got an error. - ???</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#keyboard">I can't get any input, but I don't get any erros too.</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#keylock">How can I temporary disable the keyboard handlers?</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#linesranges">How can I set the cusor to the start / the end of the command line?</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#historyunique">How can I limit the command history to unique entries only?</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#rebuild">How can I change my color theme on the fly?</A></LI>\r
+ <LI CLASS="lh15"><A HREF="#connect">How can I connect to a server?</A></LI>\r
+ </UL>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="chrome"></A>\r
+ <BR>\r
+<B CLASS="quest">Can I add chrome to the terminal? (e.g. a window header, a close box)</B><BR><BR>\r
+\r
+Not by the means of the Terminal object's interface (since there are way too many things that you may possibly want to add).<BR>\r
+The Terminal object allows you to specify the background color, the frame color, the frame's width and the font class used. If you want to add more chrome, you must align this in a separate division element.<BR><BR>\r
+\r
+To calculate the dimensions of the terminal use this formula:<BR><BR>\r
+\r
+width: 2 * frameWidth + conf.cols * <width of > + 2 * 2px padding (left and right)<BR>\r
+height: 2 * frameWidth + conf.rows * conf.rowHeight + 2 * 2px padding (top and bottom).<BR><BR>\r
+\r
+Or you could get the empirical values for width and height by calling a terminal's `<SPAN CLASS="prop">getDimensions()</SPAN>' method, once the terminal is open. (see documentation in "readme.txt").<BR><BR>\r
+\r
+Finnally, you could obviously embed the terminal's division element in your custom chrome layout (see below). [This will not be compatible to Netscape 4.]<BR><BR>\r
+\r
+p.e.:<PRE>\r
+ <div id="myTerminal1" style="position:absolute; top:100px; left:100px;">\r
+ <table class="termChrome">\r
+ <tbody>\r
+ <tr>\r
+ <td class="termTitle">terminal 1</td>\r
+ </tr>\r
+ <tr>\r
+ <td class="termBody"><div id="termDiv1" style="position:relative"></div></td>\r
+ </tr>\r
+ </tbody>\r
+ </table>\r
+ </div>\r
+\r
+ // get a terminal for this\r
+\r
+ var term1 = new Terminal(\r
+ {\r
+ x: 0,\r
+ y: 0,\r
+ id: 1,\r
+ termDiv: "termDiv1",\r
+ handler: myTermHandler\r
+ }\r
+ );\r
+ term1.open();\r
+ \r
+ // and this is how to move the chrome and the embedded terminal\r
+\r
+ TermGlobals.setElementXY( "myTerminal1", 200, 80 );\r
+</PRE>\r
+To keep track of the instance for any widgets use the terminal's `id' property. (You must set this in the configuration object to a unique value for this purpose.)<BR><BR>\r
+\r
+For a demonstration see the <A HREF="chrome_sample.html">Chrome Sample Page</A>.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="embed"></A>\r
+ <BR>\r
+<B CLASS="quest">How can I embed a terminal relative to my HTML layout?</B><BR><BR>\r
+\r
+Define your devision element with attribute "position" set to "relative" and place this inside your layout. Call "new Terminal()" with config-values { x: 0, y: 0 } to leave it at its relative origin.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="syntax"></A>\r
+ <BR>\r
+<B CLASS="quest">I pasted your sample code and just got an error. - ???</B><BR><BR>\r
+\r
+The short examples are kept arbitrarily simple to show the syntax.<BR>\r
+Make sure that your divison element(s) is/are rendered by the browser before `Terminal.open()' is called.<BR><BR>\r
+\r
+Does not work:\r
+<PRE> <head>\r
+ <script>\r
+ var term = new Terminal();\r
+ term.open();\r
+ </script>\r
+ </head>\r
+</PRE>\r
+Does work:\r
+<PRE> <head>\r
+ <script>\r
+ var term;\r
+ \r
+ function termOpen() {\r
+ // to be called from outside after compile time\r
+ term = new Terminal();\r
+ term.open();\r
+ }\r
+ </script>\r
+ </head>\r
+</PRE>\r
+c.f. "readme.txt"<BR>\r
+(Opening a terminal by clicking a link implies also that the page has currently focus.)<BR><BR>\r
+With v.1.01 and higher this doesn't cause an error any more.<BR>`Terminal.prototype.open()' now returns a value for success.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="keyboard"></A>\r
+ <BR>\r
+<B CLASS="quest">I can't get any input, but I don't get any erros too.</B><BR><BR>\r
+\r
+The Terminal object's functionality relies on the browsers ability to generate and handle keyboard events.<BR>\r
+Sadly some browsers lack a full implementation of the event model. (e.g. Konquerer [khtml] and early versions of Apple Safari, which is a descendant of khtml.)\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="keylock"></A>\r
+ <BR>\r
+<B CLASS="quest">How can I temporary disable the keyboard handlers?</B><BR>\r
+<SPAN CLASS="prop">(The terminal is blocking my HTML form fields, etc.)</SPAN><BR><BR>\r
+\r
+With version 1.03 there's a global property `<SPAN CLASS="prop">TermGlobals.keylock</SPAN>'. Set this to `true' to disable the keyboard handlers without altering any other state. Reset it to `false' to continue with your terminal session(s).\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="linesranges"></A>\r
+ <BR>\r
+<B CLASS="quest">How can I set the cusor to the start / the end of the command line?</B><BR><BR>\r
+\r
+In case you need to implement a shortcut (like ^A of some UN*X-shells) to jump to the beginning or the end of the current input line, there are two private instance methods you could utilize:<BR><BR>\r
+`<SPAN CLASS="prop">_getLineEnd(<row>, <col>)</SPAN>' returns an array [<row>, <col>] with the position of the last character in the logical input line with ASCII value >= 32 (0x20).<BR><BR>\r
+`<SPAN CLASS="prop">_getLineStart(<row>, <col>)</SPAN>' returns an array [<row>, <col>] with the position of the first character in the logical input line with ASCII value >= 32 (0x20).<BR><BR>\r
+Both take a row and a column of a cursor position as arguments.<BR><BR>\r
+\r
+p.e.:\r
+<PRE>\r
+ // jump to the start of the input line\r
+\r
+ myCtrlHandler() {\r
+ // catch ^A and jump to start of the line\r
+ if (this.inputChar == 1) {\r
+ var firstChar = this._getLineStart(this.r, this.c);\r
+ this.cursorSet(firstChar[0], firstChar[1]);\r
+ }\r
+ }</PRE>\r
+(Keep in mind that this is not exactly a good example, since some browser actually don't issue a keyboard event for \r
+"^A". And other browsers, which do catch such codes, are not very reliable in that.)\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="historyunique"></A>\r
+ <BR>\r
+<B CLASS="quest">How can I limit the command history to unique entries only?</B><BR>\r
+ <SPAN CLASS="prop">(My application effords commands to be commonly repeated.)</SPAN><BR><BR>\r
+\r
+With version 1.05 there is a new configuration and control flag `<SPAN CLASS="prop">historyUnique</SPAN>'. All you need is setting this to `true' in your terminal's configuration object.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="rebuild"></A>\r
+ <BR>\r
+<B CLASS="quest">How can I change my color theme on the fly?</B><BR><BR>\r
+\r
+With version 1.07 there is a new method `<SPAN CLASS="prop">Terminal.rebuild()</SPAN>'.<BR>\r
+This method updates the GUI to current config settings while preserving all other state.<BR><BR>\r
+p.e.:\r
+<PRE>\r
+ // change color settings on the fly\r
+ // here: set bgColor to white and font style to class "termWhite"\r
+ // method rebuild() updates the GUI without side effects\r
+ // assume var term holds a referene to a Terminal object already active\r
+\r
+ term.conf.bgColor = '#ffffff';\r
+ term.conf.fontClass = 'termWhite';\r
+ term.rebuild();</PRE>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13"><A NAME="connect"></A>\r
+ <BR>\r
+<B CLASS="quest">How can I connect to a server?</B><BR><BR>\r
+\r
+The Terminal object only provides an interface to handle console input and output.<BR>\r
+External connections have to be handled outside the Terminal object. You could use the XMLHttpRequest-Object (and use a communication model like AJAX or JSON) or connect via a frame or iframe element to a foreign host.<BR><BR>\r
+Handling connections is considered to be out of the realm of the "termlib.js" library.<BR>\r
+The code you need is in fact quite simple:\r
+<PRE>\r
+ function connectToHost(url) {\r
+ if (window.XMLHttpRequest) {\r
+ request = new XMLHttpRequest();\r
+ }\r
+ else if (window.ActiveXObject) {\r
+ request = new ActiveXObject('Microsoft.XMLHTTP');\r
+ }\r
+ if (request) {\r
+ request.onreadystatechange = requestChangeHandler;\r
+ request.open('GET', url);\r
+ request.send('');\r
+ }\r
+ else {\r
+ // XMLHttpRequest not implemented\r
+ }\r
+ }\r
+ \r
+ function requestChangeHandler() {\r
+ if (request.readyState == 4) {\r
+ // readyState 4: complete; now test for server's response status\r
+ if (request.status == 200) {\r
+ // response in request.responseText or request.responseXML if XML-code\r
+ // if it's JS-code we could get this by eval(request.responseText)\r
+ // by this we could import whole functions to be used via the terminal\r
+ }\r
+ else {\r
+ // connection error\r
+ // status code and message in request.status and request.statusText\r
+ }\r
+ }\r
+ }\r
+</PRE>\r
+You should use this only together with a timer (window.setTimeout()) to handle connection timeouts.<BR>\r
+Additionally you would need some syntax to authenticate and tell the server what you want.<BR>\r
+For this purpose you could use the following methods of the XMLHttpRequest object:<BR><BR>\r
+\r
+ <TABLE BORDER="0" CELLSPACING="0" CELLPADDING="3">\r
+ <TR VALIGN="top"><TD NOWRAP CLASS="prop">setRequestHeader("<I>headerLabel</I>", "<I>value</I>")</TD><TD>set a HTTP header to be sent to the server</TD></TR>\r
+ <TR VALIGN="top"><TD NOWRAP CLASS="prop">getResponseHeader("<I>headerLabel</I>")</TD><TD>get a HTTP header sent from the server</TD></TR>\r
+ <TR VALIGN="top"><TD NOWRAP CLASS="prop">open(<I>method</I>, "<I>url</I>" [, <I>asyncFlag</I> [,<BR> "<I>userid</I>" [, "<I>password</I>"]]])</TD><TD>assign the destination properties to the request.<BR>be aware that userid and password are not encrypted!</TD></TR>\r
+ <TR VALIGN="top"><TD NOWRAP CLASS="prop">send(<I>content</I>)</TD><TD>transmit a message body (post-string or DOM object)</TD></TR>\r
+ <TR VALIGN="top"><TD NOWRAP CLASS="prop">abort()</TD><TD>use this to stop a pending connection</TD></TR>\r
+ </TABLE>\r
+\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <BR>\r
+ Norbert Landsteiner - August 2005<BR>\r
+ <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <BR>\r
+ <A HREF="#top">> top of page</A>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ \r
+ </TD></TR>\r
+</TABLE>\r
+\r
+<DIV ID="termDiv" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
+\r
+</BODY>\r
+</HTML>
\ No newline at end of file
--- /dev/null
+<HTML>\r
+<HEAD>\r
+ <TITLE>mass:werk termlib</TITLE>\r
+\r
+<STYLE TYPE="text/css">\r
+body,p,a,td {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #cccccc;\r
+}\r
+.lh13 {\r
+ line-height: 13px;\r
+}\r
+.lh15 {\r
+ line-height: 15px;\r
+}\r
+pre {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #ccffaa;\r
+ line-height: 15px;\r
+}\r
+.prop {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ color: #bbee99;\r
+ font-size: 12px;\r
+ line-height: 15px;\r
+}\r
+h1 {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 16px;\r
+ color: #cccccc;\r
+}\r
+a,a:link,a:visited {\r
+ text-decoration: none;\r
+ color: #77dd11;\r
+}\r
+a:hover {\r
+ text-decoration: underline;\r
+ color: #77dd11;\r
+}\r
+a:active {\r
+ text-decoration: underline;\r
+ color: #dddddd;\r
+}\r
+\r
+@media print {\r
+ body { background-color: #ffffff; }\r
+ body,p,a,td {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #000000;\r
+ }\r
+ .lh13 {\r
+ line-height: 13px;\r
+ }\r
+ .lh15 {\r
+ line-height: 15px;\r
+ }\r
+ pre,.prop {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #000000;\r
+ line-height: 15px;\r
+ }\r
+ h1 {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 16px;\r
+ color: #000000;\r
+ }\r
+ a,a:link,a:visited {\r
+ text-decoration: none;\r
+ color: #000000;\r
+ }\r
+ a:hover {\r
+ text-decoration: underline;\r
+ color: #000000;\r
+ }\r
+ a:active {\r
+ text-decoration: underline;\r
+ color: #000000;\r
+ }\r
+}\r
+</STYLE>\r
+</HEAD>\r
+\r
+\r
+<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
+TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0"><A NAME="top"></A>\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
+<TR>\r
+ <TD NOWRAP>termlib.js home</TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="multiterm_test.html">multiple terminal test</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="parser_sample.html">sample parser</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="faq.html">faq</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
+</TR>\r
+</TABLE>\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" WIDTH="700" ALIGN="center">\r
+ <TR><TD>\r
+ <H1>mass:werk termlib.js</H1>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ The JavaScript library "termlib.js" provides a `Terminal' object, which\r
+ facillitates a simple and object oriented approach to generate and control a\r
+ terminal-like interface for web services.<BR><BR>\r
+ \r
+ "termlib.js" features direct keyboard input and powerful output methods\r
+ for multiple and simultanious instances of the `Terminal' object.<BR><BR>\r
+ \r
+ The library was written with the aim of simple usage and a maximum of compatibility\r
+ with minimal foot print in the global namespace.<BR><BR><BR>\r
+ \r
+ \r
+ A short example:<BR>\r
+ <PRE>\r
+ var term = new Terminal( {handler: termHandler} );\r
+ term.open();\r
+\r
+ function termHandler() {\r
+ this.newLine();\r
+ var line = this.lineBuffer;\r
+ if (line != "") {\r
+ this.write("You typed: "+line);\r
+ }\r
+ this.prompt();\r
+ }\r
+ </PRE>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <B>License</B><BR><BR>\r
+\r
+ This JavaScript-library is <U>free for private and academic use</U>.\r
+ Please include a readable copyright statement and a backlink to <http://www.masswerk.at> in the\r
+ web page. The library should always be accompanied by the "readme.txt" and the sample HTML-documents.<BR><BR>\r
+\r
+ The term "private use" includes any personal or non-commercial use, which is not related\r
+ to commercial activites, but excludes intranet, extranet and/or public net applications\r
+ that are related to any kind of commercial or profit oriented activity.<BR><BR>\r
+\r
+ For commercial use see <<A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>> for contact information.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <B>Distribution</B><BR><BR>\r
+\r
+ This JavaScript-library may be distributed freely as long it is distributed together with the "readme.txt" and the sample HTML-documents and this document.<BR><BR>\r
+\r
+ Any changes to the library should be commented and be documented in the readme-file.<BR>\r
+ Any changes must be reflected in the `Terminal.version' string as "Version.Subversion (compatibility)".\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <B>Disclaimer</B><BR><BR>\r
+\r
+ This software is distributed AS IS and in the hope that it will be useful, but WITHOUT ANY\r
+ WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
+ PURPOSE. The entire risk as to the quality and performance of the product is borne by the\r
+ user. No use of the product is authorized hereunder except under this disclaimer.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <B>History</B><BR><BR>\r
+\r
+ This library evolved from the terminal script "TermApp" ((c) N. Landsteiner 2003) and is in its\r
+ current form a down scaled spinn-off of the "JS/UIX" project. (JS/UIX is not a free software by now.)\r
+ c.f.: <<A HREF="http://www.masswerk.at/jsuix/" TARGET="_blank">http://www.masswerk.at/jsuix</A>><BR><BR>\r
+\r
+ For version history: see the <A HREF="readme.txt">readme.txt</A>.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <BR>\r
+ <B>Download</B><BR><BR>\r
+ Be sure to have read the license information and the disclamer and that you are willing to respect copyrights.<BR><BR>\r
+\r
+ <SPAN CLASS="prop">Download:</SPAN> <A HREF="termlib.zip">termlib.zip</A> (~ 40 KB, incl. docs)<BR><BR>\r
+ Current version is "1.07 (original)".<BR>\r
+ The files are now provided with line breaks in format <CRLF>.<BR>\r
+ \r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <B>Author</B><BR><BR>\r
+ © Norbert Landsteiner 2003-2005<BR>\r
+ mass:werk – media environments<BR>\r
+ <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <BR>\r
+ Author's note:<BR>\r
+ Please do not contact me on questions of simple usage. There is an extensive documentation (readme.txt) including plenty of sample code that should provide all information you need.\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ <BR>\r
+ <A HREF="#top">> top of page</A>\r
+ </TD></TR>\r
+ <TR><TD CLASS="lh13">\r
+ \r
+ </TD></TR>\r
+</TABLE>\r
+\r
+<DIV ID="termDiv" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
+\r
+</BODY>\r
+</HTML>
\ No newline at end of file
--- /dev/null
+<HTML>\r
+<HEAD>\r
+ <TITLE>termlib Multiple Terminal Test</TITLE>\r
+ <SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="termlib.js"></SCRIPT>\r
+\r
+<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript">\r
+<!--\r
+\r
+/*\r
+ multiple terminal test for termlib.js\r
+\r
+ (c) Norbert Landsteiner 2003-2005\r
+ mass:werk - media environments\r
+ <http://www.masswerk.at>\r
+\r
+*/\r
+\r
+var term=new Array();\r
+\r
+var helpPage=[\r
+ '%CS%+r Terminal Help %-r%n',\r
+ ' This is just a tiny test for multiple terminals.',\r
+ ' use one of the following commands:',\r
+ ' clear .... clear the terminal',\r
+ ' exit ..... close the terminal (or <ESC>)',\r
+ ' id ....... show terminal\'s id',\r
+ ' switch ... switch to other terminal',\r
+ ' help ..... show this help page',\r
+ ' other input will be echoed to the terminal.',\r
+ ' '\r
+];\r
+\r
+function termOpen(n) {\r
+ if (!term[n]) {\r
+ var y=(n==1)? 70: 280;\r
+ term[n]=new Terminal(\r
+ {\r
+ x: 220,\r
+ y: y,\r
+ rows: 12,\r
+ greeting: '%+r +++ Terminal #'+n+' ready. +++ %-r%nType "help" for help.%n',\r
+ id: n,\r
+ termDiv: 'termDiv'+n,\r
+ crsrBlinkMode: true,\r
+ handler: termHandler,\r
+ exitHandler: termExitHandler\r
+ }\r
+ );\r
+ if (term[n]) term[n].open();\r
+ }\r
+ else if (term[n].closed) {\r
+ term[n].open();\r
+ }\r
+ else {\r
+ term[n].focus();\r
+ }\r
+}\r
+\r
+function termHandler() {\r
+ // called on <CR> or <ENTER>\r
+ this.newLine();\r
+ var cmd=this.lineBuffer;\r
+ if (cmd!='') {\r
+ if (cmd=='switch') {\r
+ var other=(this.id==1)? 2:1;\r
+ termOpen(other);\r
+ }\r
+ else if (cmd=='clear') {\r
+ this.clear();\r
+ }\r
+ else if (cmd=='exit') {\r
+ this.close();\r
+ }\r
+ else if (cmd=='help') {\r
+ this.write(helpPage);\r
+ }\r
+ else if (cmd=='id') {\r
+ this.write('terminal id: '+this.id);\r
+ }\r
+ else {\r
+ this.type('You typed: '+cmd);\r
+ this.newLine();\r
+ }\r
+ }\r
+ this.prompt();\r
+}\r
+\r
+function termExitHandler() {\r
+ // optional handler called on exit\r
+ // activate other terminal if open\r
+ var other=(this.id==1)? 2:1;\r
+ if ((term[other]) && (term[other].closed==false)) term[other].focus();\r
+}\r
+\r
+//-->\r
+</SCRIPT>\r
+\r
+<STYLE TYPE="text/css">\r
+body,p,a,td {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #cccccc;\r
+}\r
+.lh15 {\r
+ line-height: 15px;\r
+}\r
+.term {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #33d011;\r
+ background: none;\r
+}\r
+.termReverse {\r
+ color: #111111;\r
+ background: #33d011;\r
+}\r
+a,a:link,a:visited {\r
+ text-decoration: none;\r
+ color: #77dd11;\r
+}\r
+a:hover {\r
+ text-decoration: underline;\r
+ color: #77dd11;\r
+}\r
+a:active {\r
+ text-decoration: underline;\r
+ color: #dddddd;\r
+}\r
+\r
+a.termopen,a.termopen:link,a.termopen:visited {\r
+ text-decoration: none;\r
+ color: #77dd11;\r
+ background: none;\r
+}\r
+a.termopen:hover {\r
+ text-decoration: none;\r
+ color: #222222;\r
+ background: #77dd11;\r
+}\r
+a.termopen:active {\r
+ text-decoration: none;\r
+ color: #222222;\r
+ background: #dddddd;\r
+}\r
+\r
+</STYLE>\r
+</HEAD>\r
+\r
+\r
+<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
+TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0">\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
+<TR>\r
+ <TD NOWRAP><A HREF="index.html">termlib.js home</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP>multiple terminal test</TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="parser_sample.html">sample parser</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="faq.html">faq</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
+</TR>\r
+</TABLE>\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0">\r
+ <TR><TD NOWRAP>\r
+ Multiple Terminal Test<BR> \r
+ </TD></TR>\r
+ <TR><TD NOWRAP>\r
+ <A HREF="javascript:termOpen(1)" onfocus="if(this.blur)this.blur();" onmouseover="window.status='terminal 1'; return true" onmouseout="window.status=''; return true" CLASS="termopen">> open terminal 1 </A>\r
+ </TD></TR>\r
+ <TR><TD NOWRAP>\r
+ <A HREF="javascript:termOpen(2)" onfocus="if(this.blur)this.blur();" onmouseover="window.status='terminal 2'; return true" onmouseout="window.status=''; return true" CLASS="termopen">> open terminal 2 </A>\r
+ </TD></TR>\r
+ <TR><TD NOWRAP CLASS="lh15">\r
+ <BR>\r
+ (c) mass:werk,<BR>N. Landsteiner 2003-2005<BR>\r
+ <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
+ </TD></TR>\r
+</TABLE>\r
+\r
+<DIV ID="termDiv1" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
+<DIV ID="termDiv2" STYLE="position:absolute; top:20px; left:100px;"></DIV>\r
+\r
+</BODY>\r
+</HTML>
\ No newline at end of file
--- /dev/null
+<HTML>\r
+<HEAD>\r
+ <TITLE>termlib Sample Parser</TITLE>\r
+ <SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="termlib.js"></SCRIPT>\r
+ <SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript" SRC="termlib_parser.js"></SCRIPT>\r
+\r
+<SCRIPT LANGUAGE="JavaScript" TYPE="text/javascript">\r
+<!--\r
+\r
+/*\r
+ test sample for termlib.js and termlib_parser.js\r
+\r
+ (c) Norbert Landsteiner 2005\r
+ mass:werk - media environments\r
+ <http://www.masswerk.at>\r
+\r
+*/\r
+\r
+var term;\r
+\r
+var helpPage=[\r
+ '%CS%+r Terminal Help %-r%n',\r
+ ' This is just a sample to demonstrate command line parsing.',\r
+ ' ',\r
+ ' Use one of the following commands:',\r
+ ' clear [-a] .......... clear the terminal',\r
+ ' option "a" also removes the status line',\r
+ ' number -n<value> .... return value of option "n" (test for options)',\r
+ ' repeat -n<value> .... repeats the first argument n times (another test)',\r
+ ' login <username> .... sample login (test for raw mode)',\r
+ ' exit ................ close the terminal (same as <ESC>)',\r
+ ' help ................ show this help page',\r
+ ' ',\r
+ ' other input will be echoed to the terminal as a list of parsed arguments',\r
+ ' in the format <argument index> <quoting level> "<parsed value>".',\r
+ ' '\r
+];\r
+\r
+function termOpen() {\r
+ if (!term) {\r
+ term=new Terminal(\r
+ {\r
+ x: 220,\r
+ y: 70,\r
+ termDiv: 'termDiv',\r
+ ps: '[guest]$',\r
+ initHandler: termInitHandler,\r
+ handler: commandHandler\r
+ }\r
+ );\r
+ if (term) term.open();\r
+ }\r
+ else if (term.closed) {\r
+ term.open();\r
+ }\r
+ else {\r
+ term.focus();\r
+ }\r
+}\r
+\r
+function termInitHandler() {\r
+ // output a start up screen\r
+ this.write(\r
+ [\r
+ TermGlobals.center('####################################################', 80),\r
+ TermGlobals.center('# #', 80),\r
+ TermGlobals.center('# termlib.js - Sample Parser #', 80),\r
+ TermGlobals.center('# Input is echoed as a list of parsed arguments. #', 80),\r
+ TermGlobals.center('# #', 80),\r
+ TermGlobals.center('# Type "help" for commands. #', 80),\r
+ TermGlobals.center('# #', 80),\r
+ TermGlobals.center('# (c) N. Landsteiner 2005; www.masswerk.at #', 80),\r
+ TermGlobals.center('# #', 80),\r
+ TermGlobals.center('####################################################', 80),\r
+ '%n'\r
+ ]\r
+ );\r
+ // set a double status line\r
+ this.statusLine('', 8,2); // just a line of strike\r
+ this.statusLine(' +++ This is just a test sample for command parsing. Type "help" for help. +++');\r
+ this.maxLines -= 2;\r
+ // and leave with prompt\r
+ this.prompt();\r
+}\r
+\r
+function commandHandler() {\r
+ this.newLine();\r
+ // check for raw mode first (should not be parsed)\r
+ if (this.rawMode) {\r
+ if (this.env.getPassword) {\r
+ // sample password handler (lineBuffer == stored username ?)\r
+ if (this.lineBuffer == this.env.username) {\r
+ this.user = this.env.username;\r
+ this.ps = '['+this.user+']>';\r
+ }\r
+ else {\r
+ this.type('Sorry.');\r
+ }\r
+ this.env.username = '';\r
+ this.env.getPassword = false;\r
+ }\r
+ // leave in normal mode\r
+ this.rawMode = false;\r
+ this.prompt();\r
+ return;\r
+ }\r
+ // normal command parsing\r
+ // just call the termlib_parser with a reference of the calling Terminal instance\r
+ // parsed arguments will be imported in this.argv,\r
+ // quoting levels per argument in this.argQL (quoting character or empty)\r
+ // cursor for arguments is this.argc (used by parserGetopt)\r
+ // => see 'termlib_parse.js' for configuration and details\r
+ parseLine(this);\r
+ if (this.argv.length == 0) {\r
+ // no commmand line input\r
+ }\r
+ else if (this.argQL[0]) {\r
+ // first argument quoted -> error\r
+ this.write("Syntax error: first argument quoted.");\r
+ }\r
+ else {\r
+ var cmd = this.argv[this.argc++];\r
+ /*\r
+ process commands now\r
+ 1st argument: this.argv[this.argc]\r
+ */\r
+ if (cmd == 'help') {\r
+ this.write(helpPage);\r
+ }\r
+ else if (cmd == 'clear') {\r
+ // get options\r
+ var opts = parserGetopt(this, 'aA');\r
+ if (opts.a) {\r
+ // discard status line on opt "a" or "A"\r
+ this.maxLines = this.conf.rows;\r
+ }\r
+ this.clear();\r
+ }\r
+ else if (cmd == 'number') {\r
+ // test for value options\r
+ var opts = parserGetopt(this, 'n');\r
+ if (opts.illegals.length) this.type('illegal option. usage: number -n<value>')\r
+ else if ((opts.n) && (opts.n.value != -1)) this.type('option value: '+opts.n.value)\r
+ else this.type('usage: number -n<value>');\r
+ }\r
+ else if (cmd == 'repeat') {\r
+ // another test for value options\r
+ var opts = parserGetopt(this, 'n');\r
+ if (opts.illegals.length) this.type('illegal option. usage: repeat -n<value> <string>')\r
+ else if ((opts.n) && (opts.n.value != -1)) {\r
+ // first normal argument is again this.argv[this.argc]\r
+ var s = this.argv[this.argc];\r
+ if (typeof s != 'undefined') {\r
+ // repeat this string n times\r
+ var a = [];\r
+ for (var i=0; i<opts.n.value; i++) a[a.length] = s;\r
+ this.type(a.join(' '));\r
+ }\r
+ }\r
+ else this.type('usage: repeat -n<value> <string>');\r
+ }\r
+ else if (cmd == 'login') {\r
+ // sample login (test for raw mode)\r
+ if ((this.argc == this.argv.length) || (this.argv[this.argc] == '')) {\r
+ this.type('usage: login <username>');\r
+ }\r
+ else {\r
+ this.env.getPassword = true;\r
+ this.env.username = this.argv[this.argc];\r
+ this.write('%+iSample login: repeat username as password.%-i%n');\r
+ this.type('password: ');\r
+ // exit in raw mode (blind input)\r
+ this.rawMode = true;\r
+ this.lock = false;\r
+ return;\r
+ }\r
+ }\r
+ else if (cmd == 'exit') {\r
+ this.close();\r
+ return;\r
+ }\r
+ else {\r
+ // for test purpose just output argv as list\r
+ // assemble a string of style-escaped lines and output it in more-mode\r
+ s=' INDEX QL ARGUMENT%n';\r
+ for (var i=0; i<this.argv.length; i++) {\r
+ s += TermGlobals.stringReplace('%', '%%',\r
+ TermGlobals.fillLeft(i, 6) +\r
+ TermGlobals.fillLeft((this.argQL[i])? this.argQL[i]:'-', 4) +\r
+ ' "' + this.argv[i] + '"'\r
+ ) + '%n';\r
+ }\r
+ this.write(s, 1);\r
+ return;\r
+ }\r
+ }\r
+ this.prompt();\r
+}\r
+\r
+\r
+//-->\r
+</SCRIPT>\r
+\r
+<STYLE TYPE="text/css">\r
+body,p,a,td {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #cccccc;\r
+}\r
+.lh15 {\r
+ line-height: 15px;\r
+}\r
+.term {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #33d011;\r
+ background: none;\r
+}\r
+.termReverse {\r
+ color: #111111;\r
+ background: #33d011;\r
+}\r
+a,a:link,a:visited {\r
+ text-decoration: none;\r
+ color: #77dd11;\r
+}\r
+a:hover {\r
+ text-decoration: underline;\r
+ color: #77dd11;\r
+}\r
+a:active {\r
+ text-decoration: underline;\r
+ color: #dddddd;\r
+}\r
+\r
+a.termopen,a.termopen:link,a.termopen:visited {\r
+ text-decoration: none;\r
+ color: #77dd11;\r
+ background: none;\r
+}\r
+a.termopen:hover {\r
+ text-decoration: none;\r
+ color: #222222;\r
+ background: #77dd11;\r
+}\r
+a.termopen:active {\r
+ text-decoration: none;\r
+ color: #222222;\r
+ background: #dddddd;\r
+}\r
+\r
+</STYLE>\r
+</HEAD>\r
+\r
+\r
+<BODY BGCOLOR="#222222" LINK="#77dd11" TEXT="#cccccc" ALINK="#dddddd" VLINK="#77dd11"\r
+TOPMARGIN="0" BOTTOMMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0">\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0" ALIGN="center">\r
+<TR>\r
+ <TD NOWRAP><A HREF="index.html">termlib.js home</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="multiterm_test.html">multiple terminal test</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP>sample parser</TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="faq.html">faq</A></TD>\r
+ <TD>|</TD>\r
+ <TD NOWRAP><A HREF="readme.txt" TITLE="readme.txt (text/plain)">documentation</A></TD>\r
+</TR>\r
+</TABLE>\r
+\r
+<TABLE BORDER="0" CELLSPACING="20" CELLPADDING="0">\r
+ <TR><TD NOWRAP>\r
+ Sample Parser Test<BR> \r
+ </TD></TR>\r
+ <TR><TD NOWRAP>\r
+ <A HREF="javascript:termOpen()" onfocus="if(this.blur)this.blur();" onmouseover="window.status='terminal 1'; return true" onmouseout="window.status=''; return true" CLASS="termopen">> open terminal </A>\r
+ </TD></TR>\r
+ <TR><TD NOWRAP>\r
+ \r
+ </TD></TR>\r
+ <TR><TD NOWRAP CLASS="lh15">\r
+ <BR>\r
+ (c) mass:werk,<BR>N. Landsteiner 2003-2005<BR>\r
+ <A HREF="http://www.masswerk.at/" TARGET="_blank">http://www.masswerk.at</A>\r
+ </TD></TR>\r
+</TABLE>\r
+\r
+<DIV ID="termDiv" STYLE="position:absolute;"></DIV>\r
+\r
+</BODY>\r
+</HTML>
\ No newline at end of file
--- /dev/null
+**** mass:werk termlib.js - JS-WebTerminal Object v1.07 ****\r
+\r
+ (c) Norbert Landsteiner 2003-2005\r
+ mass:werk - media environments\r
+ <http://www.masswerk.at>\r
+\r
+\r
+\r
+\r
+Contents:\r
+\r
+ 1 About\r
+ 2 Creating a new Terminal Instance\r
+ 2.1 Configuration Values\r
+ 3 Using the Terminal\r
+ 3.1 The Default Handler\r
+ 3.2 Input Modes\r
+ 3.2.1 Normal Line Input (Command Line Mode)\r
+ 3.2.1.2 Special Keys (ctrlHandler)\r
+ 3.2.2 Raw Mode\r
+ 3.2.3 Character Mode\r
+ 3.3 Other Handlers\r
+ 3.3.1 initHandler\r
+ 3.3.2 exitHandler\r
+ 3.4 Flags for Behaviour Control\r
+ 4 Output Methods\r
+ 4.1 Terminal.type()\r
+ 4.2 Terminal.write()\r
+ 4.3 Terminal.typeAt()\r
+ 4.4 Terminal.setChar()\r
+ 4.5 Terminal.newLine()\r
+ 4.6 Terminal.clear()\r
+ 4.7 Terminal.statusLine()\r
+ 4.8 Terminal.printRowFromString()\r
+ 4.9 Terminal.redraw()\r
+ 5 Cursor Methods and Editing\r
+ 5.1 Terminal.cursorOn()\r
+ 5.2 Terminal.cursorOff()\r
+ 5.3 Terminal.cursorSet()\r
+ 5.4 Terminal.cursorLeft()\r
+ 5.5 Terminal.cursorRight()\r
+ 5.6 Terminal.backspace()\r
+ 5.7 Terminal.fwdDelete()\r
+ 5.8 Terminal.isPrintable()\r
+ 6 Other Methods of the Terminal Object\r
+ 6.1 Terminal.prompt()\r
+ 6.2 Terminal.reset()\r
+ 6.3 Terminal.open()\r
+ 6.4 Terminal.close()\r
+ 6.5 Terminal.focus()\r
+ 6.6 Terminal.moveTo()\r
+ 6.7 Terminal.resizeTo()\r
+ 6.8 Terminal.getDimensions()\r
+ 6.9 Terminal.rebuild()\r
+ 7 Global Static Methods (TermGlobals)\r
+ 7.1 TermGlobals.setFocus()\r
+ 7.2 TermGlobals.keylock (Global Locking Flag)\r
+ 7.3 TermGlobalsText Methods\r
+ 7.3.1 TermGlobals.normalize()\r
+ 7.3.2 TermGlobals.fillLeft()\r
+ 7.3.3 TermGlobals.center()\r
+ 7.3.4 TermGlobals.stringReplace()\r
+ 8 Localization\r
+ 9 Cross Browser Functions\r
+ 10 Architecture, Internals\r
+ 10.1 Global Entities\r
+ 10.2 I/O Architecture\r
+ 10.3 Compatibility\r
+ 11 History\r
+ 12 Example for a Command Line Parser\r
+ 13 License\r
+ 14 Disclaimer\r
+ 15 References\r
+\r
+\r
+\r
+\r
+1 About\r
+\r
+The Terminal library "termlib.js" provides an object oriented constructor and control\r
+methods for a terminal-like DHTML interface.\r
+\r
+"termlib.js" features direct keyboard input and powerful output methods for multiple\r
+instances of the `Terminal' object (including focus control).\r
+\r
+The library was written with the aim of simple usage and a maximum of compatibility with\r
+minimal foot print in the global namespace.\r
+\r
+\r
+A simple example:\r
+\r
+ // creating a terminal and using it\r
+\r
+ var term = new Terminal( {handler: termHandler} );\r
+ term.open();\r
+\r
+ function termHandler() {\r
+ var line = this.lineBuffer;\r
+ this.newLine();\r
+ if (line == "help") {\r
+ this.write(helpPage)\r
+ }\r
+ else if (line == "exit") {\r
+ this.close();\r
+ return;\r
+ }\r
+ else if (line != "") {\r
+ this.write("You typed: "+line);\r
+ }\r
+ this.prompt();\r
+ }\r
+\r
+ var helpPage = [\r
+ "This is the monstrous help page for my groovy terminal.",\r
+ "Commands available:",\r
+ " help ... print this monstrous help page",\r
+ " exit ... leave this groovy terminal",\r
+ " ",\r
+ "Have fun!"\r
+ ];\r
+\r
+\r
+You should provide CSS font definitions for the classes ".term" (normal video) and\r
+".termReverse" (reverse video) in a monospaced font.\r
+A sample stylesheet "term_styles.css" comes with this library.\r
+\r
+See the sample application "multiterm_test.html" for a demo of multiple terminals.\r
+\r
+v.1.01: If you configure to use another font class (see 2.1 Configuration Values),\r
+ you must provide a subclass ".termReverse" for reversed video.\r
+\r
+ p.e.: .myFontClass .termReverse {\r
+ /* your definitions for reverse video here */\r
+ }\r
+ \r
+ With the addition of `conf.fontClass' you can now create multiple\r
+ instances with independend appearences.\r
+\r
+\r
+\r
+\r
+2 Creating a new Terminal Instance\r
+\r
+Use the `new' constructor to create a new instance of the Terminal object. You will want\r
+to supply a configuration object as an argument to the constructor. If the `new'\r
+constructor is called without an object as its first argument, default values are used.\r
+\r
+p.e.:\r
+\r
+ // creating a new instance of Terminal\r
+\r
+ var conf= {\r
+ x: 100,\r
+ y: 100,\r
+ cols: 80,\r
+ rows: 24\r
+ }\r
+\r
+ var term = new Term(conf);\r
+ term.open();\r
+\r
+`Terminal.open()' initializes the terminal and makes it visible to the user.\r
+This is handled in by separate method to allow the re-initilization of instances\r
+previously closed.\r
+\r
+NOTE:\r
+The division element (or NS-layer) that holds the terminal must be present when calling\r
+`Terminal.open()'. So you must not call this method from the header of a HTML-document at\r
+compile time.\r
+\r
+\r
+\r
+2.1 Configuration Values\r
+\r
+Set any of these values in your configuration object to override:\r
+\r
+ \r
+ LABEL DEFAULT VALUE COMMENT\r
+ \r
+ x 100 terminal's position x in px\r
+ y 100 terminal's position y in px\r
+ divDiv 'termDiv' id of terminals CSS division\r
+ bgColor '#181818' background color (HTML hex value)\r
+ frameColor '#555555' frame color (HTML hex value)\r
+ frameWidth 1 frame border width in px\r
+ fontClass 'term' class name of CSS font definition to use\r
+ cols 80 number of cols per row\r
+ rows 24 number of rows\r
+ rowHeight 15 a row's line-height in px\r
+ blinkDelay 500 delay for cursor blinking in milliseconds\r
+ crsrBlinkMode false true for blinking cursor\r
+ crsrBlockMode true true for block-cursor else underscore\r
+ DELisBS false handle <DEL> as <BACKSPACE>\r
+ printTab true handle <TAB> as printable (prints as space)\r
+ printEuro true handle unicode 0x20AC (Euro sign) as printable\r
+ catchCtrlH true handle ^H as <BACKSPACE>\r
+ closeOnESC true close terminal on <ESC>\r
+ historyUnique false prevent consecutive and identical entries in history\r
+ id 0 terminal id\r
+ ps '>' prompt string\r
+ greeting '%+r Terminal ready. %-r' string for greeting if no initHandler is used\r
+ handler termDefaultHandler reference to handler for command interpretation\r
+ ctrlHandler null reference to handler called on uncatched special keys\r
+ initHandler null reference to handler called at end of init()\r
+ exitHandler null reference to handler called on close()\r
+\r
+\r
+At least you will want to specify `handler' to implement your own command parser.\r
+\r
+Note: While `id' is not used by the Termninal object, it provides an easy way to identify\r
+multiple terminals by the use of "this.id". (e.g.: "if (this.id == 1) startupterm = true;")\r
+\r
+p.e.:\r
+\r
+ // creating two individual Terminal instances\r
+\r
+ var term1 = new Terminal(\r
+ {\r
+ id: 1,\r
+ x: 200,\r
+ y: 10,\r
+ cols: 80,\r
+ rows: 12,\r
+ greeting: "*** This is Terminal 1 ***",\r
+ handler: myTerminalHandler\r
+ }\r
+ );\r
+ term1.open();\r
+\r
+ var term2 = new Terminal(\r
+ {\r
+ id: 2,\r
+ x, 200,\r
+ y: 220,\r
+ cols: 80\r
+ rows: 12,\r
+ greeting: "*** This is Terminal 2 ***",\r
+ handler: myTerminalHandler\r
+ }\r
+ );\r
+ term2.open();\r
+\r
+\r
+\r
+\r
+3 Using the Terminal\r
+\r
+There are 4 different handlers that are called by a Terminal instance to process input and\r
+some flags to control the input mode and behaviour.\r
+\r
+\r
+\r
+3.1 The Default Handler (a simlple example for input handling)\r
+\r
+If no handlers are defined in the configuration object, a default handler is called to\r
+handle a line of user input. The default command line handler `termDefaultHandler' just\r
+closes the command line with a new line and echos the input back to the user:\r
+\r
+ function termDefaultHandler() {\r
+ this.newLine();\r
+ if (this.lineBuffer != '') {\r
+ this.type('You typed: '+this.lineBuffer);\r
+ this.newLine();\r
+ }\r
+ this.prompt();\r
+ }\r
+\r
+First you may note that the instance is refered to as `this'. So you need not worry about\r
+which Terminal instance is calling your handler. As the handler is entered, the terminal\r
+is locked for user input and the cursor is off. The current input is available as a string\r
+value in `this.lineBuffer'.\r
+\r
+The method `type(<text>)' just does what it says and types a string at the current cursor\r
+position to the terminal screen.\r
+\r
+`newLine()' moves the cursor to a new line.\r
+\r
+The method `prompt()' adds a new line if the cursor isn't at the start of a line, outputs\r
+the prompt string (as specified in the configuration), activates the cursor, and unlocks\r
+the terminal for further input. While you're doing normal command line processing, always\r
+call `prompt()' when leaving your handler.\r
+\r
+In fact this is all you need to create your own terminal application. Please see at least\r
+the method `write()' for a more powerful output method.\r
+\r
+Below we will refer to all methods of the Terminal object as `Terminal.<method>()'.\r
+You can call them as `this.<method>()' in a handler or as methods of your named instance\r
+in other context (e.g.: "myTerminal.close()").\r
+\r
+[In technical terms these methods are methods of the Terminal's prototype object, while\r
+the properties are properties of a Termninal instance. Since this doesn't make any\r
+difference to your script, we'll refer to both as `Terminal.<method-or-property>'.]\r
+\r
+\r
+\r
+3.2 Input Modes\r
+\r
+3.2.1 Normal Line Input (Command Line Mode)\r
+\r
+By default the terminal is in normal input mode. Any printable characters in the range of\r
+ASCII 0x20 - 0xff are echoed to the terminal and may be edited with the use of the cursor\r
+keys and the <BACKSPACE> key.\r
+The cursor keys UP and DOWN let the user browse in the command line history (the list of\r
+all commands issued previously in this Terminal instance).\r
+\r
+If the user presses <CR> or <ENTER>, the line is read from the terminal buffer, converted\r
+to a string, and placed in `Terminal.lineBuffer' (-> `this.lineBuffer') for further use.\r
+The terminal is then locked for further input and the specified handler\r
+(`Terminal.handler') is called.\r
+\r
+\r
+3.2.1.2 Special Keys (ctrlHandler)\r
+\r
+If a special character (ASCII<0x20) or an according combination of <CTRL> and a key is\r
+pressed, which is not caught for editing or "enter", and a handler for `ctrlHandler' is\r
+specified, this handler is called.\r
+The ASCII value of the special character is available in `Terminal.inputChar'. Please note\r
+that the terminal is neither locked, nor is the cursor off - all further actions have to\r
+be controlled by `ctrlHandler'. (The tracking of <CTRL>-<key> combinations as "^C" usually\r
+works but cannot be taken for granted.)\r
+\r
+A named reference of the special control values in POSIX form (as well as the values of\r
+the cursor keys [LEFT, RIGHT, UP, DOWN]) is available in the `termKey' object.\r
+\r
+p.e.:\r
+\r
+ // a simple ctrlHandler\r
+\r
+ function myCtrlHandler() {\r
+ if (this.inputChar == termKey.ETX) {\r
+ // exit on ^C (^C == ASCII 0x03 == <ETX>)\r
+ this.close();\r
+ }\r
+ }\r
+\r
+If no `ctrlHandler' is specified, control keys are ignored (default).\r
+\r
+\r
+3.2.2 Raw Mode\r
+\r
+If the flag `Terminal.rawMode' is set to a value evaluating to `true', no special keys are\r
+tracked but <CR> and <ENTER> (and <ESC>, if the flag `Terminal.closeOnESC' is set).\r
+The input is NOT echoed to the terminal. All printable key values [0x20-0xff] are\r
+transformed to characters and added to `Terminal.lineBuffer' sequentially. The command\r
+line input is NOT added to the history.\r
+\r
+This mode is especially suitable for password input.\r
+\r
+p.e.:\r
+\r
+ // using raw mode for password input\r
+\r
+ function myTermHandler() {\r
+ this.newLine();\r
+ // we stored a flag in Terminal.env to track the status\r
+ if (this.env.getpassword) {\r
+ // leave raw mode\r
+ this.rawMode = false;\r
+ if (passwords[this.env.user] == this.lineBuffer) {\r
+ // matched\r
+ this.type('Welcome '+this.env.user);\r
+ this.env.loggedin = true;\r
+ }\r
+ else {\r
+ this.type('Sorry.');\r
+ }\r
+ this.env.getpassword = false;\r
+ }\r
+ else {\r
+ // simple parsing\r
+ var args = this.lineBuffer.split(' ');\r
+ var cmd = args[0];\r
+ if (cmd == 'login') {\r
+ var user = args[1];\r
+ if (!user) {\r
+ this.type('usage: login <username>');\r
+ }\r
+ else {\r
+ this.env.user = user;\r
+ this.env.getpassword = true;\r
+ this.type('password? ');\r
+ // enter raw mode\r
+ this.rawMode = true;\r
+ // leave without prompt so we must unlock first\r
+ this.lock = false;\r
+ return;\r
+ }\r
+ }\r
+ /*\r
+ other actions ...\r
+ */\r
+ }\r
+ this.prompt();\r
+ }\r
+\r
+In this example a handler is set up to process the command "login <username>" and ask for\r
+a password for the given user name in raw mode. Note the use of the object `Terminal.env'\r
+which is just an empty object set up at the creation of the Terminal instance. Its only\r
+purpose is to provide an individual namespace for private data to be stored by a Terminal\r
+instance.\r
+\r
+NOTE: The flag `Terminal.lock' is used to control the keyboard locking. If we would not\r
+set this to `false' before leaving in raw mode, we would be caught in dead-lock, since no\r
+input could be entered and our handler wouldn't be called again. - A dreadful end of our\r
+terminal session.\r
+\r
+NOTE: Raw mode utilizes the property `Terminal.lastLine' to collect the input string.\r
+This is normally emty, when a handler is called. This is not the case if your script left\r
+the input process on a call of ctrlHandler. You should clear `Terminal.lastLine' in such\r
+a case, if you're going to enter raw mode immediatly after this.\r
+\r
+\r
+3.2.3 Character Mode\r
+\r
+If the flag `Terminal.charMode' is set to a value evaluating to `true', the terminal is in\r
+character mode. In this mode the numeric ASCII value of the next key typed is stored in\r
+`Terminal.inputChar'. The input is NOT echoed to the terminal. NO locking or cursor\r
+control is performed and left to the handler.\r
+You can use this mode to implement your editor or a console game.\r
+`Terminal.charMode' takes precedence over `Terminal.rawMode'.\r
+\r
+p.e.: \r
+\r
+ // using char mode\r
+\r
+ function myTermHandler() {\r
+ // this is the normal handler\r
+ this.newLine();\r
+ // simple parsing\r
+ var args = this.lineBuffer.split(' ');\r
+ var cmd = args[0];\r
+ if (cmd == 'edit') {\r
+ // init the editor\r
+ myEditor(this);\r
+ // redirect the handler to editor\r
+ this.handler = myEditor;\r
+ // leave in char mode\r
+ this.charMode = true;\r
+ // show cursor\r
+ this.cursorOn();\r
+ // don't forget unlocking\r
+ this.lock = false;\r
+ return;\r
+ }\r
+ /*\r
+ other actions ...\r
+ */\r
+ this.prompt();\r
+ }\r
+\r
+ function myEditor(initterm) {\r
+ // our dummy editor (featuring modal behaviour)\r
+ if (initterm) {\r
+ // perform initialization tasks\r
+ initterm.clear();\r
+ initterm.write('this is a simple test editor; leave with <ESC> then "q"%n%n');\r
+ initterm.env.mode = '';\r
+ // store a reference of the calling handler\r
+ initterm.env.handler = initterm.handler;\r
+ return;\r
+ }\r
+ // called as handler -> lock first\r
+ this.lock=true;\r
+ // hide cursor\r
+ this.cursorOff();\r
+ var key = this.inputChar;\r
+ if (this.env.mode == 'ctrl') {\r
+ // control mode\r
+ if (key == 113) {\r
+ // "q" => quit\r
+ // leave charMode and reset the handler to normal\r
+ this.charMode = false;\r
+ this.handler = this.env.handler;\r
+ // clear the screen\r
+ this.clear();\r
+ // prompt and return\r
+ this.prompt();\r
+ return;\r
+ }\r
+ else {\r
+ // leave control mode\r
+ this.env.mode = '';\r
+ }\r
+ }\r
+ else {\r
+ // edit mode\r
+ if (key == termKey.ESC) {\r
+ // enter control mode\r
+ // we'd better indicate this in a status line ...\r
+ this.env.mode = 'ctrl';\r
+ }\r
+ else if (key == termKey.LEFT) {\r
+ // cursor left\r
+ }\r
+ else if (key == termKey.RIGHT) {\r
+ // cursor right\r
+ }\r
+ if (key == termKey.UP) {\r
+ // cursor up\r
+ }\r
+ else if (key == termKey.DOWN) {\r
+ // cursor down\r
+ }\r
+ else if (key == termKey.CR) {\r
+ // cr or enter\r
+ }\r
+ else if (key == termKey.BS) {\r
+ // backspace\r
+ }\r
+ else if (key == termKey.DEL) {\r
+ // fwd delete\r
+ // conf.DELisBS is not evaluated in charMode!\r
+ }\r
+ else if (this.isPrintable(key)) {\r
+ // printable char - just type it\r
+ var ch = String.fromCharCode(key);\r
+ this.type(ch);\r
+ }\r
+ }\r
+ // leave unlocked with cursor\r
+ this.lock = false;\r
+ this.cursorOn();\r
+ }\r
+\r
+\r
+Note the redirecting of the input handler to replace the command line handler by the\r
+editor. The method `Terminal.clear()' clears the terminal.\r
+`Terminal.cursorOn()' and `Terminal.cursorOff()' are used to show and hide the cursor.\r
+\r
+\r
+\r
+3.3 Other Handlers\r
+\r
+There are two more handlers that can be specified in the configuration object:\r
+\r
+\r
+3.3.1 initHandler\r
+\r
+`initHandler' is called at the end of the initialization triggered by `Terminal.open()'.\r
+The default action - if no `initHandler' is specified - is:\r
+\r
+ // default initilization\r
+\r
+ this.write(this.conf.greeting);\r
+ this.newLine();\r
+ this.prompt();\r
+\r
+Use `initHandler' to perform your own start up tasks (e.g. show a start up screen). Keep\r
+in mind that you should unlock the terminal and possibly show a cursor to give the\r
+impression of a usable terminal.\r
+\r
+\r
+3.3.2 exitHandler\r
+\r
+`exitHandler' is called by `Terminal.close()' just before hiding the terminal. You can use\r
+this handler to implement any tasks to be performed on exit. Note that this handler is\r
+called even if the terminal is closed on <ESC> outside of your inputHandlers control.\r
+\r
+See the file "multiterm_test.html" for an example.\r
+\r
+\r
+\r
+3.4 Overview: Flags for Behaviour Control\r
+\r
+These falgs are accessible as `Terminal.<flag>' at runtime. If not stated else, the\r
+initial value may be specified in the configuration object.\r
+The configuration object and its properties are accessible at runtime via `Terminal.conf'.\r
+\r
+\r
+ NAME DEFAULT VALUE MEANING\r
+\r
+ blink_delay 500 delay for cursor blinking in milliseconds.\r
+\r
+ crsrBlinkMode false true for blinking cursor.\r
+ if false, cursor is static.\r
+ \r
+ crsrBlockMode true true for block-cursor else underscore.\r
+\r
+ DELisBS false handle <DEL> as <BACKSPACE>.\r
+\r
+ printTab true handle <TAB> as printable (prints as space)\r
+ if false <TAB> is handled as a control character\r
+\r
+ printEuro true handle the euro sign as valid input char.\r
+ if false char 0x20AC is printed, but not accepted\r
+ in the command line\r
+\r
+ catchCtrlH true handle ^H as <BACKSPACE>.\r
+ if false, ^H must be tracked by a custom\r
+ ctrlHandler.\r
+\r
+ closeOnESC true close terminal on <ESC>.\r
+ if true, <ESC> is not available for ctrHandler.\r
+\r
+\r
+ historyUnique false unique history entries.\r
+ if true, entries that are identical to the last\r
+ entry in the user history will not be added.\r
+\r
+ charMode false terminal in character mode (tracks next key-code).\r
+ (runtime only)\r
+ \r
+ rawMode false terminal in raw mode (no echo, no editing).\r
+ (runtime only)\r
+\r
+\r
+Not exactly a flag but useful:\r
+\r
+ ps '>' prompt string.\r
+\r
+\r
+\r
+\r
+4 Output Methods\r
+\r
+Please note that any output to the terminal implies an advance of the cursor. This means,\r
+that if your output reaches the last column of your terminal, the cursor is advanced and\r
+a new line is opened automatically. This procedure may include scrolling to make room for\r
+the new line. While this is not of much interest for most purposes, please note that, if\r
+you output a string of length 80 to a 80-columns-terminal, and a new line, and another\r
+string, this will result in an empty line between the two strings.\r
+\r
+\r
+4.1 Terminal.type( <text> [,<stylevector>] )\r
+\r
+Types the string <text> at the current cursor position to the terminal. Long lines are\r
+broken where the last column of the terminal is reached and continued in the next line.\r
+`Terminal.write()' does not support any kind of arbitrary line breaks. (This is just a\r
+basic output routine. See `Terminal.write()' for a more powerful output method.)\r
+\r
+A bitvector may be supplied as an optional second argument to represent a style or a\r
+combination of styles. The meanings of the bits set are interpreted as follows:\r
+\r
+<stylevector>:\r
+\r
+ 1 ... reverse (2 power 0)\r
+ 2 ... underline (2 power 1)\r
+ 4 ... italics (2 power 2)\r
+ 8 ... strike (2 power 3)\r
+\r
+So "Terminal.type( 'text', 5 )" types "text" in italics and reverse video.\r
+\r
+Note:\r
+There is no bold, for most monospaced fonts (including Courier) tend to render wider in\r
+bold. Since this would bring the terminal's layout out of balance, we just can't use bold\r
+as a style. - Sorry.\r
+\r
+The HTML-representation of this styles are defined in "TermGlobals.termStyleOpen" and\r
+"TermGlobals.termStyleClose".\r
+\r
+\r
+4.2 Terminal.write( <text> [,<usemore>] )\r
+\r
+Writes a text with markup to the terminal. If an optional second argument evaluates to\r
+true, a UN*X-style utility like `more' is used to page the text. The text may be supplied\r
+as a single string (with newline character "\n") or as an array of lines. Any other input\r
+is transformed to a string value before output.\r
+\r
+4.2.1 Mark-up:\r
+\r
+`Terminal.write()' employs a simple mark-up with the following syntax:\r
+\r
+<markup>: %([+|-]<style>|n|CS|%)\r
+ \r
+ where "+" and '-' are used to switch on and off a style, where\r
+ \r
+ <style>:\r
+ \r
+ "i" ... italics\r
+ "r" ... reverse\r
+ "s" ... strike\r
+ "u" ... underline\r
+ \r
+ "p" ... reset to plain ("%+p" == "%-p")\r
+ \r
+ styles may be combined and may overlap. (e.g. "This is %+rREVERSE%-r, %+uUNDER%+iSCORE%-u%-i.")\r
+ \r
+ "%n" represents a new line (in fact "\n" is translated to "%n" before processing)\r
+ \r
+ "%CS" clears the terminal screen\r
+ \r
+ "%%" represents the percent character ('%')\r
+\r
+\r
+4.2.2 Buffering:\r
+\r
+`Terminal.write()' writes via buffered output to the terminal. This means that the\r
+provided text is rendered to a buffer first and then only the visible parts are transfered\r
+to the terminal display buffers. This avoids scrolling delays for long output.\r
+\r
+4.2.3 UseMore Mode:\r
+\r
+The buffering of `Terminal.write()' allows for pagewise output, which may be specified by\r
+a second boolean argument. If <usemore> evaluates to `true' and the output exceeds the\r
+range of empty rows on the terminal screen, `Terminal.write()' performs like the UN*X\r
+utility `more'. The next page may be accessed by hitting <SPACE> while <q> terminates\r
+paging and returns with the prompt (-> `Terminal.prompt()').\r
+\r
+To use this facillity make sure to return immediatly after calling `Terminal.write()' in\r
+order to allow the more-routine to track the user input.\r
+The terminal is set to "charMode == false" afterwards.\r
+\r
+p.e.:\r
+\r
+ // using Terminal.write as a pager\r
+\r
+ function myTermHandler() {\r
+ this.newLine();\r
+ var args = this.lineBuffer.split(' ');\r
+ var cmd = args[0];\r
+ if (cmd == 'more') {\r
+ var page = args[1];\r
+ if (myPages[page]) {\r
+ // Terminal.write as a pager\r
+ this.write(myPages[page], true);\r
+ return;\r
+ }\r
+ else {\r
+ // Terminal.write for simple output\r
+ this.write('no such page.');\r
+ }\r
+ }\r
+ /*\r
+ other actions ...\r
+ */\r
+ this.prompt();\r
+ }\r
+\r
+\r
+4.3 Terminal.typeAt( <r>, <c>, <text> [,<stylevector>] )\r
+\r
+Output the string <text> at row <r>, col <c>.\r
+For <stylevector> see `Terminal.type()'.\r
+`Terminal.typeAt()' does not move the cursor.\r
+\r
+\r
+4.4 Terminal.setChar( <charcode>, <r>, <c> [,<stylevector>] )\r
+\r
+Output a single character represented by the ASCII value of <charcode> at row <r>, col <c>.\r
+For <stylevector> see `Terminal.type()'.\r
+\r
+\r
+4.5 Terminal.newLine()\r
+\r
+Moves the cursor to the first column of the next line and performs scrolling, if needed.\r
+\r
+\r
+4.6 Terminal.clear()\r
+\r
+Clears the terminal screen. (Returns with cursor off.)\r
+\r
+\r
+4.7 Terminal.statusLine( <text> [,<stylevector> [,<lineoffset>]] )\r
+\r
+All output acts on a logical screen with the origin at row 0 / col 0. While the origin is\r
+fixed, the logical width and height of the terminal are defined by `Terminal.maxCols' and\r
+`Terminal.maxLines'. These are set to the configuration dimensions at initilization and by\r
+`Terminal.reset()', but may be altered at any moment. Please note that there are no bounds\r
+checked, so make sure that `Terminal.maxCols' and `Terminal.maxLines' are less or equal\r
+to the configuration dimensions.\r
+\r
+You may want to decrement `Terminal.maxLines' to keep space for a reserved status line.\r
+`Terminal.statusLine( <text>, <style> )' offers a simple way to type a text to the last\r
+line of the screen as defined by the configuration dimensions.\r
+\r
+ // using statusLine()\r
+\r
+ function myHandler() {\r
+ // ...\r
+ // reserve last line\r
+ this.maxLines = term.conf.rows-1;\r
+ // print to status line in reverse video\r
+ this.statusLine("Status: <none>", 1);\r
+ // ...\r
+ }\r
+\r
+For multiple status lines the optional argument <lineoffset> specifies the addressed row,\r
+where 1 is the line closest to the bottom, 2 the second line from the bottom and so on.\r
+(default: 1)\r
+\r
+\r
+4.8 Terminal.printRowFromString( <r> , <text> [,<stylevector>] )\r
+\r
+Outputs the string <text> to row <r> in the style of an optional <stylevector>.\r
+If the string's length exceeds the length of the row (up to `Terminal.conf.cols'), extra\r
+characteres are ignored, else any extra space is filled with character code 0 (prints as\r
+<SPACE>).\r
+The valid range for <row> is: 0 >= <row> < `Terminal.maxLines'.\r
+`Terminal.printRowFromString()' does not set the cursor.\r
+\r
+You could, for example, use this method to output a line of a text editor's buffer.\r
+\r
+p.e.:\r
+\r
+ // page refresh function of a text editor\r
+\r
+ function myEditorRefresh(termref, topline) {\r
+ // termref: reference to Terminal instance\r
+ // topline: index of first line to print\r
+ // lines of text are stored in termref.env.lines\r
+ for (var r=0; r<termref.maxLines; r++) {\r
+ var i = topline + r;\r
+ if (i < termref.env.lines.length) {\r
+ // output stored line\r
+ termref.printRowFromString(r, termref.env.lines[i]);\r
+ }\r
+ else {\r
+ // output <tilde> for empty line\r
+ termref.printRowFromString(r, '~');\r
+ }\r
+ }\r
+ // set cursor to origin\r
+ termref.r = termref.c = 0; // same as termref.cursorSet(0, 0);\r
+ }\r
+\r
+\r
+4.9 Terminal.redraw( <row> )\r
+\r
+Basic function to redraw a terminal row <row> according to screen buffer values.\r
+For hackers only. (e.g.: for a console game, hack screen buffers first and redraw all\r
+changed rows at once.)\r
+\r
+\r
+\r
+\r
+5 Cursor Methods and Editing\r
+\r
+\r
+5.1 Terminal.cursorOn()\r
+\r
+Show the cursor.\r
+\r
+\r
+5.2 Terminal.cursorOff()\r
+\r
+Hide the cursor.\r
+\r
+\r
+5.3 Terminal.cursorSet( <r>, <c> )\r
+\r
+Set the cursor position to row <r> column <c>.\r
+`Terminal.cursorSet()' preserves the cursor's active state (on/off).\r
+\r
+\r
+5.4 Terminal.cursorLeft()\r
+\r
+Move the cursor left. (Movement is restricted to the logical input line.)\r
+`Terminal.cursorLeft()' preserves the cursor's active state (on/off).\r
+\r
+\r
+5.5 Terminal.cursorRight()\r
+\r
+Move the cursor right. (Movement is restricted to the logical input line.)\r
+`Terminal.cursorRight()' preserves the cursor's active state (on/off).\r
+\r
+\r
+5.6 Terminal.backspace()\r
+\r
+Delete the character left from the cursor, if the cursor is not in first position of the\r
+logical input line.\r
+`Terminal.backspace()' preserves the cursor's active state (on/off).\r
+\r
+\r
+5.7 Terminal.fwdDelete()\r
+\r
+Delete the character under the cursor.\r
+`Terminal.fwdDelete()' preserves the cursor's active state (on/off).\r
+\r
+\r
+5.8 Terminal.isPrintable( <key code> [,<unicode page 1 only>] )\r
+\r
+Returns `true' if the character represented by <key code> is printable with the current\r
+settings. An optional second argument <unicode page 1 only> limits the range of valid\r
+values to 255 with the exception of the Euro sign, if the flag `Terminal.printEuro' is set.\r
+(This second flag is used for input methods but not for output methods. So you may only\r
+enter portable characters, but you may print others to the terminals screen.)\r
+\r
+\r
+\r
+\r
+6 Other Methods of the Terminal Object\r
+\r
+6.1 Terminal.prompt()\r
+\r
+Performes the following actions:\r
+\r
+ * advance the cursor to a new line, if the cursor is not at 1st column\r
+ * type the prompt string (as specified in the configuaration object)\r
+ * show the cursor\r
+ * unlock the terminal\r
+\r
+(The value of the prompt string can be accessed and changed in `Terminal.ps'.)\r
+\r
+\r
+6.2 Terminal.reset()\r
+\r
+Resets the terminal to sane values and clears the terminal screen.\r
+\r
+\r
+6.3 Terminal.open()\r
+\r
+Opens the terminal. If this is a fresh instance, the HTML code for the terminal is\r
+generated. On re-entry the terminal's visibility is set to `true'. Initialization tasks\r
+are performed and the optional initHandler called. If no initHandler is specified in the\r
+configuration object, the greeting (configuration or default value) is shown and the user\r
+is prompted for input.\r
+\r
+v.1.01: `Terminal.open()' now checks for the existence of the DHTML element as defined in\r
+ `Terminal.conf.termDiv' and returns success.\r
+\r
+\r
+6.4 Terminal.close()\r
+\r
+Closes the terminal and hides its visibility. An optional exitHandler (specified in the\r
+configuration object) is called, and finally the flag `Terminal.closed' is set to true. So\r
+you can check for existing terminal instances as you would check for a `window' object\r
+created by `window.open()'.\r
+\r
+p.e.:\r
+\r
+ // check for a terminals state\r
+ // let array "term" hold references to terminals\r
+\r
+ if (term[n]) {\r
+ if (term[n].closed) {\r
+ // terminal exists and is closed\r
+ // re-enter via "term[n].open()"\r
+ }\r
+ else {\r
+ // terminal exists and is currently open\r
+ }\r
+ }\r
+ else {\r
+ // no such terminal\r
+ // create it via "term[n] = new Terminal()"\r
+ }\r
+\r
+\r
+6.5 Terminal.focus()\r
+\r
+Set the keyboard focus to this instance of Terminal. (As `window.focus()'.)\r
+\r
+\r
+6.6 Terminal.moveTo( <x>, <y> )\r
+\r
+Move the terminal to position <x>/<y> in px.\r
+(As `window.moveTo()', but inside the HTML page.)\r
+\r
+\r
+6.7 Terminal.resizeTo( <x>, <y> )\r
+\r
+Resize the terminal to dimensions <x> cols and <y> rows.\r
+<x> must be at least 4, <y> at least 2.\r
+`Terminal.resizeTo()' resets `Terminal.conf.rows', `Terminal.conf.cols',\r
+`Terminal.maxLines', and `Terminal.maxCols' to <y> and <x>, but leaves the instance' state\r
+else unchanged. Clears the terminal's screen and returns success.\r
+\r
+(A bit like `window.resizeTo()', but with rows and cols instead of px.)\r
+\r
+\r
+6.8 Terminal.getDimensions()\r
+\r
+Returns an object with properties "width" and "height" with numeric values for the\r
+terminal's outer dimensions in px. Values are zero (0) if the element is not present or\r
+if the method fails otherwise.\r
+\r
+\r
+6.9 Terminal.rebuild()\r
+\r
+Rebuilds the Terminal object's GUI preserving its state and content.\r
+Use this to change the color theme on the fly.\r
+\r
+p.e.:\r
+\r
+ // change color settings on the fly\r
+ // here: set bgColor to white and font style to "termWhite"\r
+ // method rebuild() updates the GUI without side effects\r
+\r
+ term.conf.bgColor = '#ffffff';\r
+ term.conf.fontClass = 'termWhite';\r
+ term.rebuild();\r
+\r
+\r
+\r
+\r
+7 Global Static Methods (TermGlobals)\r
+\r
+\r
+7.1 TermGlobals.setFocus( <termref> )\r
+\r
+Sets the keyboard focus to the instance referenced by <termref>.\r
+The focus is controlled by `TermGlobals.activeTerm' which may be accessed directly.\r
+See also: `Terminal.focus()'\r
+\r
+\r
+7.2 TermGlobals.keylock (Global Locking Flag)\r
+\r
+The global flag `TermGlobals.keylock' allows temporary keyboard locking without any\r
+other change of state. Use this to free the keyboard for any other resources.\r
+(added in v.1.03)\r
+\r
+\r
+7.3 TermGlobals Text Methods\r
+\r
+There is a small set of methods for common terminal related string tasks:\r
+\r
+\r
+7.3.1 TermGlobals.normalize( <n>, <fieldlength> )\r
+\r
+Converts a number to a string, which is filled at its left with zeros ("0") to the total\r
+length of <filedlength>. (e.g.: "TermGlobals.normalize(1, 2)" => "01")\r
+\r
+\r
+7.3.2 TermGlobals.fillLeft( <value>, <fieldlength> )\r
+\r
+Converts a value to a string and fills it to the left with blanks to <fieldlength>.\r
+\r
+\r
+7.3.3 TermGlobals.center( <text>, <length> )\r
+\r
+Adds blanks at the left of the string <text> until the text would be centered at a line\r
+of length <length>. (No blanks are added to the the right.)\r
+\r
+\r
+7.3.4 TermGlobals.stringReplace( <string1>, <string2>, <text> )\r
+\r
+Replaces all occurences of the string <string1> in <text> with <string2>.\r
+This is just a tiny work around for browsers with no support of RegExp.\r
+\r
+\r
+\r
+\r
+8 Localization\r
+\r
+The strings and key-codes used by the more utility of `Terminal.write()' are the only\r
+properties of "termlib.js" that may need localization. These properties are defined in\r
+`TermGlobals'. You may override them as needed:\r
+\r
+PROPERTY STANDARD VALUE COMMENT\r
+\r
+TermGlobals.lcMorePrompt1 ' -- MORE -- ' 1st string\r
+TermGlobals.lcMorePromtp1Style 1 reverse\r
+TermGlobals.lcMorePrompt2 ' (Type: space to continue, \'q\' to quit)' appended string\r
+TermGlobals.lcMorePrompt2Style 0 plain\r
+TermGlobals.lcMoreKeyAbort 113 (key-code: q)\r
+TermGlobals.lcMoreKeyContinue 32 (key-code <SPACE>)\r
+\r
+\r
+As "TermGlobals.lcMorePrompt2" is appended to "TermGlobals.lcMorePrompt1" make sure that\r
+the length of the combined strings does not exceed `Terminal.conf.cols'.\r
+\r
+\r
+\r
+\r
+9 Cross Browser Functions\r
+\r
+For DHTML rendering some methods - as needed by the Terminal library - are provided.\r
+These may also be accessed for other purposes.\r
+\r
+\r
+9.1 TermGlobals.writeElement( <element id>, <text> [,<NS4 parent document>] )\r
+\r
+Writes <text> to the DHTML element with id/name <element id>. \r
+<NS4 parent document> is used for NS4 only and specifies an optional reference to a parent\r
+document (default `window.document').\r
+\r
+9.2 TermGlobals.setElementXY( <element id>, <x>, <y> )\r
+\r
+Sets the DHTML element with id/name <element id> to position <x>/<y>.\r
+For NS4 works only with children of the top document (window.document).\r
+\r
+\r
+9.3 TermGlobals.setVisible( <element id>, <value> )\r
+\r
+If <value> evaluates to `true' show DHTML element with id/name <element id> else hide it.\r
+For NS4 works only with children of the top document (window.document).\r
+\r
+\r
+9.4 Custom Fixes for Missing String Methods\r
+\r
+Although `String.fromCharCode' and `String.prototype.charCodeAt' are defined by ECMA-262-2\r
+specifications, a few number of browsers lack them in their JavaScript implementation. At\r
+compile time custom methods are installed to fix this. Please note that they work only\r
+with ASCII characters and values in the range of [0x20-0xff].\r
+\r
+\r
+9.5 TermGlobals.setDisplay( <element id>, <value> )\r
+\r
+Sets the style.display property of the element with id/name <element id> to the given\r
+<value>. (added with v. 1.06)\r
+\r
+\r
+\r
+\r
+10 Architecture, Internals\r
+\r
+10.1 Global Entities\r
+\r
+The library is designed to leave only a small foot print in the namespace while providing\r
+suitable usability:\r
+\r
+ Globals defined in this library:\r
+\r
+ Terminal (Terminal object, `new' constructor and prototype methods)\r
+ TerminalDefaults (default configuration, static object)\r
+ termDefaultHandler (default command line handler, static function)\r
+ TermGlobals (common vars and code for all instances, static object and methods)\r
+ termKey (named mappings for special keys, static object)\r
+ termDomKeyRef (special key mapping for DOM key constants, static object)\r
+\r
+\r
+ Globals defined for fixing String methods, if missing\r
+ (String.fromCharCode, String.prototype.charCodeAt):\r
+\r
+ termString_keyref, termString_keycoderef, termString_makeKeyref\r
+\r
+ \r
+ Required CSS classes for font definitions: ".term", ".termReverse".\r
+\r
+\r
+\r
+10.2 I/O Architecture\r
+\r
+The Terminal object renders keyboard input from keyCodes to a line buffer and/or to a\r
+special keyCode buffer. In normal input mode printable input is echoed to the screen\r
+buffers. Special characters like <LEFT>, <RIGHT>, <BACKSPACE> are processed for command\r
+line editing by the internal key-handler `TermGlobals.keyHandler' and act directly on the\r
+screen buffers. On <CR> or <ENTER> the start and end positions of the current line are\r
+evaluated (terminated by ASCII 0x01 at the beginning which separates the prompt from the\r
+user input, and any value less than ASCII 0x20 (<SPACE>) at the right end). Then the\r
+character representation for the buffer values in this range are evaluated and\r
+concatenated to a string stored in `Terminal.lineBuffer'. As this involves some\r
+ASCII-to-String-transformations, the range of valid printable input characters is limited\r
+to the first page of unicode characters (0x0020-0x00ff).\r
+\r
+There are two screen buffers for output, one for character codes (ASCII values) and one\r
+for style codes. Style codes represent combination of styles as a bitvector (see\r
+`Terminal.type' for bit values.) The method `Terminal.redraw(<row>)' finally renders the\r
+buffers values to a string of HTML code, which is written to the HTML entity holding the\r
+according terminal row. The character buffer is a 2 dimensional array\r
+`Terminal.charBuf[<row>][<col>]' with ranges for <row> from 0 to less than\r
+`Terminal.conf.rows' and for <col> from 0 to less than `Terminal.conf.cols'. The style\r
+buffer is a 2 dimensional array `Terminal.styleBuf[<row>][<col>]' with according ranges.\r
+\r
+So every single character is represented by a ASCII code in `Terminal.charBuf' and a\r
+style-vector in `Terminal.styleBuf'. The range of printable character codes is unlimitted\r
+but should be kept to the first page of unicode characters (0x0020-0x00ff) for\r
+compatibility purpose. (c.f. 8.4)\r
+\r
+Keyboard input is first handled on the `KEYDOWN' event by the handler `TermGlobals.keyFix'\r
+to remap the keyCodes of cursor keys to consistent values. (To make them distinctable from\r
+any other possibly printable values, the values of POSIX <IS4> to <IS1> where chosen.)\r
+The mapping of the cursor keys is stored in the properties LEFT, RIGHT, UP, and DOWN of\r
+the global static object `termKey'.\r
+\r
+The main keyboard handler `TermGlobals.keyHandler' (invoked on `KEYPRESS' or by\r
+`TermGlobals.keyFix') does some final mapping first. Then the input is evaluated as\r
+controlled by the flags `Terminal.rawMode' and `Terminal.charMode' with precedence of the\r
+latter. In dependancy of the mode defined and the handlers currently defined, the input\r
+either is ignored, or is internally processed for command line editing, or one of the\r
+handlers is called.\r
+\r
+In the case of the simultanous presecence of two instances of Terminal, the keyboard focus\r
+is controlled via a reference stored in `TermGlobals.activeTerm'. This reference is also\r
+used to evaluate the `this'-context of the key handlers which are methods of the static\r
+Object `TermGlobals'.\r
+\r
+A terminal's screen consists of a HTML-table element residing in the HTML/CSS division\r
+spcified in `Terminal.conf.termDiv'. Any output is handled on a per row bases. The\r
+individual rows are either nested sub-divisions of the main divisions (used for NS4 or\r
+browsers not compatible to the "Gecko" engine) or the indiviual table data elements (<TD>)\r
+of the terminal's inner table (used for browsers employing the "Gecko" engine).\r
+(This implementation was chosen for rendering speed and in order to minimize any screen\r
+flicker.) Any output or change of state in a raw results in the inner HTML contents of a\r
+row's HTML element to be rewritten. Please note that as a result of this a blinking cursor\r
+may cause a flicker in the line containing the cursor's position while displayed by a\r
+browser, which employs the "Gecko" engine.\r
+\r
+\r
+\r
+10.3 Compatibility\r
+\r
+Standard web browsers with a JavaScript implementation compliant to ECMA-262 2nd edition\r
+[ECMA262-2] and support for the anonymous array and object constructs and the anonymous\r
+function construct in the form of "myfunc = function(x) {}" (c.f. ECMA-262 3rd edion\r
+[ECMA262-3] for details). This comprises almost all current browsers but Konquerer (khtml)\r
+and versions of Apple Safari for Mac OS 10.0-10.28 (Safari < 1.1) which lack support for\r
+keyboard events.\r
+\r
+To provide a maximum of compatibilty the extend of language keywords used was kept to a\r
+minimum and does not exceed the lexical conventions of ECMA-262-2. Especially there is no\r
+use of the `switch' statement or the `RegExp' method of the global object. Also the use of\r
+advanced Array methods like `push', `shift', `splice' was avoided.\r
+\r
+\r
+\r
+\r
+11 History\r
+\r
+This library evolved from the terminal script "TermApp" ((c) N. Landsteiner 2003) and is\r
+in its current form a down scaled spinn-off of the "JS/UIX" project [JS/UIX] (evolution\r
+"JS/UIX v0.5"). c.f.: <http://www.masswerk.at/jsuix>\r
+\r
+v 1.01: added Terminal.prototype.resizeTo(x,y)\r
+ added Terminal.conf.fontClass (=> configureable class name)\r
+ Terminal.prototype.open() now checks for element conf.termDiv in advance\r
+ and returns success.\r
+\r
+v 1.02: added support for <TAB> and Euro sign\r
+ Terminal.conf.printTab\r
+ Terminal.conf.printEuro\r
+ and method Terminal.prototype.isPrintable(keycode)\r
+ added support for getopt to sample parser ("parser_sample.html")\r
+\r
+\r
+v 1.03: added global keyboard locking (TermGlobals.keylock)\r
+ modified Terminal.prototype.redraw for speed (use of locals)\r
+\r
+\r
+v 1.04: modified the key handler to fix a bug with MSIE5/Mac\r
+ fixed a bug in TermGlobals.setVisible with older MSIE-alike browsers without\r
+ DOM support.\r
+ moved the script of the sample parser to an individual document\r
+ => "termlib_parser.js" (HTML document is "parser_sample.html" as before)\r
+\r
+v 1.05: added config flag historyUnique.\r
+\r
+v 1.06: fixed CTRl+ALT (Windows alt gr) isn't CTRL any more\r
+ -> better support for international keyboards with MSIE/Win.\r
+ fixed double backspace bug for Safari;\r
+ added TermGlobals.setDisplay for setting style.display props\r
+ termlib.js now outputs lower case html (xhtml compatibility)\r
+ (date: 12'2006)\r
+\r
+v 1.07: added method Terminal.rebuild() to rebuild the GUI with new color settings.\r
+ (date: 01'2007)\r
+\r
+\r
+\r
+\r
+12 Example for a Command Line Parser\r
+\r
+ // parser example, splits command line to args with quoting and escape\r
+ // for use as `Terminal.handler'\r
+ \r
+ function commandHandler() {\r
+ this.newLine();\r
+ var argv = ['']; // arguments vector\r
+ var argQL = ['']; // quoting level\r
+ var argc = 0; // arguments cursor\r
+ var escape = false ; // escape flag\r
+ for (var i=0; i<this.lineBuffer.length; i++) {\r
+ var ch= this.lineBuffer.charAt(i);\r
+ if (escape) {\r
+ argv[argc] += ch;\r
+ escape = false;\r
+ }\r
+ else if ((ch == '"') || (ch == "'") || (ch == "`")) {\r
+ if (argQL[argc]) {\r
+ if (argQL[argc] == ch) {\r
+ argc ++;\r
+ argv[argc] = argQL[argc] = '';\r
+ }\r
+ else {\r
+ argv[argc] += ch;\r
+ }\r
+ }\r
+ else {\r
+ if (argv[argc] != '') {\r
+ argc ++;\r
+ argv[argc] = '';\r
+ argQL[argc] = ch;\r
+ }\r
+ else {\r
+ argQL[argc] = ch;\r
+ }\r
+ }\r
+ }\r
+ else if ((ch == ' ') || (ch == '\t')) {\r
+ if (argQL[argc]) {\r
+ argv[argc] += ch;\r
+ }\r
+ else if (argv[argc] != '') {\r
+ argc++;\r
+ argv[argc] = argQL[argc] = '';\r
+ }\r
+ }\r
+ else if (ch == '\\') {\r
+ escape = true;\r
+ }\r
+ else {\r
+ argv[argc] += ch;\r
+ }\r
+ }\r
+ if ((argv[argc] == '') && (!argQL[argc])) {\r
+ argv.length--;\r
+ argQL.length--;\r
+ }\r
+ if (argv.length == 0) {\r
+ // no commmand line input\r
+ }\r
+ else if (argQL[0]) {\r
+ // first argument quoted -> error\r
+ this.write("Error: first argument quoted by "+argQL[0]);\r
+ }\r
+ else {\r
+ argc = 0;\r
+ var cmd = argv[argc++];\r
+ /*\r
+ parse commands\r
+ 1st argument is argv[argc]\r
+ arguments' quoting levels in argQL[argc] are of (<empty> | ' | " | `)\r
+ */\r
+ if (cmd == 'help') {\r
+ this.write(helpPage);\r
+ }\r
+ else if (cmd == 'clear') {\r
+ this.clear();\r
+ }\r
+ else if (cmd == 'exit') {\r
+ this.close();\r
+ return;\r
+ }\r
+ else {\r
+ // for test purpose just output argv as list\r
+ // assemple a string of style-escaped lines and output it in more-mode\r
+ s=' ARG QL VALUE%n';\r
+ for (var i=0; i<argv.length; i++) {\r
+ s += TermGlobals.stringReplace('%', '%%',\r
+ TermGlobals.fillLeft(i, 6) +\r
+ TermGlobals.fillLeft((argQL[i])? argQL[i]:'-', 4) +\r
+ ' "' + argv[i] + '"'\r
+ ) + '%n';\r
+ }\r
+ this.write(s, 1);\r
+ return;\r
+ }\r
+ }\r
+ this.prompt();\r
+ }\r
+\r
+\r
+The file "parser_sample.html" features a stand-alone parser ("termlib_parser.js") very\r
+much like this. You are free to use it according to the termlib-license (see sect. 13).\r
+It provides configurable values for quotes and esape characters and imports the parsed\r
+argument list into a Terminal instance's namespace. ("parser_sample.html" and\r
+"termlib_parser.js" should accompany this file.)\r
+\r
+\r
+\r
+\r
+13 License\r
+\r
+This JavaScript-library is free for private and academic use.\r
+Please include a readable copyright statement and a backlink to <http://www.masswerk.at>\r
+in the web page. The library should always be accompanied by the 'readme.txt' and the\r
+sample HTML-documents.\r
+\r
+The term "private use" includes any personal or non-commercial use, which is not related\r
+to commercial activites, but excludes intranet, extranet and/or public net applications\r
+that are related to any kind of commercial or profit oriented activity.\r
+\r
+For commercial use see <http://www.masswerk.at> for contact information.\r
+\r
+Any changes to the library should be commented and be documented in the readme-file.\r
+Any changes must be reflected in the `Terminal.version' string as\r
+"Version.Subversion (compatibility)".\r
+\r
+\r
+\r
+\r
+14 Disclaimer\r
+\r
+This software is distributed AS IS and in the hope that it will be useful, but WITHOUT ANY\r
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR\r
+PURPOSE. The entire risk as to the quality and performance of the product is borne by the\r
+user. No use of the product is authorized hereunder except under this disclaimer.\r
+\r
+\r
+\r
+\r
+15 References\r
+\r
+[ECMA262-2] "ECMAScript Language Specification" Standard ECMA-262 2nd Edition\r
+ August 1998 (ISO/IEC 16262 - April 1998)\r
+\r
+[ECMA262-3] "ECMAScript Language Specification" Standard ECMA-262 3rd Edition Final\r
+ 24 March 2000\r
+\r
+[JS/UIX] JS/UIX - JavaScript Uniplexed Interface eXtension\r
+ <http://www.masswerk.at/jsuix>\r
+\r
+\r
+\r
+\r
+\r
+Norbert Landsteiner / Vienna, August 2005\r
+mass:werk - media environments\r
+<http://www.masswerk.at>\r
+See web site for contact information.\r
--- /dev/null
+.term {\r
+ font-family: courier,fixed,swiss,sans-serif;\r
+ font-size: 12px;\r
+ color: #33d011;\r
+ background: none;\r
+}\r
+\r
+.termReverse {\r
+ color: #111111;\r
+ background: #33d011;\r
+}\r
--- /dev/null
+/*\r
+ termlib.js - JS-WebTerminal Object v1.07\r
+\r
+ (c) Norbert Landsteiner 2003-2005\r
+ mass:werk - media environments\r
+ <http://www.masswerk.at>\r
+\r
+ Creates [multiple] Terminal instances.\r
+\r
+ Synopsis:\r
+\r
+ myTerminal = new Terminal(<config object>);\r
+ myTerminal.open();\r
+\r
+ <config object> overrides any values of object `TerminalDefaults'.\r
+ individual values of `id' must be supplied for multiple terminals.\r
+ `handler' specifies a function to be called for input handling.\r
+ (see `Terminal.prototype.termDefaultHandler()' and documentation.)\r
+\r
+ globals defined in this library:\r
+ Terminal (Terminal object)\r
+ TerminalDefaults (default configuration)\r
+ termDefaultHandler (default command line handler)\r
+ TermGlobals (common vars and code for all instances)\r
+ termKey (named mappings for special keys)\r
+ termDomKeyRef (special key mapping for DOM constants)\r
+\r
+ globals defined for fixing String methods, if missing\r
+ (String.fromCharCode, String.prototype.charCodeAt):\r
+ termString_keyref, termString_keycoderef, termString_makeKeyref\r
+\r
+ required CSS classes for font definitions: ".term", ".termReverse".\r
+\r
+ Compatibilty:\r
+ Standard web browsers with a JavaScript implementation compliant to\r
+ ECMA-262 2nd edition and support for the anonymous array and object\r
+ constructs and the anonymous function construct in the form of\r
+ "myfunc=function(x) {}" (c.f. ECMA-262 3rd edion for details).\r
+ This comprises almost all current browsers but Konquerer (khtml) and\r
+ versions of Apple Safari for Mac OS 10.0-10.28 (Safari 1.0) which\r
+ lack support for keyboard events.\r
+\r
+ License:\r
+ This JavaScript-library is free for private and academic use.\r
+ Please include a readable copyright statement and a backlink to\r
+ <http://www.masswerk.at> in the web page.\r
+ The library should always be accompanied by the 'readme.txt' and the\r
+ sample HTML-documents.\r
+ \r
+ The term "private use" includes any personal or non-commercial use, which\r
+ is not related to commercial activites, but excludes intranet, extranet\r
+ and/or public net applications that are related to any kind of commercial\r
+ or profit oriented activity.\r
+\r
+ For commercial use see <http://www.masswerk.at> for contact information.\r
+ \r
+ Any changes should be commented and must be reflected in `Terminal.version'\r
+ in the format: "Version.Subversion (compatibility)".\r
+\r
+ Disclaimer:\r
+ This software is distributed AS IS and in the hope that it will be useful,\r
+ but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. The entire risk as to\r
+ the quality and performance of the product is borne by the user. No use of\r
+ the product is authorized hereunder except under this disclaimer.\r
+\r
+ ### The sections above must not be removed. ###\r
+ \r
+ version 1.01: added Terminal.prototype.resizeTo(x,y)\r
+ added Terminal.conf.fontClass (=> configureable class name)\r
+ Terminal.prototype.open() now checks for element conf.termDiv\r
+ in advance and returns success.\r
+\r
+ version 1.02: added support for <TAB> and Euro sign\r
+ (Terminal.conf.printTab, Terminal.conf.printEuro)\r
+ and a method to evaluate printable chars:\r
+ Terminal.prototype.isPrintable(keycode)\r
+\r
+ version 1.03: added global keyboard locking (TermGlobals.keylock)\r
+ modified Terminal.prototype.redraw for speed (use of locals)\r
+\r
+ version 1.04: modified the key handler to fix a bug with MSIE5/Mac\r
+ fixed a bug in TermGlobals.setVisible with older MSIE-alike\r
+ browsers without DOM support.\r
+\r
+ version 1.05: added config flag historyUnique.\r
+ \r
+ version 1.06: fixed CTRl+ALT (Windows alt gr) isn't CTRL any more\r
+ fixed double backspace bug for Safari;\r
+ added TermGlobals.setDisplay for setting style.display props\r
+ termlib.js now outputs lower case html (xhtml compatibility)\r
+\r
+ version 1.07: added method rebuild() to rebuild with new color settings.\r
+\r
+*/\r
+\r
+var TerminalDefaults = {\r
+ // dimensions\r
+ cols:80,\r
+ rows:24,\r
+ // appearance\r
+ x:100,\r
+ y:100,\r
+ termDiv:'termDiv',\r
+ bgColor:'#181818',\r
+ frameColor:'#555555',\r
+ frameWidth:1,\r
+ rowHeight:15,\r
+ blinkDelay:500,\r
+ // css class\r
+ fontClass:'term',\r
+ // initial cursor mode\r
+ crsrBlinkMode:false,\r
+ crsrBlockMode:true,\r
+ // key mapping\r
+ DELisBS:false,\r
+ printTab:true,\r
+ printEuro:true,\r
+ catchCtrlH:true,\r
+ closeOnESC:true,\r
+ // prevent consecutive history doublets\r
+ historyUnique:false,\r
+ // optional id\r
+ id:0,\r
+ // strings\r
+ ps:'>',\r
+ greeting:'%+r Terminal ready. %-r',\r
+ // handlers\r
+ handler:termDefaultHandler,\r
+ ctrlHandler:null,\r
+ initHandler:null,\r
+ exitHandler:null\r
+}\r
+\r
+var Terminal = function(conf) {\r
+ if (typeof conf != 'object') conf=new Object();\r
+ else {\r
+ for (var i in TerminalDefaults) {\r
+ if (typeof conf[i] == 'undefined') conf[i]=TerminalDefaults[i];\r
+ }\r
+ }\r
+ this.conf=conf;\r
+ this.version='1.07 (original)';\r
+ this.isSafari= (navigator.userAgent.indexOf('Safari')>=0)? true:false;\r
+ this.setInitValues();\r
+}\r
+\r
+Terminal.prototype.setInitValues=function() {\r
+ this.id=this.conf.id;\r
+ this.maxLines=this.conf.rows;\r
+ this.maxCols=this.conf.cols;\r
+ this.termDiv=this.conf.termDiv;\r
+ this.crsrBlinkMode=this.conf.crsrBlinkMode;\r
+ this.crsrBlockMode=this.conf.crsrBlockMode;\r
+ this.blinkDelay=this.conf.blinkDelay;\r
+ this.DELisBS=this.conf.DELisBS;\r
+ this.printTab=this.conf.printTab;\r
+ this.printEuro=this.conf.printEuro;\r
+ this.catchCtrlH=this.conf.catchCtrlH;\r
+ this.closeOnESC=this.conf.closeOnESC;\r
+ this.historyUnique=this.conf.historyUnique;\r
+ this.ps=this.conf.ps;\r
+ this.closed=false;\r
+ this.r;\r
+ this.c;\r
+ this.charBuf=new Array();\r
+ this.styleBuf=new Array();\r
+ this.scrollBuf=null;\r
+ this.blinkBuffer=0;\r
+ this.blinkTimer;\r
+ this.cursoractive=false;\r
+ this.lock=true;\r
+ this.insert=false;\r
+ this.charMode=false;\r
+ this.rawMode=false;\r
+ this.lineBuffer='';\r
+ this.inputChar=0;\r
+ this.lastLine='';\r
+ this.guiCounter=0;\r
+ this.history=new Array();\r
+ this.histPtr=0;\r
+ this.env=new Object();\r
+ this.ns4ParentDoc=null;\r
+ this.handler=this.conf.handler;\r
+ this.ctrlHandler=this.conf.ctrlHandler;\r
+ this.initHandler=this.conf.initHandler;\r
+ this.exitHandler=this.conf.exitHandler;\r
+}\r
+\r
+function termDefaultHandler() {\r
+ this.newLine();\r
+ if (this.lineBuffer != '') {\r
+ this.type('You typed: '+this.lineBuffer);\r
+ this.newLine();\r
+ }\r
+ this.prompt();\r
+}\r
+\r
+Terminal.prototype.open=function() {\r
+ if (this.termDivReady()) {\r
+ if (!this.closed) this._makeTerm();\r
+ this.init();\r
+ return true;\r
+ }\r
+ else return false;\r
+}\r
+\r
+Terminal.prototype.close=function() {\r
+ this.lock=true;\r
+ this.cursorOff();\r
+ if (this.exitHandler) this.exitHandler();\r
+ TermGlobals.setVisible(this.termDiv,0);\r
+ this.closed=true;\r
+}\r
+\r
+Terminal.prototype.init=function() {\r
+ // wait for gui\r
+ if (this.guiReady()) {\r
+ this.guiCounter=0;\r
+ // clean up at re-entry\r
+ if (this.closed) {\r
+ this.setInitValues();\r
+ }\r
+ this.clear();\r
+ TermGlobals.setVisible(this.termDiv,1);\r
+ TermGlobals.enableKeyboard(this);\r
+ if (this.initHandler) {\r
+ this.initHandler();\r
+ }\r
+ else {\r
+ this.write(this.conf.greeting);\r
+ this.newLine();\r
+ this.prompt();\r
+ }\r
+ }\r
+ else {\r
+ this.guiCounter++;\r
+ if (this.guiCounter>18000) {\r
+ if (confirm('Terminal:\nYour browser hasn\'t responded for more than 2 minutes.\nRetry?')) this.guiCounter=0\r
+ else return;\r
+ };\r
+ TermGlobals.termToInitialze=this;\r
+ window.setTimeout('TermGlobals.termToInitialze.init()',200);\r
+ }\r
+}\r
+\r
+Terminal.prototype.getRowArray=function(l,v) {\r
+ var a=new Array();\r
+ for (var i=0; i<l; i++) a[i]=v;\r
+ return a;\r
+}\r
+\r
+Terminal.prototype.type=function(text,style) {\r
+ for (var i=0; i<text.length; i++) {\r
+ var ch=text.charCodeAt(i);\r
+ if (!this.isPrintable(ch)) ch=94;\r
+ this.charBuf[this.r][this.c]=ch;\r
+ this.styleBuf[this.r][this.c]=(style)? style:0;\r
+ var last_r=this.r;\r
+ this._incCol();\r
+ if (this.r!=last_r) this.redraw(last_r);\r
+ }\r
+ this.redraw(this.r)\r
+}\r
+\r
+Terminal.prototype.write=function(text,usemore) {\r
+ // write to scroll buffer with markup\r
+ // new line = '%n' prepare any strings or arrys first\r
+ if (typeof text != 'object') {\r
+ if (typeof text!='string') text=''+text;\r
+ if (text.indexOf('\n')>=0) {\r
+ var ta=text.split('\n');\r
+ text=ta.join('%n');\r
+ }\r
+ }\r
+ else {\r
+ if (text.join) text=text.join('%n')\r
+ else text=''+text;\r
+ }\r
+ this._sbInit(usemore);\r
+ var chunks=text.split('%');\r
+ var esc=(text.charAt(0)!='%');\r
+ var style=0;\r
+ for (var i=0; i<chunks.length; i++) {\r
+ if (esc) {\r
+ if (chunks[i].length>0) this._sbType(chunks[i],style)\r
+ else if (i>0) this._sbType('%', style);\r
+ esc=false;\r
+ }\r
+ else {\r
+ var func=chunks[i].charAt(0);\r
+ if ((chunks[i].length==0) && (i>0)) {\r
+ this._sbType("%",style);\r
+ esc=true;\r
+ }\r
+ else if (func=='n') {\r
+ this._sbNewLine();\r
+ if (chunks[i].length>1) this._sbType(chunks[i].substring(1),style);\r
+ }\r
+ else if (func=='+') {\r
+ var opt=chunks[i].charAt(1);\r
+ opt=opt.toLowerCase();\r
+ if (opt=='p') style=0\r
+ else if (opt=='r') style|=1\r
+ else if (opt=='u') style|=2\r
+ else if (opt=='i') style|=4\r
+ else if (opt=='s') style|=8;\r
+ if (chunks[i].length>2) this._sbType(chunks[i].substring(2),style);\r
+ }\r
+ else if (func=='-') {\r
+ var opt=chunks[i].charAt(1);\r
+ opt=opt.toLowerCase();\r
+ if (opt=='p') style|=0\r
+ else if (opt=='r') style&=~1\r
+ else if (opt=='u') style&=~2\r
+ else if (opt=='i') style&=~4\r
+ else if (opt=='s') style&=~8;\r
+ if (chunks[i].length>2) this._sbType(chunks[i].substring(2),style);\r
+ }\r
+ else if ((chunks[i].length>1) && (chunks[i].charAt(0)=='C') && (chunks[i].charAt(1)=='S')) {\r
+ this.clear();\r
+ this._sbInit();\r
+ if (chunks[i].length>2) this._sbType(chunks[i].substring(2),style);\r
+ }\r
+ else {\r
+ if (chunks[i].length>0) this._sbType(chunks[i],style);\r
+ }\r
+ }\r
+ }\r
+ this._sbOut();\r
+}\r
+\r
+Terminal.prototype._sbType=function(text,style) {\r
+ // type to scroll buffer\r
+ var sb=this.scrollBuf;\r
+ for (var i=0; i<text.length; i++) {\r
+ var ch=text.charCodeAt(i);\r
+ if (!this.isPrintable(ch)) ch=94;\r
+ sb.lines[sb.r][sb.c]=ch;\r
+ sb.styles[sb.r][sb.c]=(style)? style:0;\r
+ sb.c++;\r
+ if (sb.c>=this.maxCols) this._sbNewLine();\r
+ }\r
+}\r
+\r
+Terminal.prototype._sbNewLine=function() {\r
+ var sb=this.scrollBuf;\r
+ sb.r++;\r
+ sb.c=0;\r
+ sb.lines[sb.r]=this.getRowArray(this.conf.cols,0);\r
+ sb.styles[sb.r]=this.getRowArray(this.conf.cols,0);\r
+}\r
+\r
+\r
+Terminal.prototype._sbInit=function(usemore) {\r
+ var sb=this.scrollBuf=new Object();\r
+ var sbl=sb.lines=new Array();\r
+ var sbs=sb.styles=new Array();\r
+ sb.more=usemore;\r
+ sb.line=0;\r
+ sb.status=0;\r
+ sb.r=0;\r
+ sb.c=this.c;\r
+ sbl[0]=this.getRowArray(this.conf.cols,0);\r
+ sbs[0]=this.getRowArray(this.conf.cols,0);\r
+ for (var i=0; i<this.c; i++) {\r
+ sbl[0][i]=this.charBuf[this.r][i];\r
+ sbs[0][i]=this.styleBuf[this.r][i];\r
+ }\r
+}\r
+\r
+Terminal.prototype._sbOut=function() {\r
+ var sb=this.scrollBuf;\r
+ var sbl=sb.lines;\r
+ var sbs=sb.styles;\r
+ var tcb=this.charBuf;\r
+ var tsb=this.styleBuf;\r
+ var ml=this.maxLines;\r
+ var buflen=sbl.length;\r
+ if (sb.more) {\r
+ if (sb.status) {\r
+ if (this.inputChar==TermGlobals.lcMoreKeyAbort) {\r
+ this.r=ml-1;\r
+ this.c=0;\r
+ tcb[this.r]=this.getRowArray(this.maxLines,0);\r
+ tsb[this.r]=this.getRowArray(this.maxLines,0);\r
+ this.redraw(this.r);\r
+ this.handler=sb.handler;\r
+ this.charMode=false;\r
+ this.inputChar=0;\r
+ this.scrollBuf=null;\r
+ this.prompt();\r
+ return;\r
+ }\r
+ else if (this.inputChar==TermGlobals.lcMoreKeyContinue) {\r
+ this.clear();\r
+ }\r
+ else {\r
+ return;\r
+ }\r
+ }\r
+ else {\r
+ if (this.r>=ml-1) this.clear();\r
+ }\r
+ }\r
+ if (this.r+buflen-sb.line<=ml) {\r
+ for (var i=sb.line; i<buflen; i++) {\r
+ var r=this.r+i-sb.line;\r
+ tcb[r]=sbl[i];\r
+ tsb[r]=sbs[i];\r
+ this.redraw(r);\r
+ }\r
+ this.r+=sb.r-sb.line;\r
+ this.c=sb.c;\r
+ if (sb.more) {\r
+ if (sb.status) this.handler=sb.handler;\r
+ this.charMode=false;\r
+ this.inputChar=0;\r
+ this.scrollBuf=null;\r
+ this.prompt();\r
+ return;\r
+ }\r
+ }\r
+ else if (sb.more) {\r
+ ml--;\r
+ if (sb.status==0) {\r
+ sb.handler=this.handler;\r
+ this.handler=this._sbOut;\r
+ this.charMode=true;\r
+ sb.status=1;\r
+ }\r
+ if (this.r) {\r
+ var ofs=ml-this.r;\r
+ for (var i=sb.line; i<ofs; i++) {\r
+ var r=this.r+i-sb.line;\r
+ tcb[r]=sbl[i];\r
+ tsb[r]=sbs[i];\r
+ this.redraw(r);\r
+ }\r
+ }\r
+ else {\r
+ var ofs=sb.line+ml;\r
+ for (var i=sb.line; i<ofs; i++) {\r
+ var r=this.r+i-sb.line;\r
+ tcb[r]=sbl[i];\r
+ tsb[r]=sbs[i];\r
+ this.redraw(r);\r
+ }\r
+ }\r
+ sb.line=ofs;\r
+ this.r=ml;\r
+ this.c=0;\r
+ this.type(TermGlobals.lcMorePrompt1, TermGlobals.lcMorePromtp1Style);\r
+ this.type(TermGlobals.lcMorePrompt2, TermGlobals.lcMorePrompt2Style);\r
+ this.lock=false;\r
+ return;\r
+ }\r
+ else if (buflen>=ml) {\r
+ var ofs=buflen-ml;\r
+ for (var i=0; i<ml; i++) {\r
+ var r=ofs+i;\r
+ tcb[i]=sbl[r];\r
+ tsb[i]=sbs[r];\r
+ this.redraw(i);\r
+ }\r
+ this.r=ml-1;\r
+ this.c=sb.c;\r
+ }\r
+ else {\r
+ var dr=ml-buflen;\r
+ var ofs=this.r-dr;\r
+ for (var i=0; i<dr; i++) {\r
+ var r=ofs+i;\r
+ for (var c=0; c<this.maxCols; c++) {\r
+ tcb[i][c]=tcb[r][c];\r
+ tsb[i][c]=tsb[r][c];\r
+ }\r
+ this.redraw(i);\r
+ }\r
+ for (var i=0; i<buflen; i++) {\r
+ var r=dr+i;\r
+ tcb[r]=sbl[i];\r
+ tsb[r]=sbs[i];\r
+ this.redraw(r);\r
+ }\r
+ this.r=ml-1;\r
+ this.c=sb.c;\r
+ }\r
+ this.scrollBuf=null;\r
+}\r
+\r
+// basic console output\r
+\r
+Terminal.prototype.typeAt=function(r,c,text,style) {\r
+ var tr1=this.r;\r
+ var tc1=this.c;\r
+ this.cursorSet(r,c);\r
+ for (var i=0; i<text.length; i++) {\r
+ var ch=text.charCodeAt(i);\r
+ if (!this.isPrintable(ch)) ch=94;\r
+ this.charBuf[this.r][this.c]=ch;\r
+ this.styleBuf[this.r][this.c]=(style)? style:0;\r
+ var last_r=this.r;\r
+ this._incCol();\r
+ if (this.r!=last_r) this.redraw(last_r);\r
+ }\r
+ this.redraw(this.r);\r
+ this.r=tr1;\r
+ this.c=tc1;\r
+}\r
+\r
+Terminal.prototype.statusLine = function(text,style,offset) {\r
+ var ch,r;\r
+ style=((style) && (!isNaN(style)))? parseInt(style)&15:0;\r
+ if ((offset) && (offset>0)) r=this.conf.rows-offset\r
+ else r=this.conf.rows-1;\r
+ for (var i=0; i<this.conf.cols; i++) {\r
+ if (i<text.length) {\r
+ ch=text.charCodeAt(i);\r
+ if (!this.isPrintable(ch)) ch = 94;\r
+ }\r
+ else ch=0;\r
+ this.charBuf[r][i]=ch;\r
+ this.styleBuf[r][i]=style;\r
+ }\r
+ this.redraw(r);\r
+}\r
+\r
+Terminal.prototype.printRowFromString = function(r,text,style) {\r
+ var ch;\r
+ style=((style) && (!isNaN(style)))? parseInt(style)&15:0;\r
+ if ((r>=0) && (r<this.maxLines)) {\r
+ if (typeof text != 'string') text=''+text;\r
+ for (var i=0; i<this.conf.cols; i++) {\r
+ if (i<text.length) {\r
+ ch=text.charCodeAt(i);\r
+ if (!this.isPrintable(ch)) ch = 94;\r
+ }\r
+ else ch=0;\r
+ this.charBuf[r][i]=ch;\r
+ this.styleBuf[r][i]=style;\r
+ }\r
+ this.redraw(r);\r
+ }\r
+}\r
+\r
+Terminal.prototype.setChar=function(ch,r,c,style) {\r
+ this.charBuf[r][c]=ch;\r
+ this.styleBuf[this.r][this.c]=(style)? style:0;\r
+ this.redraw(r);\r
+}\r
+\r
+Terminal.prototype._charOut=function(ch, style) {\r
+ this.charBuf[this.r][this.c]=ch;\r
+ this.styleBuf[this.r][this.c]=(style)? style:0;\r
+ this.redraw(this.r);\r
+ this._incCol();\r
+}\r
+\r
+Terminal.prototype._incCol=function() {\r
+ this.c++;\r
+ if (this.c>=this.maxCols) {\r
+ this.c=0;\r
+ this._incRow();\r
+ }\r
+}\r
+\r
+Terminal.prototype._incRow=function() {\r
+ this.r++;\r
+ if (this.r>=this.maxLines) {\r
+ this._scrollLines(0,this.maxLines);\r
+ this.r=this.maxLines-1;\r
+ }\r
+}\r
+\r
+Terminal.prototype._scrollLines=function(start, end) {\r
+ window.status='Scrolling lines ...';\r
+ start++;\r
+ for (var ri=start; ri<end; ri++) {\r
+ var rt=ri-1;\r
+ this.charBuf[rt]=this.charBuf[ri];\r
+ this.styleBuf[rt]=this.styleBuf[ri];\r
+ }\r
+ // clear last line\r
+ var rt=end-1;\r
+ this.charBuf[rt]=this.getRowArray(this.conf.cols,0);\r
+ this.styleBuf[rt]=this.getRowArray(this.conf.cols,0);\r
+ this.redraw(rt);\r
+ for (var r=end-1; r>=start; r--) this.redraw(r-1);\r
+ window.status='';\r
+}\r
+\r
+Terminal.prototype.newLine=function() {\r
+ this.c=0;\r
+ this._incRow();\r
+}\r
+\r
+Terminal.prototype.clear=function() {\r
+ window.status='Clearing display ...';\r
+ this.cursorOff();\r
+ this.insert=false;\r
+ for (var ri=0; ri<this.maxLines; ri++) {\r
+ this.charBuf[ri]=this.getRowArray(this.conf.cols,0);\r
+ this.styleBuf[ri]=this.getRowArray(this.conf.cols,0);\r
+ this.redraw(ri);\r
+ }\r
+ this.r=0;\r
+ this.c=0;\r
+ window.status='';\r
+}\r
+\r
+Terminal.prototype.reset=function() {\r
+ if (this.lock) return;\r
+ this.lock=true;\r
+ this.rawMode=false;\r
+ this.charMode=false;\r
+ this.maxLines=this.conf.rows;\r
+ this.maxCols=this.conf.cols;\r
+ this.lastLine='';\r
+ this.lineBuffer='';\r
+ this.inputChar=0;\r
+ this.clear();\r
+}\r
+\r
+Terminal.prototype.cursorSet=function(r,c) {\r
+ var crsron=this.cursoractive;\r
+ if (crsron) this.cursorOff();\r
+ this.r=r%this.maxLines;\r
+ this.c=c%this.maxCols;\r
+ this._cursorReset(crsron);\r
+}\r
+\r
+Terminal.prototype._cursorReset=function(crsron) {\r
+ if (crsron) this.cursorOn()\r
+ else {\r
+ this.blinkBuffer=this.styleBuf[this.r][this.c];\r
+ }\r
+}\r
+\r
+Terminal.prototype.cursorOn=function() {\r
+ if (this.blinkTimer) clearTimeout(this.blinkTimer);\r
+ this.blinkBuffer=this.styleBuf[this.r][this.c];\r
+ this._cursorBlink();\r
+ this.cursoractive=true;\r
+}\r
+\r
+Terminal.prototype.cursorOff=function() {\r
+ if (this.blinkTimer) clearTimeout(this.blinkTimer);\r
+ if (this.cursoractive) {\r
+ this.styleBuf[this.r][this.c]=this.blinkBuffer;\r
+ this.redraw(this.r);\r
+ this.cursoractive=false;\r
+ }\r
+}\r
+\r
+Terminal.prototype._cursorBlink=function() {\r
+ if (this.blinkTimer) clearTimeout(this.blinkTimer);\r
+ if (this == TermGlobals.activeTerm) {\r
+ if (this.crsrBlockMode) {\r
+ this.styleBuf[this.r][this.c]=(this.styleBuf[this.r][this.c]&1)?\r
+ this.styleBuf[this.r][this.c]&254:this.styleBuf[this.r][this.c]|1;\r
+ }\r
+ else {\r
+ this.styleBuf[this.r][this.c]=(this.styleBuf[this.r][this.c]&2)?\r
+ this.styleBuf[this.r][this.c]&253:this.styleBuf[this.r][this.c]|2;\r
+ }\r
+ this.redraw(this.r);\r
+ }\r
+ if (this.crsrBlinkMode) this.blinkTimer=setTimeout('TermGlobals.activeTerm._cursorBlink()', this.blinkDelay);\r
+}\r
+\r
+Terminal.prototype.cursorLeft=function() {\r
+ var crsron=this.cursoractive;\r
+ if (crsron) this.cursorOff();\r
+ var r=this.r;\r
+ var c=this.c;\r
+ if (c>0) c--\r
+ else if (r>0) {\r
+ c=this.maxCols-1;\r
+ r--;\r
+ }\r
+ if (this.isPrintable(this.charBuf[r][c])) {\r
+ this.r=r;\r
+ this.c=c;\r
+ }\r
+ this.insert=true;\r
+ this._cursorReset(crsron);\r
+}\r
+\r
+Terminal.prototype.cursorRight=function() {\r
+ var crsron=this.cursoractive;\r
+ if (crsron) this.cursorOff();\r
+ var r=this.r;\r
+ var c=this.c;\r
+ if (c<this.maxCols-1) c++\r
+ else if (r<this.maxLines-1) {\r
+ c=0;\r
+ r++;\r
+ }\r
+ if (!this.isPrintable(this.charBuf[r][c])) {\r
+ this.insert=false;\r
+ }\r
+ if (this.isPrintable(this.charBuf[this.r][this.c])) {\r
+ this.r=r;\r
+ this.c=c;\r
+ }\r
+ this._cursorReset(crsron);\r
+}\r
+\r
+Terminal.prototype.backspace=function() {\r
+ var crsron=this.cursoractive;\r
+ if (crsron) this.cursorOff();\r
+ var r=this.r;\r
+ var c=this.c;\r
+ if (c>0) c--\r
+ else if (r>0) {\r
+ c=this.maxCols-1;\r
+ r--;\r
+ };\r
+ if (this.isPrintable(this.charBuf[r][c])) {\r
+ this._scrollLeft(r, c);\r
+ this.r=r;\r
+ this.c=c;\r
+ }; \r
+ this._cursorReset(crsron);\r
+}\r
+\r
+Terminal.prototype.fwdDelete=function() {\r
+ var crsron=this.cursoractive;\r
+ if (crsron) this.cursorOff();\r
+ if (this.isPrintable(this.charBuf[this.r][this.c])) {\r
+ this._scrollLeft(this.r,this.c);\r
+ if (!this.isPrintable(this.charBuf[this.r][this.c])) this.insert=false;\r
+ }\r
+ this._cursorReset(crsron);\r
+}\r
+\r
+Terminal.prototype.prompt=function() {\r
+ this.lock=true;\r
+ if (this.c>0) this.newLine();\r
+ this.type(this.ps);\r
+ this._charOut(1);\r
+ this.lock=false;\r
+ this.cursorOn();\r
+}\r
+\r
+Terminal.prototype._scrollLeft=function(r,c) {\r
+ var rows=new Array();\r
+ rows[0]=r;\r
+ while (this.isPrintable(this.charBuf[r][c])) {\r
+ var ri=r;\r
+ var ci=c+1;\r
+ if (ci==this.maxCols) {\r
+ if (ri<this.maxLines-1) {\r
+ ci=0;\r
+ ri++;\r
+ rows[rows.length]=ri;\r
+ }\r
+ else {\r
+ break;\r
+ }\r
+ }\r
+ this.charBuf[r][c]=this.charBuf[ri][ci];\r
+ this.styleBuf[r][c]=this.styleBuf[ri][ci];\r
+ c=ci;\r
+ r=ri;\r
+ }\r
+ if (this.charBuf[r][c]!=0) this.charBuf[r][c]=0;\r
+ for (var i=0; i<rows.length; i++) this.redraw(rows[i]);\r
+}\r
+\r
+Terminal.prototype._scrollRight=function(r,c) {\r
+ var rows=new Array();\r
+ var end=this._getLineEnd(r,c);\r
+ var ri=end[0];\r
+ var ci=end[1];\r
+ if ((ci==this.maxCols-1) && (ri==this.maxLines-1)) {\r
+ if (r==0) return;\r
+ this._scrollLines(0,this.maxLines);\r
+ this.r--;\r
+ r--;\r
+ ri--;\r
+ }\r
+ rows[r]=1;\r
+ while (this.isPrintable(this.charBuf[ri][ci])) {\r
+ var rt=ri;\r
+ var ct=ci+1;\r
+ if (ct==this.maxCols) {\r
+ ct=0;\r
+ rt++;\r
+ rows[rt]=1;\r
+ }\r
+ this.charBuf[rt][ct]=this.charBuf[ri][ci];\r
+ this.styleBuf[rt][ct]=this.styleBuf[ri][ci];\r
+ if ((ri==r) && (ci==c)) break;\r
+ ci--;\r
+ if (ci<0) {\r
+ ci=this.maxCols-1;\r
+ ri--;\r
+ rows[ri]=1;\r
+ }\r
+ }\r
+ for (var i=r; i<this.maxLines; i++) {\r
+ if (rows[i]) this.redraw(i);\r
+ }\r
+}\r
+\r
+Terminal.prototype._getLineEnd=function(r,c) {\r
+ if (!this.isPrintable(this.charBuf[r][c])) {\r
+ c--;\r
+ if (c<0) {\r
+ if (r>0) {\r
+ r--;\r
+ c=this.maxCols-1;\r
+ }\r
+ else {\r
+ c=0;\r
+ }\r
+ }\r
+ }\r
+ if (this.isPrintable(this.charBuf[r][c])) {\r
+ while (true) {\r
+ var ri=r;\r
+ var ci=c+1;\r
+ if (ci==this.maxCols) {\r
+ if (ri<this.maxLines-1) {\r
+ ri++;\r
+ ci=0;\r
+ }\r
+ else {\r
+ break;\r
+ }\r
+ }\r
+ if (!this.isPrintable(this.charBuf[ri][ci])) break;\r
+ c=ci;\r
+ r=ri;\r
+ }\r
+ }\r
+ return [r,c];\r
+}\r
+\r
+Terminal.prototype._getLineStart=function(r,c) {\r
+ // not used by now, just in case anyone needs this ...\r
+ var ci, ri;\r
+ if (!this.isPrintable(this.charBuf[r][c])) {\r
+ ci=c-1;\r
+ ri=r;\r
+ if (ci<0) {\r
+ if (ri==0) return [0,0];\r
+ ci=this.maxCols-1;\r
+ ri--;\r
+ }\r
+ if (!this.isPrintable(this.charBuf[ri][ci])) return [r,c]\r
+ else {\r
+ r=ri;\r
+ c=ci;\r
+ }\r
+ }\r
+ while (true) {\r
+ var ri=r;\r
+ var ci=c-1;\r
+ if (ci<0) {\r
+ if (ri==0) break;\r
+ ci=this.maxCols-1;\r
+ ri--;\r
+ }\r
+ if (!this.isPrintable(this.charBuf[ri][ci])) break;;\r
+ r=ri;\r
+ c=ci;\r
+ }\r
+ return [r,c];\r
+}\r
+\r
+Terminal.prototype._getLine=function() {\r
+ var end=this._getLineEnd(this.r,this.c);\r
+ var r=end[0];\r
+ var c=end[1];\r
+ var line=new Array();\r
+ while (this.isPrintable(this.charBuf[r][c])) {\r
+ line[line.length]=String.fromCharCode(this.charBuf[r][c]);\r
+ if (c>0) c--\r
+ else if (r>0) {\r
+ c=this.maxCols-1;\r
+ r--;\r
+ }\r
+ else break;\r
+ }\r
+ line.reverse();\r
+ return line.join('');\r
+}\r
+\r
+Terminal.prototype._clearLine=function() {\r
+ var end=this._getLineEnd(this.r,this.c);\r
+ var r=end[0];\r
+ var c=end[1];\r
+ var line='';\r
+ while (this.isPrintable(this.charBuf[r][c])) {\r
+ this.charBuf[r][c]=0;\r
+ if (c>0) {\r
+ c--;\r
+ }\r
+ else if (r>0) {\r
+ this.redraw(r);\r
+ c=this.maxCols-1;\r
+ r--;\r
+ }\r
+ else break;\r
+ }\r
+ if (r!=end[0]) this.redraw(r);\r
+ c++;\r
+ this.cursorSet(r,c);\r
+ this.insert=false;\r
+}\r
+\r
+Terminal.prototype.isPrintable=function(ch, unicodePage1only) {\r
+ if ((unicodePage1only) && (ch>255)) {\r
+ return ((ch==termKey.EURO) && (this.printEuro))? true:false;\r
+ }\r
+ return (\r
+ ((ch>=32) && (ch!=termKey.DEL)) ||\r
+ ((this.printTab) && (ch==termKey.TAB))\r
+ );\r
+}\r
+\r
+// keyboard focus\r
+\r
+Terminal.prototype.focus=function() {\r
+ TermGlobals.activeTerm=this;\r
+}\r
+\r
+// global store and functions\r
+\r
+var TermGlobals={\r
+ termToInitialze:null,\r
+ activeTerm:null,\r
+ kbdEnabled:false,\r
+ keylock:false,\r
+ lcMorePrompt1: ' -- MORE -- ',\r
+ lcMorePromtp1Style: 1,\r
+ lcMorePrompt2: ' (Type: space to continue, \'q\' to quit)',\r
+ lcMorePrompt2Style: 0,\r
+ lcMoreKeyAbort: 113,\r
+ lcMoreKeyContinue: 32\r
+};\r
+\r
+// keybard focus\r
+\r
+TermGlobals.setFocus=function(termref) {\r
+ TermGlobals.activeTerm=termref;\r
+}\r
+\r
+// text related\r
+\r
+TermGlobals.normalize=function(n,m) {\r
+ var s=''+n;\r
+ while (s.length<m) s='0'+s;\r
+ return s;\r
+}\r
+\r
+TermGlobals.fillLeft=function(t,n) {\r
+ if (typeof t != 'string') t=''+t;\r
+ while (t.length<n) t=' '+t;\r
+ return t;\r
+}\r
+\r
+TermGlobals.center=function(t,l) {\r
+ var s='';\r
+ for (var i=t.length; i<l; i+=2) s+=' ';\r
+ return s+t;\r
+}\r
+\r
+TermGlobals.stringReplace=function(s1,s2,t) {\r
+ var l1=s1.length;\r
+ var l2=s2.length;\r
+ var ofs=t.indexOf(s1);\r
+ while (ofs>=0) {\r
+ t=t.substring(0,ofs)+s2+t.substring(ofs+l1);\r
+ ofs=t.indexOf(s1,ofs+l2);\r
+ }\r
+ return t;\r
+}\r
+\r
+// keyboard\r
+\r
+var termKey= {\r
+ // special key codes\r
+ 'NUL': 0x00,\r
+ 'SOH': 0x01,\r
+ 'STX': 0x02,\r
+ 'ETX': 0x03,\r
+ 'EOT': 0x04,\r
+ 'ENQ': 0x05,\r
+ 'ACK': 0x06,\r
+ 'BEL': 0x07,\r
+ 'BS': 0x08,\r
+ 'HT': 0x09,\r
+ 'TAB': 0x09,\r
+ 'LF': 0x0A,\r
+ 'VT': 0x0B,\r
+ 'FF': 0x0C,\r
+ 'CR': 0x0D,\r
+ 'SO': 0x0E,\r
+ 'SI': 0x0F,\r
+ 'DLE': 0x10,\r
+ 'DC1': 0x11,\r
+ 'DC2': 0x12,\r
+ 'DC3': 0x13,\r
+ 'DC4': 0x14,\r
+ 'NAK': 0x15,\r
+ 'SYN': 0x16,\r
+ 'ETB': 0x17,\r
+ 'CAN': 0x18,\r
+ 'EM': 0x19,\r
+ 'SUB': 0x1A,\r
+ 'ESC': 0x1B,\r
+ 'IS4': 0x1C,\r
+ 'IS3': 0x1D,\r
+ 'IS2': 0x1E,\r
+ 'IS1': 0x1F,\r
+ 'DEL': 0x7F,\r
+ // other specials\r
+ 'EURO': 0x20AC,\r
+ // cursor mapping\r
+ 'LEFT': 0x1C,\r
+ 'RIGHT': 0x1D,\r
+ 'UP': 0x1E,\r
+ 'DOWN': 0x1F\r
+};\r
+\r
+var termDomKeyRef = {\r
+ DOM_VK_LEFT: termKey.LEFT,\r
+ DOM_VK_RIGHT: termKey.RIGHT,\r
+ DOM_VK_UP: termKey.UP,\r
+ DOM_VK_DOWN: termKey.DOWN,\r
+ DOM_VK_BACK_SPACE: termKey.BS,\r
+ DOM_VK_RETURN: termKey.CR,\r
+ DOM_VK_ENTER: termKey.CR,\r
+ DOM_VK_ESCAPE: termKey.ESC,\r
+ DOM_VK_DELETE: termKey.DEL,\r
+ DOM_VK_TAB: termKey.TAB\r
+};\r
+\r
+TermGlobals.enableKeyboard=function(term) {\r
+ if (!this.kbdEnabled) {\r
+ if (document.addEventListener) document.addEventListener("keypress", this.keyHandler, true)\r
+ else {\r
+ if ((self.Event) && (self.Event.KEYPRESS)) document.captureEvents(Event.KEYPRESS);\r
+ document.onkeypress = this.keyHandler;\r
+ }\r
+ window.document.onkeydown=this.keyFix;\r
+ this.kbdEnabled=true;\r
+ }\r
+ this.activeTerm=term;\r
+}\r
+\r
+TermGlobals.keyFix=function(e) {\r
+ var term=TermGlobals.activeTerm;\r
+ if ((TermGlobals.keylock) || (term.lock)) return true;\r
+ if (window.event) {\r
+ var ch=window.event.keyCode;\r
+ if (!e) e=window.event;\r
+ if (e.DOM_VK_UP) {\r
+ for (var i in termDomKeyRef) {\r
+ if ((e[i]) && (ch == e[i])) {\r
+ this.keyHandler({which:termDomKeyRef[i],_remapped:true});\r
+ if (e.preventDefault) e.preventDefault();\r
+ if (e.stopPropagation) e.stopPropagation();\r
+ e.cancleBubble=true;\r
+ return false;\r
+ }\r
+ }\r
+ e.cancleBubble=false;\r
+ return true;\r
+ }\r
+ else {\r
+ // no DOM support\r
+ if ((ch==8) && (!term.isSafari)) TermGlobals.keyHandler({which:termKey.BS,_remapped:true})\r
+ else if (ch==9) TermGlobals.keyHandler({which:termKey.TAB,_remapped:true})\r
+ else if (ch==37) TermGlobals.keyHandler({which:termKey.LEFT,_remapped:true})\r
+ else if (ch==39) TermGlobals.keyHandler({which:termKey.RIGHT,_remapped:true})\r
+ else if (ch==38) TermGlobals.keyHandler({which:termKey.UP,_remapped:true})\r
+ else if (ch==40) TermGlobals.keyHandler({which:termKey.DOWN,_remapped:true})\r
+ else if (ch==127) TermGlobals.keyHandler({which:termKey.DEL,_remapped:true})\r
+ else if ((ch>=57373) && (ch<=57376)) {\r
+ if (ch==57373) TermGlobals.keyHandler({which:termKey.UP,_remapped:true})\r
+ else if (ch==57374) TermGlobals.keyHandler({which:termKey.DOWN,_remapped:true})\r
+ else if (ch==57375) TermGlobals.keyHandler({which:termKey.LEFT,_remapped:true})\r
+ else if (ch==57376) TermGlobals.keyHandler({which:termKey.RIGHT,_remapped:true});\r
+ }\r
+ else {\r
+ e.cancleBubble=false;\r
+ return true;\r
+ }\r
+ if (e.preventDefault) e.preventDefault();\r
+ if (e.stopPropagation) e.stopPropagation();\r
+ e.cancleBubble=true;\r
+ return false;\r
+ }\r
+ }\r
+}\r
+\r
+TermGlobals.keyHandler=function(e) {\r
+ var term=TermGlobals.activeTerm;\r
+ if ((TermGlobals.keylock) || (term.lock)) return true;\r
+ if ((window.event) && (window.event.preventDefault)) window.event.preventDefault()\r
+ else if ((e) && (e.preventDefault)) e.preventDefault();\r
+ if ((window.event) && (window.event.stopPropagation)) window.event.stopPropagation()\r
+ else if ((e) && (e.stopPropagation)) e.stopPropagation();\r
+ var ch;\r
+ var ctrl=false;\r
+ var shft=false;\r
+ var remapped=false;\r
+ if (e) {\r
+ ch=e.which;\r
+ ctrl=(((e.ctrlKey) && (e.altKey)) || (e.modifiers==2));\r
+ shft=((e.shiftKey) || (e.modifiers==4));\r
+ if (e._remapped) {\r
+ remapped=true;\r
+ if (window.event) {\r
+ //ctrl=((ctrl) || (window.event.ctrlKey));\r
+ ctrl=((ctrl) || ((window.event.ctrlKey) && (!window.event.altKey)));\r
+ shft=((shft) || (window.event.shiftKey));\r
+ }\r
+ }\r
+ }\r
+ else if (window.event) {\r
+ ch=window.event.keyCode;\r
+ //ctrl=(window.event.ctrlKey);\r
+ ctrl=((window.event.ctrlKey) && (!window.event.altKey)); // allow alt gr == ctrl alts\r
+ shft=(window.event.shiftKey);\r
+ }\r
+ else {\r
+ return true;\r
+ }\r
+ if ((ch=='') && (remapped==false)) {\r
+ // map specials\r
+ if (e==null) e=window.event;\r
+ if ((e.charCode==0) && (e.keyCode)) {\r
+ if (e.DOM_VK_UP) {\r
+ for (var i in termDomKeyRef) {\r
+ if ((e[i]) && (e.keyCode == e[i])) {\r
+ ch=termDomKeyRef[i];\r
+ break;\r
+ }\r
+ }\r
+ }\r
+ else {\r
+ // NS4\r
+ if (e.keyCode==28) ch=termKey.LEFT\r
+ else if (e.keyCode==29) ch=termKey.RIGHT\r
+ else if (e.keyCode==30) ch=termKey.UP\r
+ else if (e.keyCode==31) ch=termKey.DOWN\r
+ // Mozilla alike but no DOM support\r
+ else if (e.keyCode==37) ch=termKey.LEFT\r
+ else if (e.keyCode==39) ch=termKey.RIGHT\r
+ else if (e.keyCode==38) ch=termKey.UP\r
+ else if (e.keyCode==40) ch=termKey.DOWN\r
+ // just to have the TAB mapping here too\r
+ else if (e.keyCode==9) ch=termKey.TAB;\r
+ }\r
+ }\r
+ }\r
+ // key actions\r
+ if (term.charMode) {\r
+ term.insert=false;\r
+ term.inputChar=ch;\r
+ term.lineBuffer='';\r
+ term.handler();\r
+ if ((ch<=32) && (window.event)) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ if (!ctrl) {\r
+ // special keys\r
+ if (ch==termKey.CR) {\r
+ term.lock=true;\r
+ term.cursorOff();\r
+ term.insert=false;\r
+ if (term.rawMode) {\r
+ term.lineBuffer=term.lastLine;\r
+ }\r
+ else {\r
+ term.lineBuffer=term._getLine();\r
+ if (\r
+ (term.lineBuffer!='') && ((!term.historyUnique) ||\r
+ (term.history.length==0) ||\r
+ (term.lineBuffer!=term.history[term.history.length-1]))\r
+ ) {\r
+ term.history[term.history.length]=term.lineBuffer;\r
+ }\r
+ term.histPtr=term.history.length;\r
+ }\r
+ term.lastLine='';\r
+ term.inputChar=0;\r
+ term.handler();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (ch==termKey.ESC) {\r
+ if (term.conf.closeOnESC) term.close();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ if ((ch<32) && (term.rawMode)) {\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else {\r
+ if (ch==termKey.LEFT) {\r
+ term.cursorLeft();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (ch==termKey.RIGHT) {\r
+ term.cursorRight();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (ch==termKey.UP) {\r
+ term.cursorOff();\r
+ if (term.histPtr==term.history.length) term.lastLine=term._getLine();\r
+ term._clearLine();\r
+ if ((term.history.length) && (term.histPtr>=0)) {\r
+ if (term.histPtr>0) term.histPtr--;\r
+ term.type(term.history[term.histPtr]);\r
+ }\r
+ else if (term.lastLine) term.type(term.lastLine);\r
+ term.cursorOn();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (ch==termKey.DOWN) {\r
+ term.cursorOff();\r
+ if (term.histPtr==term.history.length) term.lastLine=term._getLine();\r
+ term._clearLine();\r
+ if ((term.history.length) && (term.histPtr<=term.history.length)) {\r
+ if (term.histPtr<term.history.length) term.histPtr++;\r
+ if (term.histPtr<term.history.length) term.type(term.history[term.histPtr])\r
+ else if (term.lastLine) term.type(term.lastLine);\r
+ }\r
+ else if (term.lastLine) term.type(term.lastLine);\r
+ term.cursorOn();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (ch==termKey.BS) {\r
+ term.backspace();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (ch==termKey.DEL) {\r
+ if (term.DELisBS) term.backspace()\r
+ else term.fwdDelete();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ }\r
+ }\r
+ if (term.rawMode) {\r
+ if (term.isPrintable(ch)) {\r
+ term.lastLine+=String.fromCharCode(ch);\r
+ }\r
+ if ((ch==32) && (window.event)) window.event.cancleBubble=true\r
+ else if ((window.opera) && (window.event)) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else {\r
+ if ((term.conf.catchCtrlH) && ((ch==termKey.BS) || ((ctrl) && (ch==72)))) {\r
+ // catch ^H\r
+ term.backspace();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if ((term.ctrlHandler) && ((ch<32) || ((ctrl) && (term.isPrintable(ch,true))))) {\r
+ if (((ch>=65) && (ch<=96)) || (ch==63)) {\r
+ // remap canonical\r
+ if (ch==63) ch=31\r
+ else ch-=64;\r
+ }\r
+ term.inputChar=ch;\r
+ term.ctrlHandler();\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if ((ctrl) || (!term.isPrintable(ch,true))) {\r
+ if (window.event) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ else if (term.isPrintable(ch,true)) {\r
+ if (term.blinkTimer) clearTimeout(term.blinkTimer);\r
+ if (term.insert) {\r
+ term.cursorOff();\r
+ term._scrollRight(term.r,term.c);\r
+ }\r
+ term._charOut(ch);\r
+ term.cursorOn();\r
+ if ((ch==32) && (window.event)) window.event.cancleBubble=true\r
+ else if ((window.opera) && (window.event)) window.event.cancleBubble=true;\r
+ return false;\r
+ }\r
+ }\r
+ return true;\r
+}\r
+\r
+// term gui\r
+\r
+TermGlobals.hasSubDivs=false;\r
+TermGlobals.hasLayers=false;\r
+TermGlobals.termStringStart='';\r
+TermGlobals.termStringEnd='';\r
+\r
+TermGlobals.termSpecials=new Array();\r
+TermGlobals.termSpecials[0]=' ';\r
+TermGlobals.termSpecials[1]=' ';\r
+TermGlobals.termSpecials[9]=' ';\r
+TermGlobals.termSpecials[32]=' ';\r
+TermGlobals.termSpecials[34]='"';\r
+TermGlobals.termSpecials[38]='&';\r
+TermGlobals.termSpecials[60]='<';\r
+TermGlobals.termSpecials[62]='>';\r
+TermGlobals.termSpecials[127]='◊';\r
+TermGlobals.termSpecials[0x20AC]='€';\r
+\r
+TermGlobals.termStyles=new Array(1,2,4,8);\r
+TermGlobals.termStyleOpen=new Array();\r
+TermGlobals.termStyleClose=new Array();\r
+TermGlobals.termStyleOpen[1]='<span class="termReverse">';\r
+TermGlobals.termStyleClose[1]='<\/span>';\r
+TermGlobals.termStyleOpen[2]='<u>';\r
+TermGlobals.termStyleClose[2]='<\/u>';\r
+TermGlobals.termStyleOpen[4]='<i>';\r
+TermGlobals.termStyleClose[4]='<\/i>';\r
+TermGlobals.termStyleOpen[8]='<strike>';\r
+TermGlobals.termStyleClose[8]='<\/strike>';\r
+\r
+Terminal.prototype._makeTerm=function(rebuild) {\r
+ window.status='Building terminal ...';\r
+ TermGlobals.hasLayers=(document.layers)? true:false;\r
+ TermGlobals.hasSubDivs=(navigator.userAgent.indexOf('Gecko')<0);\r
+ var divPrefix=this.termDiv+'_r';\r
+ var s='';\r
+ s+='<table border="0" cellspacing="0" cellpadding="'+this.conf.frameWidth+'">\n';\r
+ s+='<tr><td bgcolor="'+this.conf.frameColor+'"><table border="0" cellspacing="0" cellpadding="2"><tr><td bgcolor="'+this.conf.bgColor+'"><table border="0" cellspacing="0" cellpadding="0">\n';\r
+ var rstr='';\r
+ for (var c=0; c<this.conf.cols; c++) rstr+=' ';\r
+ for (var r=0; r<this.conf.rows; r++) {\r
+ var termid=((TermGlobals.hasLayers) || (TermGlobals.hasSubDivs))? '' : ' id="'+divPrefix+r+'"';\r
+ s+='<tr><td nowrap height="'+this.conf.rowHeight+'"'+termid+' class="'+this.conf.fontClass+'">'+rstr+'<\/td><\/tr>\n';\r
+ }\r
+ s+='<\/table><\/td><\/tr>\n';\r
+ s+='<\/table><\/td><\/tr>\n';\r
+ s+='<\/table>\n';\r
+ var termOffset=2+this.conf.frameWidth;\r
+ if (TermGlobals.hasLayers) {\r
+ for (var r=0; r<this.conf.rows; r++) {\r
+ s+='<layer name="'+divPrefix+r+'" top="'+(termOffset+r*this.conf.rowHeight)+'" left="'+termOffset+'" class="'+this.conf.fontClass+'"><\/layer>\n';\r
+ }\r
+ this.ns4ParentDoc=document.layers[this.termDiv].document;\r
+ TermGlobals.termStringStart='<table border="0" cellspacing="0" cellpadding="0"><tr><td nowrap height="'+this.conf.rowHeight+'" class="'+this.conf.fontClass+'">';\r
+ TermGlobals.termStringEnd='<\/td><\/tr><\/table>';\r
+ }\r
+ else if (TermGlobals.hasSubDivs) {\r
+ for (var r=0; r<this.conf.rows; r++) {\r
+ s+='<div id="'+divPrefix+r+'" style="position:absolute; top:'+(termOffset+r*this.conf.rowHeight)+'px; left: '+termOffset+'px;" class="'+this.conf.fontClass+'"><\/div>\n';\r
+ }\r
+ TermGlobals.termStringStart='<table border="0" cellspacing="0" cellpadding="0"><tr><td nowrap height="'+this.conf.rowHeight+'" class="'+this.conf.fontClass+'">';\r
+ TermGlobals.termStringEnd='<\/td><\/tr><\/table>';\r
+ }\r
+ TermGlobals.writeElement(this.termDiv,s);\r
+ if (!rebuild) {\r
+ TermGlobals.setElementXY(this.termDiv,this.conf.x,this.conf.y);\r
+ TermGlobals.setVisible(this.termDiv,1);\r
+ }\r
+ window.status='';\r
+}\r
+\r
+Terminal.prototype.rebuild=function() {\r
+ // check for bounds and array lengths\r
+ var rl=this.conf.rows;\r
+ var cl=this.conf.cols;\r
+ for (var r=0; r<rl; r++) {\r
+ var cbr=this.charBuf[r];\r
+ if (!cbr) {\r
+ this.charBuf[r]=this.getRowArray(cl,0);\r
+ this.styleBuf[r]=this.getRowArray(cl,0);\r
+ }\r
+ else if (cbr.length<cl) {\r
+ for (var c=cbr.length; c<cl; c++) {\r
+ this.charBuf[r][c]=0;\r
+ this.styleBuf[r][c]=0;\r
+ }\r
+ }\r
+ }\r
+ var resetcrsr=false;\r
+ if (this.r>=rl) {\r
+ r=rl-1;\r
+ resetcrsr=true;\r
+ }\r
+ if (this.c>=cl) {\r
+ c=cl-1;\r
+ resetcrsr=true;\r
+ }\r
+ if ((resetcrsr) && (this.cursoractive)) this.cursorOn();\r
+ // and actually rebuild\r
+ this._makeTerm(true);\r
+ for (var r=0; r<rl; r++) {\r
+ this.redraw(r);\r
+ }\r
+}\r
+\r
+Terminal.prototype.moveTo=function(x,y) {\r
+ TermGlobals.setElementXY(this.termDiv,x,y);\r
+}\r
+\r
+Terminal.prototype.resizeTo=function(x,y) {\r
+ if (this.termDivReady()) {\r
+ x=parseInt(x,10);\r
+ y=parseInt(y,10);\r
+ if ((isNaN(x)) || (isNaN(y)) || (x<4) || (y<2)) return false;\r
+ this.maxCols=this.conf.cols=x;\r
+ this.maxLines=this.conf.rows=y;\r
+ this._makeTerm();\r
+ this.clear();\r
+ return true;\r
+ }\r
+ else return false;\r
+}\r
+\r
+Terminal.prototype.redraw=function(r) {\r
+ var s=TermGlobals.termStringStart;\r
+ var curStyle=0;\r
+ var tstls=TermGlobals.termStyles;\r
+ var tscls=TermGlobals.termStyleClose;\r
+ var tsopn=TermGlobals.termStyleOpen;\r
+ var tspcl=TermGlobals.termSpecials;\r
+ var t_cb=this.charBuf;\r
+ var t_sb=this.styleBuf;\r
+ for (var i=0; i<this.conf.cols; i++) {\r
+ var c=t_cb[r][i];\r
+ var cs=t_sb[r][i];\r
+ if (cs!=curStyle) {\r
+ if (curStyle) {\r
+ for (var k=tstls.length-1; k>=0; k--) {\r
+ var st=tstls[k];\r
+ if (curStyle&st) s+=tscls[st];\r
+ }\r
+ }\r
+ curStyle=cs;\r
+ for (var k=0; k<tstls.length; k++) {\r
+ var st=tstls[k];\r
+ if (curStyle&st) s+=tsopn[st];\r
+ }\r
+ }\r
+ s+= (tspcl[c])? tspcl[c] : String.fromCharCode(c);\r
+ }\r
+ if (curStyle>0) {\r
+ for (var k=tstls.length-1; k>=0; k--) {\r
+ var st=tstls[k];\r
+ if (curStyle&st) s+=tscls[st];\r
+ }\r
+ }\r
+ s+=TermGlobals.termStringEnd;\r
+ TermGlobals.writeElement(this.termDiv+'_r'+r,s,this.ns4ParentDoc);\r
+}\r
+\r
+Terminal.prototype.guiReady=function() {\r
+ ready=true;\r
+ if (TermGlobals.guiElementsReady(this.termDiv, self.document)) {\r
+ for (var r=0; r<this.conf.rows; r++) {\r
+ if (TermGlobals.guiElementsReady(this.termDiv+'_r'+r,this.ns4ParentDoc)==false) {\r
+ ready=false;\r
+ break;\r
+ }\r
+ }\r
+ }\r
+ else ready=false;\r
+ return ready;\r
+}\r
+\r
+Terminal.prototype.termDivReady=function() {\r
+ if (document.layers) {\r
+ return (document.layers[this.termDiv])? true:false;\r
+ }\r
+ else if (document.getElementById) {\r
+ return (document.getElementById(this.termDiv))? true:false;\r
+ }\r
+ else if (document.all) {\r
+ return (document.all[this.termDiv])? true:false;\r
+ }\r
+ else {\r
+ return false;\r
+ }\r
+}\r
+\r
+Terminal.prototype.getDimensions=function() {\r
+ var w=0;\r
+ var h=0;\r
+ var d=this.termDiv;\r
+ if (document.layers) {\r
+ if (document.layers[d]) {\r
+ w=document.layers[d].clip.right;\r
+ h=document.layers[d].clip.bottom;\r
+ }\r
+ }\r
+ else if (document.getElementById) {\r
+ var obj=document.getElementById(d);\r
+ if ((obj) && (obj.firstChild)) {\r
+ w=parseInt(obj.firstChild.offsetWidth,10);\r
+ h=parseInt(obj.firstChild.offsetHeight,10);\r
+ }\r
+ else if ((obj) && (obj.children) && (obj.children[0])) {\r
+ w=parseInt(obj.children[0].offsetWidth,10);\r
+ h=parseInt(obj.children[0].offsetHeight,10);\r
+ }\r
+ }\r
+ else if (document.all) {\r
+ var obj=document.all[d];\r
+ if ((obj) && (obj.children) && (obj.children[0])) {\r
+ w=parseInt(obj.children[0].offsetWidth,10);\r
+ h=parseInt(obj.children[0].offsetHeight,10);\r
+ }\r
+ }\r
+ return { width: w, height: h };\r
+}\r
+\r
+// basic dynamics\r
+\r
+TermGlobals.writeElement=function(e,t,d) {\r
+ if (document.layers) {\r
+ var doc=(d)? d : self.document;\r
+ doc.layers[e].document.open();\r
+ doc.layers[e].document.write(t);\r
+ doc.layers[e].document.close();\r
+ }\r
+ else if (document.getElementById) {\r
+ var obj=document.getElementById(e);\r
+ obj.innerHTML=t;\r
+ }\r
+ else if (document.all) {\r
+ document.all[e].innerHTML=t;\r
+ }\r
+}\r
+\r
+TermGlobals.setElementXY=function(d,x,y) {\r
+ if (document.layers) {\r
+ document.layers[d].moveTo(x,y);\r
+ }\r
+ else if (document.getElementById) {\r
+ var obj=document.getElementById(d);\r
+ obj.style.left=x+'px';\r
+ obj.style.top=y+'px';\r
+ }\r
+ else if (document.all) {\r
+ document.all[d].style.left=x+'px';\r
+ document.all[d].style.top=y+'px';\r
+ }\r
+}\r
+\r
+TermGlobals.setVisible=function(d,v) {\r
+ if (document.layers) {\r
+ document.layers[d].visibility= (v)? 'show':'hide';\r
+ }\r
+ else if (document.getElementById) {\r
+ var obj=document.getElementById(d);\r
+ obj.style.visibility= (v)? 'visible':'hidden';\r
+ }\r
+ else if (document.all) {\r
+ document.all[d].style.visibility= (v)? 'visible':'hidden';\r
+ }\r
+}\r
+\r
+TermGlobals.setDisplay=function(d,v) {\r
+ if (document.getElementById) {\r
+ var obj=document.getElementById(d);\r
+ obj.style.display=v;\r
+ }\r
+ else if (document.all) {\r
+ document.all[d].style.display=v;\r
+ }\r
+}\r
+\r
+TermGlobals.guiElementsReady=function(e,d) {\r
+ if (document.layers) {\r
+ var doc=(d)? d : self.document;\r
+ return ((doc) && (doc.layers[e]))? true:false;\r
+ }\r
+ else if (document.getElementById) {\r
+ return (document.getElementById(e))? true:false;\r
+ }\r
+ else if (document.all) {\r
+ return (document.all[e])? true:false;\r
+ }\r
+ else return false;\r
+}\r
+\r
+\r
+// constructor mods (ie4 fix)\r
+\r
+var termString_keyref;\r
+var termString_keycoderef;\r
+\r
+function termString_makeKeyref() {\r
+ termString_keyref= new Array();\r
+ termString_keycoderef= new Array();\r
+ var hex= new Array('A','B','C','D','E','F');\r
+ for (var i=0; i<=15; i++) {\r
+ var high=(i<10)? i:hex[i-10];\r
+ for (var k=0; k<=15; k++) {\r
+ var low=(k<10)? k:hex[k-10];\r
+ var cc=i*16+k;\r
+ if (cc>=32) {\r
+ var cs=unescape("%"+high+low);\r
+ termString_keyref[cc]=cs;\r
+ termString_keycoderef[cs]=cc;\r
+ }\r
+ }\r
+ }\r
+}\r
+\r
+if (!String.fromCharCode) {\r
+ termString_makeKeyref();\r
+ String.fromCharCode=function(cc) {\r
+ return (cc!=null)? termString_keyref[cc] : '';\r
+ };\r
+}\r
+if (!String.prototype.charCodeAt) {\r
+ if (!termString_keycoderef) termString_makeKeyref();\r
+ String.prototype.charCodeAt=function(n) {\r
+ cs=this.charAt(n);\r
+ return (termString_keycoderef[cs])? termString_keycoderef[cs] : 0;\r
+ };\r
+}\r
+\r
+// eof
\ No newline at end of file
--- /dev/null
+/*\r
+ termlib_parser.js v.1.0\r
+ command line parser for termlib.js\r
+ (c) Norbert Landsteiner 2005\r
+ mass:werk - media environments\r
+ <http://www.masswerk.at>\r
+\r
+ you are free to use this parser under the "termlib.js" license.\r
+\r
+ usage: call "parseLine(this)" from your Terminal handler\r
+ parsed args in this.argv\r
+ quoting levels per arg in this.argQL (value: quote char)\r
+ this.argc: pointer to this.argv and this.argQL (used by parserGetopt)\r
+ call parseretopt(this, "<options>") from your handler to get opts\r
+ (returns an object with properties for every option flag. any float\r
+ values are stored in Object.<flag>.value; illegal opts in array\r
+ Object.illegals)\r
+\r
+ configuration: you may want to overide the follow objects (or add properties):\r
+ parserWhiteSpace: chars to be parsed as whitespace\r
+ parserQuoteChars: chars to be parsed as quotes\r
+ parserSingleEscapes: chars to escape a quote or escape expression\r
+ parserOptionChars: chars that start an option\r
+ parserEscapeExpressions: chars that start escape expressions\r
+*/\r
+\r
+// chars to be parsed as white space\r
+var parserWhiteSpace = {\r
+ ' ': true,\r
+ '\t': true\r
+}\r
+\r
+// chars to be parsed as quotes\r
+var parserQuoteChars = {\r
+ '"': true,\r
+ "'": true,\r
+ '`': true\r
+};\r
+\r
+// chars to be parsed as escape char\r
+var parserSingleEscapes = {\r
+ '\\': true\r
+};\r
+\r
+// chars that mark the start of an option-expression\r
+// for use with parserGetopt\r
+var parserOptionChars = {\r
+ '-': true\r
+}\r
+\r
+// chars that start escape expressions (value = handler)\r
+// plugin handlers for ascii escapes or variable substitution\r
+var parserEscapeExpressions = {\r
+ '%': parserHexExpression\r
+}\r
+\r
+function parserHexExpression(termref, pointer, echar, quotelevel) {\r
+ /* example for parserEscapeExpressions\r
+ params:\r
+ termref: ref to Terminal instance\r
+ pointer: position in termref.lineBuffer (echar)\r
+ echar: escape character found\r
+ quotelevel: current quoting level (quote char or empty)\r
+ char under pointer will be ignored\r
+ the return value is added to the current argument\r
+ */\r
+ // convert hex values to chars (e.g. %20 => <SPACE>)\r
+ if (termref.lineBuffer.length > pointer+2) {\r
+ // get next 2 chars\r
+ var hi = termref.lineBuffer.charAt(pointer+1);\r
+ var lo = termref.lineBuffer.charAt(pointer+2);\r
+ lo = lo.toUpperCase();\r
+ hi = hi.toUpperCase();\r
+ // check for valid hex digits\r
+ if ((((hi>='0') && (hi<='9')) || ((hi>='A') && ((hi<='F')))) &&\r
+ (((lo>='0') && (lo<='9')) || ((lo>='A') && ((lo<='F'))))) {\r
+ // next 2 chars are valid hex, so strip them from lineBuffer\r
+ parserEscExprStrip(termref, pointer+1, pointer+3);\r
+ // and return the char\r
+ return String.fromCharCode(parseInt(hi+lo, 16));\r
+ }\r
+ }\r
+ // if not handled return the escape character (=> no conversion)\r
+ return echar;\r
+}\r
+\r
+function parserEscExprStrip(termref, from, to) {\r
+ // strip characters from termref.lineBuffer (for use with escape expressions)\r
+ termref.lineBuffer =\r
+ termref.lineBuffer.substring(0, from) +\r
+ termref.lineBuffer.substring(to);\r
+}\r
+\r
+function parserGetopt(termref, optsstring) {\r
+ // scans argv form current position of argc for opts\r
+ // arguments in argv must not be quoted\r
+ // returns an object with a property for every option flag found\r
+ // option values (absolute floats) are stored in Object.<opt>.value (default -1)\r
+ // the property "illegals" contains an array of all flags found but not in optstring\r
+ // argc is set to first argument that is not an option\r
+ var opts = { 'illegals':[] };\r
+ while ((termref.argc < termref.argv.length) && (termref.argQL[termref.argc]=='')) {\r
+ var a = termref.argv[termref.argc];\r
+ if ((a.length>0) && (parserOptionChars[a.charAt(0)])) {\r
+ var i = 1;\r
+ while (i<a.length) {\r
+ var c=a.charAt(i);\r
+ var v = '';\r
+ while (i<a.length-1) {\r
+ var nc=a.charAt(i+1);\r
+ if ((nc=='.') || ((nc>='0') && (nc<='9'))) {\r
+ v += nc;\r
+ i++;\r
+ }\r
+ else break;\r
+ }\r
+ if (optsstring.indexOf(c)>=0) {\r
+ opts[c] = (v == '')? {value:-1} : (isNaN(v))? {value:0} : {value:parseFloat(v)};\r
+ }\r
+ else {\r
+ opts.illegals[opts.illegals.length]=c;\r
+ }\r
+ i++;\r
+ }\r
+ termref.argc++;\r
+ }\r
+ else break;\r
+ }\r
+ return opts;\r
+}\r
+\r
+function parseLine(termref) {\r
+ // stand-alone parser, takes a Terminal instance as argument\r
+ // parses the command line and stores results as instance properties\r
+ // argv: list of parsed arguments\r
+ // argQL: argument's quoting level (<empty> or quote character)\r
+ // argc: cursur for argv, set initinally to zero (0)\r
+ // open quote strings are not an error but automatically closed.\r
+ var argv = ['']; // arguments vector\r
+ var argQL = ['']; // quoting level\r
+ var argc = 0; // arguments cursor\r
+ var escape = false ; // escape flag\r
+ for (var i=0; i<termref.lineBuffer.length; i++) {\r
+ var ch= termref.lineBuffer.charAt(i);\r
+ if (escape) {\r
+ argv[argc] += ch;\r
+ escape = false;\r
+ }\r
+ else if (parserEscapeExpressions[ch]) {\r
+ var v = parserEscapeExpressions[ch](termref, i, ch, argQL[argc]);\r
+ if (typeof v != 'undefined') argv[argc] += v;\r
+ }\r
+ else if (parserQuoteChars[ch]) {\r
+ if (argQL[argc]) {\r
+ if (argQL[argc] == ch) {\r
+ argc ++;\r
+ argv[argc] = argQL[argc] = '';\r
+ }\r
+ else {\r
+ argv[argc] += ch;\r
+ }\r
+ }\r
+ else {\r
+ if (argv[argc] != '') {\r
+ argc ++;\r
+ argv[argc] = '';\r
+ argQL[argc] = ch;\r
+ }\r
+ else {\r
+ argQL[argc] = ch;\r
+ }\r
+ }\r
+ }\r
+ else if (parserWhiteSpace[ch]) {\r
+ if (argQL[argc]) {\r
+ argv[argc] += ch;\r
+ }\r
+ else if (argv[argc] != '') {\r
+ argc++;\r
+ argv[argc] = argQL[argc] = '';\r
+ }\r
+ }\r
+ else if (parserSingleEscapes[ch]) {\r
+ escape = true;\r
+ }\r
+ else {\r
+ argv[argc] += ch;\r
+ }\r
+ }\r
+ if ((argv[argc] == '') && (!argQL[argc])) {\r
+ argv.length--;\r
+ argQL.length--;\r
+ }\r
+ termref.argv = argv;\r
+ termref.argQL = argQL;\r
+ termref.argc = 0;\r
+}\r
+\r
+// eof
\ No newline at end of file
--- /dev/null
+Web interface for Factor to Javascript compiler
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel furnace furnace.validator http.server.responders
+ help help.topics html splitting sequences words strings
+ quotations macros vocabs tools.browser combinators
+ arrays io.files ;
+IN: webapps.help
+
+! : string>topic ( string -- topic )
+ ! " " split dup length 1 = [ first ] when ;
+
+: show-help ( topic -- )
+ serving-html
+ dup article-title [
+ [ help ] with-html-stream
+ ] simple-html-document ;
+
+\ show-help {
+ { "topic" }
+} define-action
+\ show-help { { "topic" "handbook" } } default-values
+
+M: link browser-link-href
+ link-name
+ dup word? over f eq? or [
+ browser-link-href
+ ] [
+ dup array? [ " " join ] when
+ [ show-help ] curry quot-link
+ ] if ;
+
+: show-word ( word vocab -- )
+ lookup show-help ;
+
+\ show-word {
+ { "word" }
+ { "vocab" }
+} define-action
+\ show-word { { "word" "call" } { "vocab" "kernel" } } default-values
+
+M: f browser-link-href
+ drop \ f browser-link-href ;
+
+M: word browser-link-href
+ dup word-name swap word-vocabulary
+ [ show-word ] 2curry quot-link ;
+
+: show-vocab ( vocab -- )
+ f >vocab-link show-help ;
+
+\ show-vocab {
+ { "vocab" }
+} define-action
+
+\ show-vocab { { "vocab" "kernel" } } default-values
+
+M: vocab-spec browser-link-href
+ vocab-name [ show-vocab ] curry quot-link ;
+
+: show-vocabs-tagged ( tag -- )
+ <vocab-tag> show-help ;
+
+\ show-vocabs-tagged {
+ { "tag" }
+} define-action
+
+M: vocab-tag browser-link-href
+ vocab-tag-name [ show-vocabs-tagged ] curry quot-link ;
+
+: show-vocabs-by ( author -- )
+ <vocab-author> show-help ;
+
+\ show-vocabs-by {
+ { "author" }
+} define-action
+
+M: vocab-author browser-link-href
+ vocab-author-name [ show-vocabs-by ] curry quot-link ;
+
+"help" "show-help" "extra/webapps/help" web-app
+
+! Hard-coding for factorcode.org
+PREDICATE: pathname resource-pathname
+ pathname-string "resource:" head? ;
+
+M: resource-pathname browser-link-href
+ pathname-string
+ "resource:" ?head drop
+ "/responder/source/" swap append ;
--- /dev/null
+Chris Double
--- /dev/null
+! cont-number-guess
+!
+! 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.
+!
+! This example modifies the console based 'numbers-game' example
+! in a very minimal way to demonstrate conversion of a console
+! program to a web based application.
+!
+! All that was required was changing the input and output functions
+! to use HTML. The remaining code was untouched.
+!
+! The result is not that pretty but it shows the basic idea.
+USING: kernel math parser html html.elements io namespaces
+math.parser random webapps.continuation ;
+
+IN: webapps.numbers
+
+: web-print ( str -- )
+ #! Display the string in a web page.
+ [
+ swap dup
+ <html>
+ <head> <title> write </title> </head>
+ <body>
+ <p> write </p>
+ <p> <a =href a> "Press to continue" write </a> </p>
+ </body>
+ </html>
+ ] show 2drop ;
+
+: read-number ( -- )
+ [
+ <html>
+ <head> <title> "Enter a number" write </title> </head>
+ <body>
+ <form =action "post" =method form>
+ <p>
+ "Enter a number:" write
+ <input "text" =type "num" =name "20" =size input/>
+ <input "submit" =type "Press to continue" =value input/>
+ </p>
+ </form>
+ </body>
+ </html>
+ ] show [ "num" get ] bind string>number ;
+
+: guess-banner
+ "I'm thinking of a number between 0 and 100." web-print ;
+: guess-prompt ;
+: too-high "Too high" web-print ;
+: too-low "Too low" web-print ;
+: correct "Correct - you win!" web-print ;
+: inexact-guess ( actual guess -- )
+ < [ too-high ] [ too-low ] if ;
+
+: judge-guess ( actual guess -- ? )
+ 2dup = [
+ 2drop correct f
+ ] [
+ inexact-guess t
+ ] if ;
+
+: number-to-guess ( -- n ) 100 random ;
+
+: numbers-game-loop ( actual -- )
+ dup guess-prompt read-number judge-guess [
+ numbers-game-loop
+ ] [
+ drop
+ ] if ;
+
+: numbers-game number-to-guess numbers-game-loop ;
+
+"numbers-game" [ numbers-game ] install-cont-responder
--- /dev/null
+<% USING: io math math.parser namespaces furnace ; %>
+
+<h1>Annotate</h1>
+
+<form method="POST" action="/responder/pastebin/annotate-paste">
+
+<table>
+
+<tr>
+<th align="right">Summary:</th>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
+</tr>
+
+<tr>
+<th align="right">Your name:</th>
+<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
+</tr>
+
+<tr>
+<th align="right">File type:</th>
+<td><% "modes" render-template %></td>
+</tr>
+
+<!--
+<tr>
+<th align="right">Channel:</th>
+<td><input type="TEXT" name="channel" value="#concatenative" /></td>
+</tr>
+-->
+
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
+<tr>
+<th align="right" valign="top">Content:</th>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
+</tr>
+</table>
+
+<input type="hidden" name="n" value="<% "n" get number>string write %>" />
+<input type="hidden" name="furnace-form-submitted" value="annotate-paste"/>
+<input type="SUBMIT" value="Annotate" />
+</form>
--- /dev/null
+<% USING: namespaces io furnace calendar ; %>
+
+<h2>Annotation: <% "summary" get write %></h2>
+
+<table>
+<tr><th align="right">Annotation by:</th><td><% "author" get write %></td></tr>
+<tr><th align="right">File type:</th><td><% "mode" get write %></td></tr>
+<tr><th align="right">Created:</th><td><% "date" get timestamp>string write %></td></tr>
+</table>
+
+<% "syntax" render-template %>
--- /dev/null
+Slava Pestov
--- /dev/null
+</body>
+
+</html>
--- /dev/null
+<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
+
+<!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">
+<head>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+
+ <title><% "title" get write %></title>
+ <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+ <% default-stylesheet %>
+ <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
+</head>
+
+<body id="index">
+
+ <div class="navbar">
+ <% [ paste-list ] "Paste list" render-link %> |
+ <% [ new-paste ] "New paste" render-link %> |
+ <% [ feed.xml ] "Syndicate" render-link %>
+ </div>
+ <h1 class="pastebin-title"><% "title" get write %></h1>
--- /dev/null
+<% USING: furnace xmode.catalog sequences kernel html.elements assocs io sorting continuations ; %>
+
+<select name="mode">
+ <% modes keys natural-sort [
+ <option dup "mode" session-var = [ "true" =selected ] when option> write </option>
+ ] each %>
+</select>
--- /dev/null
+<% USING: continuations furnace namespaces ; %>
+
+<%
+ "New paste" "title" set
+ "header" render-template
+%>
+
+<form method="POST" action="/responder/pastebin/submit-paste">
+
+<table>
+
+<tr>
+<th align="right">Summary:</th>
+<td><input type="TEXT" name="summary" value="<% "summary" render %>" /></td>
+<td align="left" class="error"><% "summary" "*Required" render-error %></td>
+</tr>
+
+<tr>
+<th align="right">Your name:</th>
+<td><input type="TEXT" name="author" value="<% "author" render %>" /></td>
+<td class="error"><% "author" "*Required" render-error %></td>
+</tr>
+
+<tr>
+<th align="right">File type:</th>
+<td><% "modes" render-template %></td>
+</tr>
+
+<!--
+<tr>
+<th align="right">Channel:</th>
+<td><input type="TEXT" name="channel" value="#concatenative" /></td>
+</tr>
+-->
+
+<tr>
+<td></td>
+<td colspan="2" class="error" align="left"><% "contents" "*Required" render-error %></td>
+</tr>
+
+<tr>
+<th align="right" valign="top">Content:</th>
+<td colspan="2"><textarea rows="24" cols="60" name="contents"><% "contents" render %></textarea></td>
+</tr>
+</table>
+
+<input type="hidden" name="furnace-form-submitted" value="new-paste"/>
+<input type="SUBMIT" value="Submit paste" />
+</form>
+
+<% "footer" render-template %>
--- /dev/null
+<% USING: namespaces furnace sequences ; %>
+
+<%
+ "Pastebin" "title" set
+ "header" render-template
+%>
+
+<table width="100%" cellspacing="10">
+ <tr>
+ <td valign="top">
+ <table width="100%">
+ <tr align="left" class="pastebin-headings">
+ <th width="50%">Summary:</th>
+ <th width="100">Paste by:</th>
+ <th width="200">Date:</th>
+ </tr>
+ <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
+ </table>
+ </td>
+ <td valign="top" width="25%">
+ <div class="infobox">
+ <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
+ </p>
+ <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
+ </p>
+ <p>
+ <% "webapps.pastebin" browse-webapp-source %></p>
+ </div>
+ </td>
+ </tr>
+</table>
+
+<% "footer" render-template %>
--- /dev/null
+<% USING: continuations namespaces io kernel math math.parser
+furnace webapps.pastebin calendar sequences ; %>
+
+<tr>
+ <td>
+ <a href="<% model get paste-link write %>">
+ <% "summary" get write %>
+ </a>
+ </td>
+ <td><% "author" get write %></td>
+ <td><% "date" get timestamp>string write %></td>
+</tr>
--- /dev/null
+USING: calendar furnace furnace.validator io.files kernel
+namespaces sequences http.server.responders html math.parser rss
+xml.writer xmode.code2html math calendar.format ;
+IN: webapps.pastebin
+
+TUPLE: pastebin pastes ;
+
+: <pastebin> ( -- pastebin )
+ V{ } clone pastebin construct-boa ;
+
+<pastebin> pastebin set-global
+
+TUPLE: paste
+summary author channel mode contents date
+annotations n ;
+
+: <paste> ( summary author channel mode contents -- paste )
+ f V{ } clone f paste construct-boa ;
+
+TUPLE: annotation summary author mode contents ;
+
+C: <annotation> annotation
+
+: get-paste ( n -- paste )
+ pastebin get pastebin-pastes nth ;
+
+: show-paste ( n -- )
+ serving-html
+ get-paste
+ [ "show-paste" render-component ] with-html-stream ;
+
+\ show-paste { { "n" v-number } } define-action
+
+: new-paste ( -- )
+ serving-html
+ [ "new-paste" render-template ] with-html-stream ;
+
+\ new-paste { } define-action
+
+: paste-list ( -- )
+ serving-html
+ [
+ [ show-paste ] "show-paste-quot" set
+ [ new-paste ] "new-paste-quot" set
+ pastebin get "paste-list" render-component
+ ] with-html-stream ;
+
+\ paste-list { } define-action
+
+: paste-link ( paste -- link )
+ paste-n number>string [ show-paste ] curry quot-link ;
+
+: safe-head ( seq n -- seq' )
+ over length min head ;
+
+: paste-feed ( -- entries )
+ pastebin get pastebin-pastes <reversed> 20 safe-head [
+ {
+ paste-summary
+ paste-link
+ paste-date
+ } get-slots timestamp>rfc3339 f swap <entry>
+ ] map ;
+
+: feed.xml ( -- )
+ "text/xml" serving-content
+ "pastebin"
+ "http://pastebin.factorcode.org"
+ paste-feed <feed> feed>xml write-xml ;
+
+\ feed.xml { } define-action
+
+: add-paste ( paste pastebin -- )
+ >r now over set-paste-date r>
+ pastebin-pastes 2dup length swap set-paste-n push ;
+
+: submit-paste ( summary author channel mode contents -- )
+ <paste> [ pastebin get add-paste ] keep
+ paste-link permanent-redirect ;
+
+\ new-paste
+\ submit-paste {
+ { "summary" v-required }
+ { "author" v-required }
+ { "channel" }
+ { "mode" v-required }
+ { "contents" v-required }
+} define-form
+
+\ new-paste {
+ { "channel" "#concatenative" }
+ { "mode" "factor" }
+} default-values
+
+: annotate-paste ( n summary author mode contents -- )
+ <annotation> swap get-paste
+ [ paste-annotations push ] keep
+ paste-link permanent-redirect ;
+
+[ "n" show-paste ]
+\ annotate-paste {
+ { "n" v-required v-number }
+ { "summary" v-required }
+ { "author" v-required }
+ { "mode" v-required }
+ { "contents" v-required }
+} define-form
+
+\ show-paste {
+ { "mode" "factor" }
+} default-values
+
+: style.css ( -- )
+ "text/css" serving-content
+ "style.css" send-resource ;
+
+\ style.css { } define-action
+
+"pastebin" "paste-list" "extra/webapps/pastebin" web-app
--- /dev/null
+<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
+
+<%
+ "Paste: " "summary" get append "title" set
+ "header" render-template
+%>
+
+<table>
+<tr><th>Paste by:</th><td><% "author" get write %></td></tr>
+<!-- <tr><th>Channel:</th><td><% "channel" get write %></td></tr> -->
+<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
+<tr><th>File type:</th><td><% "mode" get write %></td></tr>
+</table>
+
+<% "syntax" render-template %>
+
+<% "annotations" get [ "annotation" render-component ] each %>
+
+<% model get "annotate-paste" render-component %>
+
+<% "footer" render-template %>
--- /dev/null
+body {
+ font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#888;
+}
+
+h1.pastebin-title {
+ font-size:300%;
+}
+
+a {
+ color:#222;
+ border-bottom:1px dotted #ccc;
+ text-decoration:none;
+}
+
+a:hover {
+ border-bottom:1px solid #ccc;
+}
+
+pre.code {
+ border:1px dashed #ccc;
+ background-color:#f5f5f5;
+ padding:5px;
+ font-size:150%;
+ color:#000000;
+}
+
+.navbar {
+ background-color:#eeeeee;
+ padding:5px;
+ border:1px solid #ccc;
+}
+
+.infobox {
+ border: 1px solid #C1DAD7;
+ padding: 10px;
+}
+
+.error {
+ color: red;
+}
--- /dev/null
+<% USING: xmode.code2html splitting namespaces ; %>
+
+<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: sequences rss arrays concurrency.combinators kernel
+sorting html.elements io assocs namespaces math threads vocabs
+html furnace http.server.templating calendar math.parser
+splitting continuations debugger system http.server.responders
+xml.writer prettyprint logging calendar.format ;
+IN: webapps.planet
+
+: print-posting-summary ( posting -- )
+ <p "news" =class p>
+ <b> dup entry-title write </b> <br/>
+ <a entry-link =href "more" =class a>
+ "Read More..." write
+ </a>
+ </p> ;
+
+: print-posting-summaries ( postings -- )
+ [ print-posting-summary ] each ;
+
+: print-blogroll ( blogroll -- )
+ <ul "description" =class ul>
+ [
+ <li> <a dup third =href a> first write </a> </li>
+ ] each
+ </ul> ;
+
+: format-date ( date -- string )
+ rfc3339>timestamp timestamp>string ;
+
+: print-posting ( posting -- )
+ <h2 "posting-title" =class h2>
+ <a dup entry-link =href a>
+ dup entry-title write-html
+ </a>
+ </h2>
+ <p "posting-body" =class p>
+ dup entry-description write-html
+ </p>
+ <p "posting-date" =class p>
+ entry-pub-date format-date write
+ </p> ;
+
+: print-postings ( postings -- )
+ [ print-posting ] each ;
+
+SYMBOL: default-blogroll
+SYMBOL: cached-postings
+
+: safe-head ( seq n -- seq' )
+ over length min head ;
+
+: mini-planet-factor ( -- )
+ cached-postings get 4 safe-head print-posting-summaries ;
+
+: planet-factor ( -- )
+ serving-html [ "planet" render-template ] with-html-stream ;
+
+\ planet-factor { } define-action
+
+: planet-feed ( -- feed )
+ "[ planet-factor ]"
+ "http://planet.factorcode.org"
+ cached-postings get 30 safe-head <feed> ;
+
+: feed.xml ( -- )
+ "text/xml" serving-content
+ planet-feed feed>xml write-xml ;
+
+\ feed.xml { } define-action
+
+: style.css ( -- )
+ "text/css" serving-content
+ "style.css" send-resource ;
+
+\ style.css { } define-action
+
+SYMBOL: last-update
+
+: <posting> ( author entry -- entry' )
+ clone
+ [ ": " swap entry-title 3append ] keep
+ [ set-entry-title ] keep ;
+
+: fetch-feed ( url -- feed )
+ download-feed feed-entries ;
+
+\ fetch-feed DEBUG add-error-logging
+
+: fetch-blogroll ( blogroll -- entries )
+ dup 0 <column> swap 1 <column>
+ [ fetch-feed ] parallel-map
+ [ [ <posting> ] with map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+ [ [ entry-pub-date ] compare ] sort <reversed> ;
+
+: update-cached-postings ( -- )
+ default-blogroll get
+ fetch-blogroll sort-entries
+ cached-postings set-global ;
+
+: update-thread ( -- )
+ millis last-update set-global
+ [ update-cached-postings ] "RSS feed update slave" spawn drop
+ 10 60 * 1000 * sleep
+ update-thread ;
+
+: start-update-thread ( -- )
+ [
+ "webapps.planet" [
+ update-thread
+ ] with-logging
+ ] "RSS feed update master" spawn drop ;
+
+"planet" "planet-factor" "extra/webapps/planet" web-app
+
+{
+ { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
+ { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
+ { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
+ { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
+ { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
+ { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
+ { "Kio M. Smallwood"
+ "http://sekenre.wordpress.com/feed/atom/"
+ "http://sekenre.wordpress.com/" }
+ { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
+ { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
+ { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
+} default-blogroll set-global
--- /dev/null
+<% USING: namespaces html.elements webapps.planet sequences
+furnace ; %>
+
+<!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">
+<head>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+
+ <title>planet-factor</title>
+ <link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+ <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
+</head>
+
+<body id="index">
+ <h1 class="planet-title">[ planet-factor ]</h1>
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td> <% cached-postings get 20 safe-head print-postings %> </td>
+ <td valign="top" width="25%" class="infobox">
+ <p>
+ <b>planet-factor</b> is an Atom/RSS aggregator that collects the
+ contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
+ <a href="http://planet.lisp.org">Planet Lisp</a>.
+ </p>
+ <p>
+ <img src="http://planet.lisp.org/feed-icon-14x14.png" />
+ <a href="feed.xml"> Syndicate </a>
+ </p>
+ <p>
+ This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
+ <% "webapps.planet" browse-webapp-source %>
+ </p>
+ <h2 class="blogroll-title">Blogroll</h2>
+ <% default-blogroll get print-blogroll %>
+ <p>
+ If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
+ </p>
+ </td>
+ </tr>
+ </table>
+</body>
+
+</html>
--- /dev/null
+body {
+ font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#888;
+}
+
+h1.planet-title {
+ font-size:300%;
+}
+
+a {
+ color:#222;
+ border-bottom:1px dotted #ccc;
+ text-decoration:none;
+}
+
+a:hover {
+ border-bottom:1px solid #ccc;
+}
+
+.posting-title {
+ background-color:#f5f5f5;
+}
+
+pre, code {
+ color:#000000;
+ font-size:120%;
+}
+
+.infobox {
+ border-left: 1px solid #C1DAD7;
+}
+
+.posting-date {
+ text-align: right;
+ font-size:90%;
+}
+
+a.more {
+ display:block;
+ padding:0 0 5px 0;
+ color:#333;
+ text-decoration:none;
+ text-align:right;
+ border:none;
+}
LIBS = -lm
-EXE_SUFFIX=-nt
-DLL_SUFFIX=-nt
+EXE_SUFFIX=
+DLL_SUFFIX=
PLAF_DLL_OBJS += vm/os-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
/* Insufficient room even after code GC, give up */
if(start == 0)
- critical_error("Out of memory in add-compiled-block",0);
+ fatal_error("Out of memory in add-compiled-block",0);
}
return start;
{
CELL length = array_capacity(array);
CELL i;
+ bool trimmed;
if(length > 10)
+ {
+ trimmed = true;
length = 10;
+ }
+ else
+ trimmed = false;
for(i = 0; i < length; i++)
{
printf(" ");
print_nested_obj(array_nth(array,i),nesting);
}
+
+ if(trimmed)
+ printf("...");
}
void print_nested_obj(CELL obj, F_FIXNUM nesting)
p->rs_size = 32 * CELLS;
p->gen_count = 3;
- p->code_size = 4 * CELLS;
+ p->code_size = 8 * CELLS;
p->young_size = 2 * CELLS;
p->aging_size = 4 * CELLS;
#endif
for(i = 0; i < FIRST_SAVE_ENV; i++)
userenv[i] = F;
+ for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++)
+ userenv[i] = F;
+
/* do a full GC + code heap compaction */
compact_code_heap();
}
else
{
- dpush(tag_object(memory_to_char_string(
- (char *)(buf + 1),c)));
+ if(c != size)
+ {
+ REGISTER_UNTAGGED(buf);
+ F_BYTE_ARRAY *new_buf = allot_byte_array(c);
+ UNREGISTER_UNTAGGED(buf);
+ memcpy(new_buf + 1, buf + 1,c);
+ buf = new_buf;
+ }
+ dpush(tag_object(buf));
break;
}
}
}
+DEFINE_PRIMITIVE(fputc)
+{
+ FILE *file = unbox_alien();
+ F_FIXNUM ch = to_fixnum(dpop());
+
+ for(;;)
+ {
+ if(fputc(ch,file) == EOF)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ }
+ else
+ break;
+ }
+}
+
DEFINE_PRIMITIVE(fwrite)
{
- FILE* file = unbox_alien();
- F_STRING* text = untag_string(dpop());
- F_FIXNUM length = untag_fixnum_fast(text->length);
- char* string = to_char_string(text,false);
+ FILE *file = unbox_alien();
+ F_BYTE_ARRAY *text = untag_byte_array(dpop());
+ F_FIXNUM length = array_capacity(text);
+ char *string = (char *)(text + 1);
- if(string_capacity(text) == 0)
+ if(length == 0)
return;
for(;;)
int err_no(void);
DECLARE_PRIMITIVE(fopen);
+DECLARE_PRIMITIVE(fgetc);
+DECLARE_PRIMITIVE(fread);
+DECLARE_PRIMITIVE(fputc);
DECLARE_PRIMITIVE(fwrite);
DECLARE_PRIMITIVE(fflush);
DECLARE_PRIMITIVE(fclose);
-DECLARE_PRIMITIVE(fgetc);
-DECLARE_PRIMITIVE(fread);
/* Platform specific primitives */
DECLARE_PRIMITIVE(open_file);
dpush(result);
}
+DEFINE_PRIMITIVE(set_os_envs)
+{
+ F_ARRAY *array = untag_array(dpop());
+ CELL size = array_capacity(array);
+
+ /* Memory leak */
+ char **env = calloc(size + 1,sizeof(CELL));
+
+ CELL i;
+ for(i = 0; i < size; i++)
+ {
+ F_STRING *string = untag_string(array_nth(array,i));
+ CELL length = to_fixnum(string->length);
+
+ char *chars = malloc(length + 1);
+ char_string_to_memory(string,chars);
+ chars[length] = '\0';
+ env[i] = chars;
+ }
+
+ environ = env;
+}
+
F_SEGMENT *alloc_segment(CELL size)
{
int pagesize = getpagesize();
#define from_symbol_string from_char_string
#define FACTOR_OS_STRING "winnt"
-#define FACTOR_DLL L"factor-nt.dll"
-#define FACTOR_DLL_NAME "factor-nt.dll"
+#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL_NAME "factor.dll"
void c_to_factor_toplevel(CELL quot);
long exception_handler(PEXCEPTION_POINTERS pe);
GROWABLE_ADD(result,pair);
}
while (FindNextFile(dir, &find_data));
- CloseHandle(dir);
+ FindClose(dir);
}
UNREGISTER_ROOT(result);
{
Sleep(msec);
}
+
+DECLARE_PRIMITIVE(set_os_envs)
+{
+ not_implemented_error();
+}
primitive_fopen,
primitive_fgetc,
primitive_fread,
+ primitive_fputc,
primitive_fwrite,
primitive_fflush,
primitive_fclose,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
+ primitive_set_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
primitive_resize_float_array,
} F_ENVTYPE;
#define FIRST_SAVE_ENV BOOT_ENV
+#define LAST_SAVE_ENV STAGE2_ENV
/* TAGGED user environment data; see getenv/setenv prims */
DLLEXPORT CELL userenv[USER_ENV];
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(os_env);
DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
projects / factor.git / commitdiff