<key>CFBundlePackageType</key>
<string>APPL</string>
<key>NSHumanReadableCopyright</key>
- <string>Copyright © 2003-2007, Slava Pestov and friends</string>
+ <string>Copyright © 2003-2008, Slava Pestov and friends</string>
<key>NSServices</key>
<array>
<dict>
ARTICLE: "embedding-factor" "What embedding looks like from Factor"
"Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance."
$nl
-"One exception is the global " { $link stdio } " stream, which is by default not bound to the terminal where the process is running, to avoid conflicting with any I/O the host process might perform. To initialize the terminal stream, " { $link init-stdio } " must be called explicitly."
+"One exception is that the global " { $link input-stream } " and " { $link output-stream } " streams are not bound by default, to avoid conflicting with any I/O the host process might perform. The " { $link init-stdio } " words must be called explicitly to initialize terminal streams."
$nl
"There is a word which can detect when Factor is embedded:"
{ $subsection embedded? }
! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
-sequences.private namespaces classes math ;
+sequences.private namespaces math ;
IN: assocs
ARTICLE: "alists" "Association lists"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
-{ $subsection subassoc? }
+{ $subsection assoc-subset? }
{ $subsection assoc-intersect }
{ $subsection update }
{ $subsection assoc-union }
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
-HELP: subassoc?
+HELP: assoc-subset?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
sequences.private hashtables io prettyprint assocs
continuations ;
-[ t ] [ H{ } dup subassoc? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
-[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
-[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
-[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
-[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
+[ t ] [ H{ } dup assoc-subset? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
+[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
+[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
+[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] unit-test
+[ t ] [ H{ { 1 f } } H{ { 1 f } } assoc-subset? ] unit-test
! Test some combinators
[
: assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ;
-: subassoc? ( assoc1 assoc2 -- ? )
+: assoc-subset? ( assoc1 assoc2 -- ? )
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
: assoc= ( assoc1 assoc2 -- ? )
- 2dup subassoc? >r swap subassoc? r> and ;
+ [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
: assoc-hashcode ( n assoc -- code )
[
[ emit ] emit-object ;
! Strings
-: emit-chars ( seq -- )
+: emit-bytes ( seq -- )
bootstrap-cell <groups>
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ;
-: pack-string ( string -- newstr )
+: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr )
dup length emit-fixnum
f ' emit
f ' emit
- pack-string emit-chars
+ pad-bytes emit-bytes
] emit-object ;
M: string '
[ 0 emit-fixnum ] emit-object
] bi* ;
-M: byte-array ' byte-array emit-dummy-array ;
+M: byte-array '
+ byte-array type-number object tag-number [
+ dup length emit-fixnum
+ pad-bytes emit-bytes
+ ] emit-object ;
M: bit-array ' bit-array emit-dummy-array ;
[
{
dictionary source-files builtins
- update-map class<-cache class-not-cache
- classes-intersect-cache class-and-cache
+ update-map class<=-cache
+ class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
"Writing image to " write
architecture get boot-image-name resource-path
[ write "..." print flush ]
- [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
+ [ binary [ (write-image) ] with-file-writer ] bi ;
PRIVATE>
"arrays"
"bit-arrays"
"byte-arrays"
+ "byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
}
} define-tuple-class
+"byte-vector" "byte-vectors" create
+tuple
+{
+ {
+ { "byte-array" "byte-arrays" }
+ "underlying"
+ { "underlying" "growable" }
+ { "set-underlying" "growable" }
+ } {
+ { "array-capacity" "sequences.private" }
+ "fill"
+ { "length" "sequences" }
+ { "set-fill" "growable" }
+ }
+} define-tuple-class
+
"curry" "kernel" create
tuple
{
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
-! 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
parse-command-line
run-user-init
"run" get run
- stdio get [ stream-flush ] when*
+ output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot
"?{"
"BIN:"
"B{"
+ "BV{"
"C:"
"CHAR:"
"DEFER:"
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel\r
+byte-vectors.private combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: byte-array>vector\r
+{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable byte-arrays ;\r
+IN: byte-vectors\r
+\r
+<PRIVATE\r
+\r
+: byte-array>vector ( byte-array length -- byte-vector )\r
+ byte-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ <byte-array> 0 byte-array>vector ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-array>vector ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+INSTANCE: byte-vector growable\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
--- /dev/null
+USING: help.markup help.syntax kernel math sequences quotations
+math.private byte-arrays strings ;
+IN: checksums
+
+HELP: checksum
+{ $class-description "The class of checksum algorithms." } ;
+
+HELP: hex-string
+{ $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 "USING: checksums io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
+}
+{ $notes "Numbers are zero-padded on the left." } ;
+
+HELP: checksum-stream
+{ $values { "stream" "an input stream" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data read from the stream." }
+{ $side-effects "stream" } ;
+
+HELP: checksum-bytes
+{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-lines
+{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-file
+{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a file." } ;
+
+ARTICLE: "checksums" "Checksums"
+"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
+$nl
+"Checksums are instances of a class:"
+{ $subsection checksum }
+"Operations on checksums:"
+{ $subsection checksum-bytes }
+{ $subsection checksum-stream }
+{ $subsection checksum-lines }
+"Checksums should implement at least one of " { $link checksum-bytes } " and " { $link checksum-stream } ". Implementing " { $link checksum-lines } " is optional."
+$nl
+"Utilities:"
+{ $subsection checksum-file }
+{ $subsection hex-string }
+"Checksum implementations:"
+{ $subsection "checksums.crc32" }
+{ $vocab-subsection "MD5 checksum" "checksums.md5" }
+{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
+{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;
--- /dev/null
+IN: checksums.tests
+USING: checksums tools.test ;
+
+\ checksum-bytes must-infer
+\ checksum-stream must-infer
+\ checksum-lines must-infer
+\ checksum-file must-infer
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math.parser io io.streams.byte-array
+io.encodings.binary io.files kernel ;
+IN: checksums
+
+MIXIN: checksum
+
+GENERIC: checksum-bytes ( bytes checksum -- value )
+
+GENERIC: checksum-stream ( stream checksum -- value )
+
+GENERIC: checksum-lines ( lines checksum -- value )
+
+M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
+
+M: checksum checksum-stream >r contents r> checksum-bytes ;
+
+M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
+
+: checksum-file ( path checksum -- value )
+ >r binary <file-reader> r> checksum-stream ;
+
+: hex-string ( seq -- str )
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax math ;
+IN: checksums.crc32
+
+HELP: crc32
+{ $class-description "The CRC32 checksum algorithm." } ;
+
+ARTICLE: "checksums.crc32" "CRC32 checksum"
+"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
+{ $subsection crc32 } ;
+
+ABOUT: "checksums.crc32"
--- /dev/null
+USING: checksums checksums.crc32 kernel math tools.test namespaces ;
+
+[ B{ 0 0 0 0 } ] [ "" crc32 checksum-bytes ] unit-test
+
+[ B{ HEX: cb HEX: f4 HEX: 39 HEX: 26 } ] [ "123456789" crc32 checksum-bytes ] unit-test
+
--- /dev/null
+! Copyright (C) 2006 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences sequences.private namespaces
+words io io.binary io.files io.streams.string quotations
+definitions checksums ;
+IN: checksums.crc32
+
+: crc32-polynomial HEX: edb88320 ; inline
+
+: crc32-table V{ } ; inline
+
+256 [
+ 8 [
+ dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
+ ] times >bignum
+] map 0 crc32-table copy
+
+: (crc32) ( crc ch -- crc )
+ >bignum dupd bitxor
+ mask-byte crc32-table nth-unsafe >bignum
+ swap -8 shift bitxor ; inline
+
+SINGLETON: crc32
+
+INSTANCE: crc32 checksum
+
+: init-crc32 drop >r HEX: ffffffff dup r> ; inline
+
+: finish-crc32 bitxor 4 >be ; inline
+
+M: crc32 checksum-bytes
+ init-crc32
+ [ (crc32) ] each
+ finish-crc32 ;
+
+M: crc32 checksum-lines
+ init-crc32
+ [ [ (crc32) ] each CHAR: \n (crc32) ] each
+ finish-crc32 ;
--- /dev/null
+CRC32 checksum algorithm
-USING: help.markup help.syntax kernel classes ;\r
+USING: help.markup help.syntax kernel classes words\r
+checksums checksums.crc32 sequences math ;\r
IN: classes.algebra\r
\r
ARTICLE: "class-operations" "Class operations"\r
"Set-theoretic operations on classes:"\r
{ $subsection class< }\r
+{ $subsection class<= }\r
{ $subsection class-and }\r
{ $subsection class-or }\r
{ $subsection classes-intersect? }\r
-"Topological sort:"\r
-{ $subsection sort-classes }\r
{ $subsection min-class }\r
"Low-level implementation detail:"\r
{ $subsection class-types }\r
{ $subsection class-types }\r
{ $subsection class-tags } ;\r
\r
+ARTICLE: "class-linearization" "Class linearization"\r
+"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"\r
+{ $list\r
+ "If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."\r
+ { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }\r
+}\r
+"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"\r
+{ $list\r
+ "Built-in classes and tuple classes"\r
+ "Predicate classes"\r
+ "Union classes"\r
+ "Mixin classes"\r
+}\r
+"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."\r
+$nl\r
+"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."\r
+$nl\r
+"Operations:"\r
+{ $subsection class< }\r
+{ $subsection sort-classes }\r
+"Metaclass order:"\r
+{ $subsection rank-class } ;\r
+\r
HELP: flatten-builtin-class\r
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;\r
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }\r
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;\r
\r
-HELP: class<\r
+HELP: class<=\r
{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }\r
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }\r
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;\r
\r
HELP: sort-classes\r
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }\r
-{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
+{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
\r
HELP: class-or\r
{ $values { "first" class } { "second" class } { "class" class } }\r
tools.test vectors words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
vectors definitions source-files compiler.units growable\r
-random inference effects kernel.private sbufs ;\r
+random inference effects kernel.private sbufs math.order ;\r
\r
-: class= [ class< ] 2keep swap class< and ;\r
+: class= [ class<= ] [ swap class<= ] 2bi and ;\r
\r
: class-and* >r class-and r> class= ;\r
\r
\r
[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
\r
-[ t ] [ \ fixnum \ integer class< ] unit-test\r
-[ t ] [ \ fixnum \ fixnum class< ] unit-test\r
-[ f ] [ \ integer \ fixnum class< ] unit-test\r
-[ t ] [ \ integer \ object class< ] unit-test\r
-[ f ] [ \ integer \ null class< ] unit-test\r
-[ t ] [ \ null \ object class< ] unit-test\r
+[ t ] [ \ fixnum \ integer class<= ] unit-test\r
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
+[ f ] [ \ integer \ fixnum class<= ] unit-test\r
+[ t ] [ \ integer \ object class<= ] unit-test\r
+[ f ] [ \ integer \ null class<= ] unit-test\r
+[ t ] [ \ null \ object class<= ] unit-test\r
\r
-[ t ] [ \ generic \ word class< ] unit-test\r
-[ f ] [ \ word \ generic class< ] unit-test\r
+[ t ] [ \ generic \ word class<= ] unit-test\r
+[ f ] [ \ word \ generic class<= ] unit-test\r
\r
-[ f ] [ \ reversed \ slice class< ] unit-test\r
-[ f ] [ \ slice \ reversed class< ] unit-test\r
+[ f ] [ \ reversed \ slice class<= ] unit-test\r
+[ f ] [ \ slice \ reversed class<= ] unit-test\r
\r
PREDICATE: no-docs < word "documentation" word-prop not ;\r
\r
UNION: no-docs-union no-docs integer ;\r
\r
-[ t ] [ no-docs no-docs-union class< ] unit-test\r
-[ f ] [ no-docs-union no-docs class< ] unit-test\r
+[ t ] [ no-docs no-docs-union class<= ] unit-test\r
+[ f ] [ no-docs-union no-docs class<= ] unit-test\r
\r
TUPLE: a ;\r
TUPLE: b ;\r
UNION: c a b ;\r
\r
-[ t ] [ \ c \ tuple class< ] unit-test\r
-[ f ] [ \ tuple \ c class< ] unit-test\r
+[ t ] [ \ c \ tuple class<= ] unit-test\r
+[ f ] [ \ tuple \ c class<= ] unit-test\r
\r
-[ t ] [ \ tuple-class \ class class< ] unit-test\r
-[ f ] [ \ class \ tuple-class class< ] unit-test\r
+[ t ] [ \ tuple-class \ class class<= ] unit-test\r
+[ f ] [ \ class \ tuple-class class<= ] unit-test\r
\r
TUPLE: tuple-example ;\r
\r
-[ t ] [ \ null \ tuple-example class< ] unit-test\r
-[ f ] [ \ object \ tuple-example class< ] unit-test\r
-[ f ] [ \ object \ tuple-example class< ] unit-test\r
-[ t ] [ \ tuple-example \ tuple class< ] unit-test\r
-[ f ] [ \ tuple \ tuple-example class< ] unit-test\r
+[ t ] [ \ null \ tuple-example class<= ] unit-test\r
+[ f ] [ \ object \ tuple-example class<= ] unit-test\r
+[ f ] [ \ object \ tuple-example class<= ] unit-test\r
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
\r
TUPLE: a1 ;\r
TUPLE: b1 ;\r
UNION: y1 a1 c1 ;\r
UNION: z1 b1 c1 ;\r
\r
-[ f ] [ z1 x1 y1 class-and class< ] unit-test\r
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
\r
-[ t ] [ x1 y1 class-and a1 class< ] unit-test\r
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
\r
[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
\r
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test\r
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
\r
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test\r
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
\r
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
\r
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
\r
[ t ] [\r
- growable tuple sequence class-and class<\r
+ growable tuple sequence class-and class<=\r
] unit-test\r
\r
[ t ] [\r
- growable assoc class-and tuple class<\r
+ growable assoc class-and tuple class<=\r
] unit-test\r
\r
-[ t ] [ object \ f \ f class-not class-or class< ] unit-test\r
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
\r
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
\r
[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
\r
-[ t ] [ array number class-not class< ] unit-test\r
+[ t ] [ array number class-not class<= ] unit-test\r
\r
-[ f ] [ bignum number class-not class< ] unit-test\r
+[ f ] [ bignum number class-not class<= ] unit-test\r
\r
[ vector ] [ vector class-not class-not ] unit-test\r
\r
-[ t ] [ fixnum fixnum bignum class-or class< ] unit-test\r
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
\r
-[ f ] [ fixnum class-not integer class-and array class< ] unit-test\r
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
\r
-[ f ] [ fixnum class-not integer class< ] unit-test\r
+[ f ] [ fixnum class-not integer class<= ] unit-test\r
\r
-[ f ] [ number class-not array class< ] unit-test\r
+[ f ] [ number class-not array class<= ] unit-test\r
\r
-[ f ] [ fixnum class-not array class< ] unit-test\r
+[ f ] [ fixnum class-not array class<= ] unit-test\r
\r
-[ t ] [ number class-not integer class-not class< ] unit-test\r
+[ t ] [ number class-not integer class-not class<= ] unit-test\r
\r
[ t ] [ vector array class-not class-and vector class= ] unit-test\r
\r
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
\r
-[ f ] [ fixnum class-not integer class< ] unit-test\r
+[ f ] [ fixnum class-not integer class<= ] unit-test\r
\r
[ t ] [ null class-not object class= ] unit-test\r
\r
[ t ] [\r
fixnum class-not\r
fixnum fixnum class-not class-or\r
- class<\r
+ class<=\r
] unit-test\r
\r
! Test method inlining\r
=\r
] unit-test\r
] times\r
+\r
+SINGLETON: xxx\r
+UNION: yyy xxx ;\r
+\r
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
+\r
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
+\r
+TUPLE: xa ;\r
+TUPLE: xb ;\r
+TUPLE: xc < xa ;\r
+TUPLE: xd < xb ;\r
+TUPLE: xe ;\r
+TUPLE: xf < xb ;\r
+TUPLE: xg < xb ;\r
+TUPLE: xh < xb ;\r
+\r
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel classes classes.builtin combinators accessors\r
sequences arrays vectors assocs namespaces words sorting layouts\r
-math hashtables kernel.private sets ;\r
+math hashtables kernel.private sets math.order ;\r
IN: classes.algebra\r
\r
: 2cache ( key1 key2 assoc quot -- value )\r
>r >r 2array r> [ first2 ] r> compose cache ; inline\r
\r
-DEFER: (class<)\r
+DEFER: (class<=)\r
\r
-: class< ( first second -- ? )\r
- class<-cache get [ (class<) ] 2cache ;\r
+: class<= ( first second -- ? )\r
+ class<=-cache get [ (class<=) ] 2cache ;\r
\r
DEFER: (class-not)\r
\r
\r
C: <anonymous-complement> anonymous-complement\r
\r
-: superclass< ( first second -- ? )\r
- >r superclass r> class< ;\r
+: superclass<= ( first second -- ? )\r
+ >r superclass r> class<= ;\r
\r
-: left-union-class< ( first second -- ? )\r
- >r members r> [ class< ] curry all? ;\r
+: left-union-class<= ( first second -- ? )\r
+ >r members r> [ class<= ] curry all? ;\r
\r
-: right-union-class< ( first second -- ? )\r
- members [ class< ] with contains? ;\r
+: right-union-class<= ( first second -- ? )\r
+ members [ class<= ] with contains? ;\r
\r
: left-anonymous-union< ( first second -- ? )\r
- >r members>> r> [ class< ] curry all? ;\r
+ >r members>> r> [ class<= ] curry all? ;\r
\r
: right-anonymous-union< ( first second -- ? )\r
- members>> [ class< ] with contains? ;\r
+ members>> [ class<= ] with contains? ;\r
\r
: left-anonymous-intersection< ( first second -- ? )\r
- >r members>> r> [ class< ] curry contains? ;\r
+ >r members>> r> [ class<= ] curry contains? ;\r
\r
: right-anonymous-intersection< ( first second -- ? )\r
- members>> [ class< ] with all? ;\r
+ members>> [ class<= ] with all? ;\r
\r
: anonymous-complement< ( first second -- ? )\r
- [ class>> ] bi@ swap class< ;\r
+ [ class>> ] bi@ swap class<= ;\r
\r
-: (class<) ( first second -- -1/0/1 ) \r
+: (class<=) ( first second -- -1/0/1 ) \r
{\r
{ [ 2dup eq? ] [ 2drop t ] }\r
{ [ dup object eq? ] [ 2drop t ] }\r
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union< ] }\r
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }\r
- { [ over members ] [ left-union-class< ] }\r
+ { [ over members ] [ left-union-class<= ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }\r
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }\r
{ [ over anonymous-complement? ] [ 2drop f ] }\r
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
- { [ dup members ] [ right-union-class< ] }\r
- { [ over superclass ] [ superclass< ] }\r
+ { [ dup members ] [ right-union-class<= ] }\r
+ { [ over superclass ] [ superclass<= ] }\r
[ 2drop f ]\r
} cond ;\r
\r
members>> [ classes-intersect? ] with all? ;\r
\r
: anonymous-complement-intersect? ( first second -- ? )\r
- class>> class< not ;\r
+ class>> class<= not ;\r
\r
: union-class-intersect? ( first second -- ? )\r
members [ classes-intersect? ] with contains? ;\r
{\r
{ [ over tuple eq? ] [ 2drop t ] }\r
{ [ over builtin-class? ] [ 2drop f ] }\r
- { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }\r
+ { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }\r
[ swap classes-intersect? ]\r
} cond ;\r
\r
\r
: (class-and) ( first second -- class )\r
{\r
- { [ 2dup class< ] [ drop ] }\r
- { [ 2dup swap class< ] [ nip ] }\r
+ { [ 2dup class<= ] [ drop ] }\r
+ { [ 2dup swap class<= ] [ nip ] }\r
{ [ 2dup classes-intersect? not ] [ 2drop null ] }\r
{ [ dup members ] [ right-union-and ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }\r
\r
: (class-or) ( first second -- class )\r
{\r
- { [ 2dup class< ] [ nip ] }\r
- { [ 2dup swap class< ] [ drop ] }\r
+ { [ 2dup class<= ] [ nip ] }\r
+ { [ 2dup swap class<= ] [ drop ] }\r
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }\r
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }\r
[ 2array <anonymous-union> ]\r
[ <anonymous-complement> ]\r
} cond ;\r
\r
+: class< ( first second -- ? )\r
+ {\r
+ { [ 2dup class<= not ] [ 2drop f ] }\r
+ { [ 2dup swap class<= not ] [ 2drop t ] }\r
+ [ [ rank-class ] bi@ < ]\r
+ } cond ;\r
+\r
: largest-class ( seq -- n elt )\r
- dup [\r
- [ 2dup class< >r swap class< not r> and ]\r
- with filter empty?\r
- ] curry find [ "Topological sort failed" throw ] unless* ;\r
+ dup [ [ class< ] with contains? not ] curry find-last\r
+ [ "Topological sort failed" throw ] unless* ;\r
\r
: sort-classes ( seq -- newseq )\r
- >vector\r
+ [ [ word-name ] compare ] sort >vector\r
[ dup empty? not ]\r
[ dup largest-class >r over delete-nth r> ]\r
[ ] unfold nip ;\r
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
dup empty? [ 2drop f ] [\r
- tuck [ class< ] with all? [ peek ] [ drop f ] if\r
+ tuck [ class<= ] with all? [ peek ] [ drop f ] if\r
] if ;\r
\r
: (flatten-class) ( class -- )\r
\r
: flatten-builtin-class ( class -- assoc )\r
flatten-class [\r
- dup tuple class< [ 2drop tuple tuple ] when\r
+ dup tuple class<= [ 2drop tuple tuple ] when\r
] assoc-map ;\r
\r
: class-types ( class -- seq )\r
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
+
+M: builtin-class rank-class drop 0 ;
$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
+{ $subsection "class-linearization" }
{ $see-also "class-index" } ;
ABOUT: "classes"
M: union-1 generic-update-test drop "union-1" ;
-[ f ] [ bignum union-1 class< ] unit-test
-[ t ] [ union-1 number class< ] unit-test
+[ f ] [ bignum union-1 class<= ] unit-test
+[ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
"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
+[ t ] [ bignum union-1 class<= ] unit-test
+[ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
M: assoc-mixin collection-size assoc-size ;
-[ t ] [ array sequence-mixin class< ] unit-test
+[ t ] [ array sequence-mixin class<= ] unit-test
[ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
[ 3 ] [ { 1 2 3 } collection-size ] unit-test
[ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
INSTANCE: integer mx1
-[ t ] [ integer mx1 class< ] unit-test
-[ t ] [ mx1 integer class< ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
-[ t ] [ array mx1 class< ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ t ] [ array mx1 class<= ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
[ \ mx1 forget ] with-compilation-unit
UNION: redefine-bug-2 redefine-bug-1 quotation ;
-[ t ] [ fixnum redefine-bug-2 class< ] unit-test
-[ t ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
+[ t ] [ quotation redefine-bug-2 class<= ] 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
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
+[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
+[ t ] [ bignum redefine-bug-2 class<= ] unit-test
USE: io.streams.string
quotations combinators sorting effects graphs vocabs ;
IN: classes
-SYMBOL: class<-cache
+SYMBOL: class<=-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
SYMBOL: class-or-cache
: init-caches ( -- )
- H{ } clone class<-cache set
+ H{ } clone class<=-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
H{ } clone class-or-cache set ;
: reset-caches ( -- )
- class<-cache get clear-assoc
+ class<=-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
+GENERIC: rank-class ( class -- n )
+
GENERIC: reset-class ( class -- )
M: word reset-class drop ;
M: mixin-class reset-class
{ "class" "metaclass" "members" "mixin" } reset-props ;
+M: mixin-class rank-class drop 3 ;
+
: redefine-mixin-class ( class members -- )
dupd define-union-class
t "mixin" set-word-prop ;
"predicate-definition"
"superclass"
} reset-props ;
+
+M: predicate-class rank-class drop 1 ;
C: <laptop> laptop
[ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
-[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop tuple class<= ] unit-test
+[ t ] [ laptop computer class<= ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
C: <server> server
[ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
-[ t ] [ server computer class< ] unit-test
+[ t ] [ server tuple class<= ] unit-test
+[ t ] [ server computer class<= ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
-[ f ] [ server laptop class< ] unit-test
-[ f ] [ laptop server class< ] unit-test
+[ f ] [ server laptop class<= ] unit-test
+[ f ] [ laptop server class<= ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ f ] [ 1 2 <computer> laptop? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
-[ f ] [ electronic-device laptop class< ] unit-test
-[ t ] [ server electronic-device class< ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
+[ t ] [ server electronic-device class<= ] unit-test
+[ t ] [ laptop server class-or electronic-device class<= ] unit-test
[ t ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+
+TUPLE: subclass-forget-test ;
+
+TUPLE: subclass-forget-test-1 < subclass-forget-test ;
+TUPLE: subclass-forget-test-2 < subclass-forget-test ;
+TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
+
+[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+
+[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
+[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
+[ subclass-forget-test-3 new ] must-fail
dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n )
- superclasses 1 head-slice*
+ superclasses but-last-slice
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )
} reset-props
] bi ;
+M: tuple-class rank-class drop 0 ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;
+
+M: union-class rank-class drop 2 ;
inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
-inference ;
+inference combinators ;
IN: compiler
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
: save-effect ( word effect -- )
- over "compiled-uses" word-prop [
- 2dup swap "compiled-effect" word-prop =
- [ over ripple-up ] unless
- ] when
- "compiled-effect" set-word-prop ;
+ [
+ over "compiled-effect" word-prop = [
+ dup "compiled-uses" word-prop
+ [ dup ripple-up ] when
+ ] unless drop
+ ]
+ [ "compiled-effect" set-word-prop ] 2bi ;
-: finish-compile ( word effect dependencies -- )
- >r dupd save-effect r>
- over compiled-unxref
- over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
+: compile-begins ( word -- )
+ f swap compiler-error ;
-: compile-succeeded ( word -- effect dependencies )
+: compile-failed ( word error -- )
+ [ swap compiler-error ]
[
- [ word-dataflow optimize ] keep dup generate
- ] computing-dependencies ;
+ drop
+ [ f swap compiled get set-at ]
+ [ f save-effect ]
+ bi
+ ] 2bi ;
-: compile-failed ( word error -- )
- f pick compiled get set-at
- swap compiler-error ;
+: compile-succeeded ( effect word -- )
+ [ swap save-effect ]
+ [ compiled-unxref ]
+ [
+ dup compiled-crossref?
+ [ dependencies get compiled-xref ] [ drop ] if
+ ] tri ;
: (compile) ( word -- )
- f over compiler-error
- [ dup compile-succeeded finish-compile ]
- [ dupd compile-failed f save-effect ]
- recover ;
+ [
+ H{ } clone dependencies set
+
+ {
+ [ compile-begins ]
+ [
+ [ word-dataflow ] [ compile-failed return ] recover
+ optimize
+ ]
+ [ dup generate ]
+ [ compile-succeeded ]
+ } cleave
+ ] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [
HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
+{ $description "Prints a compiler error to " { $link output-stream } "." } ;
HELP: compiler-errors.
{ $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+ } "." } ;
+{ $description "Prints compiler errors to " { $link output-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." } ;
+{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
{ :errors :warnings } related-words
{ $code
"<external-resource> ... do stuff ... dispose"
}
-"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words
-kernel.private ;
+kernel.private accessors ;
IN: continuations.tests
: (callcc1-test)
"!!! The following error is part of the test" print
-[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
+[ ] [ [ [ "2 car" ] eval ] try ] unit-test
[ f throw ] must-fail
[ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test
] with-scope
+
+TUPLE: dispose-error ;
+
+M: dispose-error dispose 3 throw ;
+
+TUPLE: dispose-dummy disposed? ;
+
+M: dispose-dummy dispose t >>disposed? drop ;
+
+T{ dispose-error } "a" set
+T{ dispose-dummy } "b" set
+
+[ f ] [ "b" get disposed?>> ] unit-test
+
+[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
+
+[ t ] [ "b" get disposed?>> ] unit-test
+
+[ ] [ [ return ] with-return ] unit-test
: continue ( continuation -- )
f swap continue-with ;
+SYMBOL: return-continuation
+
+: with-return ( quot -- )
+ [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
+
+: return ( -- )
+ return-continuation get continue ;
+
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
GENERIC: dispose ( object -- )
+: dispose-each ( seq -- )
+ [
+ [ [ dispose ] curry [ , ] recover ] each
+ ] { } make dup empty? [ drop ] [ peek rethrow ] if ;
+
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
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 debugger.private
-io.files.private ;
+io.files.private listener ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
HELP: error.
{ $values { "error" "an error" } }
-{ $contract "Print an error to the " { $link stdio } " stream. You can define methods on this generic word to print human-readable messages for custom errors." }
+{ $contract "Print an error to " { $link output-stream } ". You can define methods on this generic word to print human-readable messages for custom errors." }
{ $notes "Code should call " { $link print-error } " instead, which handles the case where the printing of the error itself throws an error." } ;
HELP: error-help
HELP: print-error
{ $values { "error" "an error" } }
-{ $description "Print an error to the " { $link stdio } " stream." }
+{ $description "Print an error to " { $link output-stream } "." }
{ $notes "This word is called by the listener and other tools which report caught errors to the user." } ;
HELP: restarts.
-{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
-
-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." } ;
+{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
HELP: try
{ $values { "quot" "a quotation" } }
-{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
{ $examples
"The following example prints an error and keeps going:"
{ $code
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic hashtables inspector io kernel
-math namespaces prettyprint sequences assocs sequences.private
-strings io.styles vectors words system splitting math.parser
-classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes.builtin classes
-compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings mirrors accessors
-math.order ;
+math namespaces prettyprint prettyprint.config sequences assocs
+sequences.private strings io.styles vectors words system
+splitting math.parser classes.tuple continuations
+continuations.private combinators generic.math
+classes.builtin classes compiler.units generic.standard vocabs
+threads threads.private init kernel.private libc io.encodings
+mirrors accessors math.order ;
IN: debugger
GENERIC: error. ( error -- )
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
-SYMBOL: error-hook
-
-[
+: print-error-and-restarts ( error -- )
print-error
restarts.
nl
- "Type :help for debugging help." print flush
-] error-hook set-global
+ "Type :help for debugging help." print flush ;
: try ( quot -- )
- [ error-hook get call ] recover ;
+ [ print-error-and-restarts ] recover ;
ERROR: assert got expect ;
M: inconsistent-next-method summary
drop "Executing call-next-method with inconsistent parameters" ;
-M: stream-closed-twice summary
- drop "Attempt to perform I/O on closed stream" ;
-
M: check-method summary
drop "Invalid parameters for create-method" ;
M: assert summary drop "Assertion failed" ;
+M: assert error.
+ "Assertion failed" print
+ standard-table-style [
+ 15 length-limit set
+ 5 line-limit set
+ [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
+ [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
+ ] tabular-output ;
+
M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
M: realloc-error summary
drop "Memory reallocation failed" ;
-: error-in-thread. ( -- )
- error-thread get-global
+: error-in-thread. ( thread -- )
"Error in thread " write
[
dup thread-id #
die drop
] [
global [
- error-in-thread. print-error flush
+ error-thread get-global error-in-thread. print-error flush
] bind
] if ;
: %unbox-c-ptr ( dst src -- )
dup operand-class {
- { [ dup \ f class< ] [ drop %unbox-f ] }
- { [ dup simple-alien class< ] [ drop %unbox-alien ] }
- { [ dup byte-array class< ] [ drop %unbox-byte-array ] }
- { [ dup bit-array class< ] [ drop %unbox-byte-array ] }
- { [ dup float-array class< ] [ drop %unbox-byte-array ] }
+ { [ dup \ f class<= ] [ drop %unbox-f ] }
+ { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
+ { [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
+ { [ dup float-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
- [ class< ]
+ [ class<= ]
} case ;
: spec-matches? ( value spec -- ? )
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
- operand-class immediate class< ;
+ operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
IN: generic
ARTICLE: "method-order" "Method precedence"
-"Consider the case where a generic word has methods on two classes, say A and B, which share a non-empty intersection. If the generic word is called on an object which is an instance of both A and B, a choice of method must be made. If A is a subclass of B, the method for A to be called; this makes sense, because we're defining general behavior for instances of B, and refining it for instances of A. Conversely, if B is a subclass of A, then we expect B's method to be called. However, if neither is a subclass of the other, we have an ambiguous situation and undefined behavior will result. Either the method for A or B will be called, and there is no way to predict ahead of time."
-$nl
-"The generic word system linearly orders all the methods on a generic word by their class. Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in order. If methods are defined on overlapping classes, this order will fail to be unique and the problem described above can occur."
+"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
$nl
"Here is an example:"
{ $code
"GENERIC: explain"
- "M: number explain drop \"an integer\" print ;"
- "M: sequence explain drop \"a sequence\" print ;"
"M: object explain drop \"an object\" print ;"
+ "M: number explain drop \"a number\" print ;"
+ "M: sequence explain drop \"a sequence\" print ;"
}
-"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. As a result, the outcome of calling " { $snippet "bar" } " with an " { $link integer } " on the stack is undefined - either one of the two methods may be called. This situation can lead to subtle bugs. To avoid it, explicitly disambiguate the method order by defining a method on the intersection. If in this case we want integers to behave like numbers, we would also define:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
-"On the other hand, if we want integers to behave like sequences here, we could define:"
+"The linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number }" }
+"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
{ $code "M: integer explain drop \"a sequence\" print ;" }
-"The " { $link order } " word can be useful to clarify method dispatch order."
+"Now, the linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number integer }" }
+"The " { $link order } " word can be useful to clarify method dispatch order:"
{ $subsection order } ;
ARTICLE: "generic-introspection" "Generic word introspection"
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )
- order [ class< ] with filter reverse dup length 1 =
+ order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
dup null bootstrap-word eq? [
drop f
] [
- number bootstrap-word class<
+ number bootstrap-word class<=
] if ;
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
: math-precedence ( class -- pair )
{
- { [ dup null class< ] [ drop { -1 -1 } ] }
+ { [ dup null class<= ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
[ drop { 100 100 } ]
} cond ;
alist>quot ;
: split-methods ( assoc class -- first second )
- [ [ nip class< not ] curry assoc-filter ]
- [ [ nip class< ] curry assoc-filter ] 2bi ;
+ [ [ nip class<= not ] curry assoc-filter ]
+ [ [ nip class<= ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: keep-going? ( assoc -- ? )
- assumed get swap second first class< ;
+ assumed get swap second first class<= ;
: prune-redundant-predicates ( assoc -- default assoc' )
{
1 slot { tuple-layout } declare
5 slot ; inline
-: unclip-last [ 1 head* ] [ peek ] bi ;
-
M: tuple-dispatch-engine engine>quot
[
picker %
[ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
- [ value>> value-class* ] [ class>> ] bi class< ;
+ [ value>> value-class* ] [ class>> ] bi class<= ;
M: pair apply-constraint
first2 2dup constraints get set-at
HELP: infer.
{ $values { "quot" "a quotation" } }
-{ $description "Attempts to infer the quotation's stack effect, and prints this data to the " { $link stdio } " stream." }
+{ $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words
IN: inference.state.tests
-USING: tools.test inference.state words ;
+USING: tools.test inference.state words kernel namespaces ;
+
+: computing-dependencies ( quot -- dependencies )
+ H{ } clone [ dependencies rot with-variable ] keep ;
+ inline
SYMBOL: a
SYMBOL: b
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
-: computing-dependencies ( quot -- dependencies )
- H{ } clone [ dependencies rot with-variable ] keep ;
- inline
-
! Did the current control-flow path throw an error?
SYMBOL: terminated?
drop [ no-case ]
] [
dup peek quotation? [
- dup peek swap 1 head*
+ dup peek swap but-last
] [
[ no-case ] swap
] if case>quot
HELP: inspector-hook
{ $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
$nl
-"The default implementation calls " { $link describe } " which outputs on the " { $link stdio } " stream, but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
+"The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
{ $contract "Initializes the I/O system. Called on startup." } ;
HELP: init-stdio
-{ $contract "Initializes the global " { $link stdio } " stream. Called on startup." } ;
+{ $contract "Initializes the global " { $link input-stream } " and " { $link output-stream } ". Called on startup." } ;
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
: init-stdio ( -- )
- (init-stdio) utf8 <encoder> stderr set-global
- utf8 <encoder-duplex> stdio set-global ;
+ (init-stdio)
+ [ utf8 <decoder> input-stream set-global ]
+ [ utf8 <encoder> output-stream set-global ]
+ [ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( ms -- )
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax math ;
-IN: io.crc32
-
-HELP: crc32
-{ $values { "seq" "a sequence of bytes" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
-
-HELP: lines-crc32
-{ $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"
-"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
-{ $subsection crc32 }
-{ $subsection lines-crc32 } ;
-
-ABOUT: "io.crc32"
+++ /dev/null
-USING: io.crc32 kernel math tools.test namespaces ;
-
-[ 0 ] [ "" crc32 ] unit-test
-[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test
-
+++ /dev/null
-! Copyright (C) 2006 Doug Coleman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences sequences.private namespaces
-words io io.binary io.files io.streams.string quotations
-definitions ;
-IN: io.crc32
-
-: crc32-polynomial HEX: edb88320 ; inline
-
-: crc32-table V{ } ; inline
-
-256 [
- 8 [
- dup even? >r 2/ r> [ crc32-polynomial bitxor ] unless
- ] times >bignum
-] map 0 crc32-table copy
-
-: (crc32) ( crc ch -- crc )
- >bignum dupd bitxor
- mask-byte crc32-table nth-unsafe >bignum
- swap -8 shift bitxor ; inline
-
-: crc32 ( seq -- n )
- >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
-
-: lines-crc32 ( seq -- n )
- HEX: ffffffff tuck [
- [ (crc32) ] each CHAR: \n (crc32)
- ] reduce bitxor ;
+++ /dev/null
-CRC32 checksum algorithm
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
{ $subsection <encoder> }
-{ $subsection <decoder> }
-{ $subsection <encoder-duplex> } ;
+{ $subsection <decoder> } ;
HELP: <encoder>
{ $values { "stream" "an 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" } "." }
$low-level-note ;
-HELP: <encoder-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" } "." }
-$low-level-note ;
-
-{ <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:"
{ $subsection "io.encodings.binary" }
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 ]
+[ "resource:core/io/test/empty-file.txt" ascii <file-reader> lines ]
unit-test
: lines-test ( stream -- line1 line2 )
- [ readln readln ] with-stream ;
+ [ readln readln ] with-input-stream ;
[
"This is a line."
"This is another line."
] [
- "core/io/test/windows-eol.txt" <resource-reader> lines-test
+ "resource:core/io/test/windows-eol.txt"
+ ascii <file-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+ "resource:core/io/test/mac-os-eol.txt"
+ ascii <file-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "core/io/test/unix-eol.txt" <resource-reader> lines-test
+ "resource:core/io/test/unix-eol.txt"
+ ascii <file-reader> lines-test
] unit-test
[
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable
strings io classes continuations combinators io.styles
-io.streams.plain splitting io.streams.duplex byte-arrays
-sequences.private accessors ;
+io.streams.plain splitting byte-arrays sequences.private
+accessors ;
IN: io.encodings
! The encoding descriptor protocol
over decoder? [ >r decoder-stream r> ] when <decoder> ;
PRIVATE>
-
-: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
- tuck reencode >r redecode r> <duplex-stream> ;
{ $description "A unknown file type." } ;
HELP: <file-reader>
-{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
- { "stream" "an input stream" } }
+{
+ $values
+ { "path" "a pathname string" }
+ { "encoding" "an encoding descriptor" }
+ { "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: with-file-reader
{ $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 } "." }
+{ $description "Opens a file for reading and calls the quotation using " { $link with-input-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-writer
{ $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 } "." }
+{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-output-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender
{ $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 } "." }
+{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-output-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: set-file-lines
<file-reader> lines ;
: with-file-reader ( path encoding quot -- )
- >r <file-reader> r> with-stream ; inline
+ >r <file-reader> r> with-input-stream ; inline
: file-contents ( path encoding -- str )
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
- >r <file-writer> r> with-stream ; inline
+ >r <file-writer> r> with-output-stream ; inline
: set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ;
[ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- )
- >r <file-appender> r> with-stream ; inline
+ >r <file-appender> r> with-output-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
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."
+"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 " { $link with-input-stream } " and " { $link with-output-stream } "."
$nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl
{ $subsection stream-write-table }
{ $see-also "io.timeouts" } ;
-ARTICLE: "stdio" "The default stream"
-"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:"
+ARTICLE: "stdio" "Default input and output streams"
+"Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. 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." }
+ { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams 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-input-stream } " or " { $link with-output-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>"
+ "\"data.txt\" utf8 <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> ["
+ "\"data.txt\" utf8 <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> ["
+ "\"data.txt\" utf8 <file-reader> ["
" readln number>string read 16 group"
- "] with-stream"
+ "] with-input-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."
+"An even better implementation that takes advantage of a utility word:"
+{ $code
+ "USING: continuations kernel io io.files math.parser splitting ;"
+ "\"data.txt\" utf8 ["
+ " readln number>string read 16 group"
+ "] with-file-reader"
+}
+"The default input stream is stored in a dynamically-scoped variable:"
+{ $subsection input-stream }
+"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
+$nl
+"Words reading from the default input stream:"
{ $subsection read1 }
{ $subsection read }
{ $subsection read-until }
{ $subsection readln }
+"A pair of combinators for rebinding the " { $link input-stream } " variable:"
+{ $subsection with-input-stream }
+{ $subsection with-input-stream* }
+"The default output stream is stored in a dynamically-scoped variable:"
+{ $subsection output-stream }
+"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
+$nl
+"Words writing to the default input stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
{ $subsection with-row }
{ $subsection with-cell }
{ $subsection write-cell }
-"A pair of combinators support rebinding the " { $link stdio } " variable:"
-{ $subsection with-stream }
-{ $subsection with-stream* } ;
+"A pair of combinators for rebinding the " { $link output-stream } " variable:"
+{ $subsection with-output-stream }
+{ $subsection with-output-stream* }
+"A pair of combinators for rebinding both default streams at once:"
+{ $subsection with-streams }
+{ $subsection with-streams* } ;
ARTICLE: "stream-utils" "Stream utilities"
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
-HELP: stdio
-{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ;
+HELP: input-stream
+{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
+
+HELP: output-stream
+{ $var-description "Holds an output stream for various implicit stream operations. Rebound using " { $link with-output-stream } " and " { $link with-output-stream* } "." } ;
HELP: readln
{ $values { "str/f" "a string or " { $link f } } }
-{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
+{ $description "Reads a line of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read1
{ $values { "ch/f" "a character or " { $link f } } }
-{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." }
+{ $description "Reads a character of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read
{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } }
-{ $description "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 " { $link input-stream } ". Outputs a truncated string or " { $link f } " on stream exhaustion." }
$io-error ;
HELP: read-until
{ $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } }
-{ $contract "Reads characters from the " { $link stdio } " 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 } "." }
+{ $contract "Reads characters from " { $link input-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 } "." }
$io-error ;
HELP: write1
{ $values { "ch" "a character" } }
-{ $contract "Writes a character of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
+{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: write
{ $values { "str" string } }
-{ $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." }
+{ $description "Writes a string of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ;
HELP: flush
-{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." }
+{ $description "Waits for any pending output on " { $link output-stream } " to complete." }
$io-error ;
HELP: nl
-{ $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." }
+{ $description "Writes a line terminator to " { $link output-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" } }
-{ $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." }
+{ $description "Writes formatted text to " { $link output-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" } }
-{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." }
+{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } }
-{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on the " { $link stdio } " stream."
+{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $examples
HELP: with-cell
{ $values { "quot" quotation } }
-{ $description "Calls a quotation in a new scope with the " { $link stdio } " stream rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
+{ $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ;
HELP: write-cell
$io-error ;
HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" "a quotation" } }
+{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;
HELP: print
{ $values { "string" string } }
-{ $description "Writes a newline-terminated string to the " { $link stdio } " stream." }
+{ $description "Writes a newline-terminated string to " { $link output-stream } "." }
$io-error ;
-HELP: with-stream
-{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
-{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+HELP: with-input-stream
+{ $values { "stream" "an input stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+
+HELP: with-output-stream
+{ $values { "stream" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+
+HELP: with-streams
+{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } ". The stream is closed if the quotation returns or throws an error." } ;
+
+HELP: with-streams*
+{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-streams } "." } ;
+
+{ with-input-stream with-input-stream* } related-words
+
+{ with-output-stream with-output-stream* } related-words
-{ with-stream with-stream* } related-words
+HELP: with-input-stream*
+{ $values { "stream" "an input stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-input-stream } "." } ;
-HELP: with-stream*
-{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } }
-{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." }
-{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
+HELP: with-output-stream*
+{ $values { "stream" "an output stream" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-output-stream } "." } ;
HELP: bl
-{ $description "Outputs a space character (" { $snippet "\" \"" } ")." }
+{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
$io-error ;
HELP: write-object
{ $values { "str" string } { "obj" "an object" } }
-{ $description "Writes a string to the " { $link stdio } " stream, associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
+{ $description "Writes a string to " { $link output-stream } ", associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
$io-error ;
HELP: lines
"foo" "io.tests" lookup
] unit-test
-: <resource-reader> ( resource -- stream )
- resource-path latin1 <file-reader> ;
-
[
"This is a line.\rThis is another line.\r"
] [
- "core/io/test/mac-os-eol.txt" <resource-reader>
- [ 500 read ] with-stream
+ "resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
+ [ 500 read ] with-input-stream
] unit-test
[
255
] [
- "core/io/test/binary.txt" <resource-reader>
- [ read1 ] with-stream >fixnum
+ "resource:core/io/test/binary.txt" latin1 <file-reader>
+ [ read1 ] with-input-stream >fixnum
] unit-test
! Make sure we use correct to_c_string form when writing
}
] [
[
- "core/io/test/separator-test.txt" <resource-reader> [
+ "resource:core/io/test/separator-test.txt"
+ latin1 <file-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,
- ] with-stream
+ ] with-input-stream
] { } make
] unit-test
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
-
-! [ "" ] [ 0 read ] unit-test
-
-! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
-
-! [
-! "/core/io/test/binary.txt" <resource-reader>
-! [ 0.2 read ] with-stream
-! ] must-fail
[ 2dup (stream-copy) ] [ dispose dispose ] [ ]
cleanup ;
-! Default stream
-SYMBOL: stdio
+! Default streams
+SYMBOL: input-stream
+SYMBOL: output-stream
+SYMBOL: error-stream
-! Default error stream
-SYMBOL: stderr
+: readln ( -- str/f ) input-stream get stream-readln ;
+: read1 ( -- ch/f ) input-stream get stream-read1 ;
+: read ( n -- str/f ) input-stream get stream-read ;
+: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ;
-: readln ( -- str/f ) stdio get stream-readln ;
-: read1 ( -- ch/f ) stdio get stream-read1 ;
-: read ( n -- str/f ) stdio get stream-read ;
-: read-until ( seps -- str/f sep/f ) stdio get stream-read-until ;
+: write1 ( ch -- ) output-stream get stream-write1 ;
+: write ( str -- ) output-stream get stream-write ;
+: flush ( -- ) output-stream get stream-flush ;
-: write1 ( ch -- ) stdio get stream-write1 ;
-: write ( str -- ) stdio get stream-write ;
-: flush ( -- ) stdio get stream-flush ;
+: nl ( -- ) output-stream get stream-nl ;
+: format ( str style -- ) output-stream get stream-format ;
-: nl ( -- ) stdio get stream-nl ;
-: format ( str style -- ) stdio get stream-format ;
+: with-input-stream* ( stream quot -- )
+ input-stream swap with-variable ; inline
-: with-stream* ( stream quot -- )
- stdio swap with-variable ; inline
+: with-input-stream ( stream quot -- )
+ [ with-input-stream* ] curry with-disposal ; inline
-: with-stream ( stream quot -- )
- [ with-stream* ] curry with-disposal ; inline
+: with-output-stream* ( stream quot -- )
+ output-stream swap with-variable ; inline
+
+: with-output-stream ( stream quot -- )
+ [ with-output-stream* ] curry with-disposal ; inline
+
+: with-streams* ( input output quot -- )
+ [ output-stream set input-stream set ] prepose with-scope ; inline
+
+: with-streams ( input output quot -- )
+ [ [ with-streams* ] 3curry ]
+ [ [ drop dispose dispose ] 3curry ] 3bi
+ [ ] cleanup ; inline
: tabular-output ( style quot -- )
- swap >r { } make r> stdio get stream-write-table ; inline
+ swap >r { } make r> output-stream get stream-write-table ; inline
: with-row ( quot -- )
{ } make , ; inline
: with-cell ( quot -- )
- H{ } stdio get make-cell-stream
- [ swap with-stream ] keep , ; inline
+ H{ } output-stream get make-cell-stream
+ [ swap with-output-stream ] keep , ; inline
: write-cell ( str -- )
[ write ] with-cell ; inline
swap dup assoc-empty? [
drop call
] [
- stdio get make-span-stream swap with-stream
+ output-stream get make-span-stream swap with-output-stream
] if ; inline
: with-nesting ( style quot -- )
- >r stdio get make-block-stream r> with-stream ; inline
+ >r output-stream get make-block-stream
+ r> with-output-stream ; inline
-: print ( string -- ) stdio get stream-print ;
+: print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ;
presented associate format ;
: lines ( stream -- seq )
- [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
+ [ [ readln dup ] [ ] [ drop ] unfold ] with-input-stream ;
: contents ( stream -- str )
[
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
- ] with-stream ;
+ ] with-input-stream ;
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." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " 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." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces io.encodings.private ;
+sequences io namespaces io.encodings.private accessors ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array )
- >r <byte-writer> r> [ stdio get ] compose with-stream*
- dup encoder? [ encoder-stream ] when >byte-array ; inline
+ >r <byte-writer> r> [ output-stream get ] compose with-output-stream*
+ dup encoder? [ stream>> ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
- >r <byte-reader> r> with-stream ; inline
+ >r <byte-reader> r> with-input-stream* ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend
-io.streams.duplex io.files continuations byte-arrays ;
+io.files continuations byte-arrays ;
IN: io.streams.c
TUPLE: c-writer handle ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax io continuations ;
-IN: io.streams.duplex
-
-ARTICLE: "io.streams.duplex" "Duplex streams"
-"Duplex streams combine an input stream and an output stream into a bidirectional stream."
-{ $subsection duplex-stream }
-{ $subsection <duplex-stream> } ;
-
-ABOUT: "io.streams.duplex"
-
-HELP: duplex-stream
-{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
-
-HELP: <duplex-stream>
-{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
-{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
-
-HELP: stream-closed-twice
-{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
+++ /dev/null
-USING: io.streams.duplex io kernel continuations tools.test ;
-IN: io.streams.duplex.tests
-
-! Test duplex stream close behavior
-TUPLE: closing-stream closed? ;
-
-: <closing-stream> closing-stream new ;
-
-M: closing-stream dispose
- dup closing-stream-closed? [
- "Closing twice!" throw
- ] [
- t swap set-closing-stream-closed?
- ] if ;
-
-TUPLE: unclosable-stream ;
-
-: <unclosable-stream> unclosable-stream new ;
-
-M: unclosable-stream dispose
- "Can't close me!" throw ;
-
-[ ] [
- <closing-stream> <closing-stream> <duplex-stream>
- dup dispose dispose
-] unit-test
-
-[ t ] [
- <unclosable-stream> <closing-stream> [
- <duplex-stream>
- [ dup dispose ] [ 2drop ] recover
- ] keep closing-stream-closed?
-] unit-test
-
-[ t ] [
- <closing-stream> [ <unclosable-stream>
- <duplex-stream>
- [ dup dispose ] [ 2drop ] recover
- ] keep closing-stream-closed?
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations io accessors ;
-IN: io.streams.duplex
-
-! We ensure that the stream can only be closed once, to preserve
-! integrity of duplex I/O ports.
-
-TUPLE: duplex-stream in out closed ;
-
-: <duplex-stream> ( in out -- stream )
- f duplex-stream boa ;
-
-ERROR: stream-closed-twice ;
-
-<PRIVATE
-
-: check-closed ( stream -- stream )
- dup closed>> [ stream-closed-twice ] when ; inline
-
-: in ( duplex -- stream ) check-closed in>> ;
-
-: out ( duplex -- stream ) check-closed out>> ;
-
-PRIVATE>
-
-M: duplex-stream stream-flush
- out stream-flush ;
-
-M: duplex-stream stream-readln
- in stream-readln ;
-
-M: duplex-stream stream-read1
- in stream-read1 ;
-
-M: duplex-stream stream-read-until
- in stream-read-until ;
-
-M: duplex-stream stream-read-partial
- in stream-read-partial ;
-
-M: duplex-stream stream-read
- in stream-read ;
-
-M: duplex-stream stream-write1
- out stream-write1 ;
-
-M: duplex-stream stream-write
- out stream-write ;
-
-M: duplex-stream stream-nl
- out stream-nl ;
-
-M: duplex-stream stream-format
- out stream-format ;
-
-M: duplex-stream make-span-stream
- out make-span-stream ;
-
-M: duplex-stream make-block-stream
- out make-block-stream ;
-
-M: duplex-stream make-cell-stream
- out make-cell-stream ;
-
-M: duplex-stream stream-write-table
- out stream-write-table ;
-
-M: duplex-stream dispose
- #! The output stream is closed first, in case both streams
- #! are attached to the same file descriptor, the output
- #! buffer needs to be flushed before we close the fd.
- dup closed>> [
- t >>closed
- [ dup out>> dispose ]
- [ dup in>> dispose ] [ ] cleanup
- ] unless drop ;
+++ /dev/null
-Combine an input and an output stream into a single duplex stream
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
HELP: <string-reader>
{ $values { "str" string } { "stream" "an input stream" } }
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." } ;
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ;
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,
- ] with-stream
+ ] with-input-stream
] { } make
] unit-test
512 <sbuf> ;
: with-string-writer ( quot -- str )
- <string-writer> swap [ stdio get ] compose with-stream*
+ <string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
>sbuf dup reverse-here null <decoder> ;
: with-string-reader ( str quot -- )
- >r <string-reader> r> with-stream ; inline
+ >r <string-reader> r> with-input-stream ; inline
INSTANCE: growable plain-writer
] unless ;
: map-last ( seq quot -- seq )
- swap dup length <reversed>
- [ zero? rot [ call ] keep swap ] 2map nip ; inline
+ >r dup length <reversed> [ zero? ] r> compose 2map ; 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* ;
+ [ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
HELP: read-quot
{ $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." } ;
+{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-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." } ;
+{ $description "Prompts for an expression on " { $link input-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 " { $link output-stream } " and the word returns normally." } ;
HELP: listener
-{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ;
+{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
HELP: bye
{ $description "Exits the current listener." }
[
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
- drop
+ drop
] unit-test
] with-file-vocabs
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
-io.streams.duplex vectors words generic system combinators
-continuations debugger definitions compiler.units accessors ;
+vectors words generic system combinators continuations debugger
+definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
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/f ) stdio get stream-read-quot ;
+: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
: bye ( -- ) quit-flag on ;
"( " in get " )" 3append
H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
+SYMBOL: error-hook
+
+[ print-error-and-restarts ] error-hook set-global
+
: listen ( -- )
listener-hook get call prompt.
- [ read-quot [ try ] [ bye ] if* ]
+ [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup parse-error? [
error-hook get call
M: real hashcode* nip >fixnum ;
-! real and sequence overlap. we disambiguate:
-M: integer hashcode* nip >fixnum ;
-
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: invert-comparison
-{ $values { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" }
- { "new-symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
+{ $values { "symbol" symbol }
+ { "new-symbol" symbol } }
{ $description "Invert the comparison symbol returned by " { $link <=> } ". The output for the symbol " { $snippet "+eq+" } " is itself." }
{ $examples
{ $example "USING: math.order prettyprint ;" "+lt+ invert-comparison ." "+gt+" } } ;
SYMBOL: +eq+
SYMBOL: +gt+
-GENERIC: <=> ( obj1 obj2 -- symbol )
-
-: (<=>) ( a b -- symbol )
- 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
-
: invert-comparison ( symbol -- new-symbol )
#! Can't use case, index or nth here
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
-M: real <=> (<=>) ;
-M: integer <=> (<=>) ;
+GENERIC: <=> ( obj1 obj2 -- symbol )
+
+M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
GENERIC: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? )
[ 1 1 >base ] must-fail
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
+
+[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
+
+[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
+
+[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
M: float >base
drop {
+ { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
- { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
[ float>string fix-float ]
} cond ;
node-literal t
] [
node-class {
- { [ dup null class< ] [ drop f f ] }
- { [ dup \ f class-not class< ] [ drop t t ] }
- { [ dup \ f class< ] [ drop f t ] }
+ { [ dup null class<= ] [ drop f f ] }
+ { [ dup \ f class-not class<= ] [ drop t t ] }
+ { [ dup \ f class<= ] [ drop f t ] }
[ drop f f ]
} cond
] if ;
IN: optimizer.def-use.tests
USING: inference inference.dataflow optimizer optimizer.def-use
-namespaces assocs kernel sequences math tools.test words ;
+namespaces assocs kernel sequences math tools.test words sets ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use drop
dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ;
-: subset? [ member? ] curry all? ;
-
-: set= 2dup subset? >r swap subset? r> and ;
-
[ { [ + ] } ] [
[ [ 1 2 3 ] [ + ] over drop drop ] kill-set
] unit-test
float real
complex number
object
- } [ class< ] with find nip ;
+ } [ class<= ] with find nip ;
: inlining-math-method ( #call word -- quot/f )
swap node-input-classes
: 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 ;
+ 2dup class<= >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [
: evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r
- node-class-first r> class< ;
+ node-class-first r> class<= ;
: optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it
USING: alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces
-assocs quotations sequences.private io.binary io.crc32
+assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend
\ >sbuf { string } "specializer" set-word-prop
-\ crc32 { string } "specializer" set-word-prop
-
\ split, { string string } "specializer" set-word-prop
\ memq? { array } "specializer" set-word-prop
: math-closure ( class -- newclass )
{ null fixnum bignum integer rational float real number }
- [ class< ] with find nip number or ;
+ [ class<= ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
dup r> at swap or ;
: won't-overflow? ( interval node -- ? )
- node-in-d [ value-class* fixnum class< ] all?
+ node-in-d [ value-class* fixnum class<= ] all?
swap fixnum fits? and ;
: post-process ( class interval node -- classes intervals )
: twiddle-interval ( i1 -- i2 )
dup [
node get node-in-d
- [ value-class* integer class< ] all?
+ [ value-class* integer class<= ] all?
[ integral-closure ] when
] when ;
! Removing overflow checks
: remove-overflow-check? ( #call -- ? )
dup out-d>> first node-class
- [ fixnum class< ] [ null eq? not ] bi and ;
+ [ fixnum class<= ] [ null eq? not ] bi and ;
{
{ + [ fixnum+fast ] }
dup #call? [ node-param eq? ] [ 2drop f ] if ;
: coerced-to-fixnum? ( #call -- ? )
- dup dup node-in-d [ node-class integer class< ] with all?
+ dup dup node-in-d [ node-class integer class<= ] with all?
[ \ >fixnum consumed-by? ] [ drop f ] if ;
{
: convert-rem-to-and? ( #call -- ? )
dup node-in-d {
- { [ 2dup first node-class integer class< not ] [ f ] }
+ { [ 2dup first node-class integer class<= not ] [ f ] }
{ [ 2dup second node-literal integer? not ] [ f ] }
{ [ 2dup second node-literal power-of-2? not ] [ f ] }
[ t ]
@ get [ eq? ] [ @ set t ] if* ;
: match-class ( value spec -- ? )
- >r node get swap node-class r> class< ;
+ >r node get swap node-class r> class<= ;
: value-match? ( value spec -- ? )
{
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
-"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, a message is printed to the " { $link stdio } " stream. Except when debugging suspected name clashes, these messages can be ignored."
+"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
$nl
"Here is an example where shadowing occurs:"
{ $code
"USING: sequences io ;"
""
": append"
- " \"foe::append calls sequences::append\" print append ;"
+ " \"foe::append calls sequences:append\" print append ;"
""
"IN: fee"
""
": append"
- " \"fee::append calls fee::append\" print append ;"
+ " \"fee::append calls fee:append\" print append ;"
""
"IN: fox"
"USE: foe"
""
": append"
- " \"fox::append calls foe::append\" print append ;"
+ " \"fox::append calls foe:append\" print append ;"
""
"\"1234\" \"5678\" append print"
""
}
"When placed in a source file and run, the above code produces the following output:"
{ $code
- "foe::append calls sequences::append"
+ "foe:append calls sequences:append"
"12345678"
- "fee::append calls foe::append"
- "foe::append calls sequences::append"
+ "fee:append calls foe:append"
+ "foe:append calls sequences:append"
"12345678"
-} ;
+}
+"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
HELP: parser-notes
-{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ;
+{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
HELP: parser-notes?
{ $values { "?" "a boolean" } }
HELP: eval>string
{ $values { "str" string } { "output" string } }
-{ $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ;
+{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
HELP: staging-violation
{ $values { "word" word } }
] must-fail
[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
+
+[ 92 ] [ "CHAR: \\" eval ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval ] unit-test
SYMBOL: current-class
SYMBOL: current-generic
-: (M:)
- CREATE-METHOD
+: with-method-definition ( quot -- parsed )
[
+ >r
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
- parse-definition
- ] with-scope ;
+ r> call
+ ] with-scope ; inline
+
+: (M:)
+ CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object )
scan-word dup parsing?
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays bit-arrays generic hashtables io
-assocs kernel math namespaces sequences strings sbufs io.styles
-vectors words prettyprint.config prettyprint.sections quotations
-io io.files math.parser effects classes.tuple math.order
-classes.tuple.private classes float-arrays ;
+USING: arrays byte-arrays byte-vectors bit-arrays generic
+hashtables io assocs kernel math namespaces sequences strings
+sbufs io.styles vectors words prettyprint.config
+prettyprint.sections quotations io io.files math.parser effects
+classes.tuple math.order classes.tuple.private classes
+float-arrays ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
+M: byte-vector pprint-delims drop \ BV{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
+M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
$nl
"Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary."
$nl
-"The key words to print an object to the " { $link stdio } " stream; the first two emit a trailing newline, the second two do not:"
+"The key words to print an object to " { $link output-stream } "; the first two emit a trailing newline, the second two do not:"
{ $subsection . }
{ $subsection short. }
{ $subsection pprint }
HELP: with-pprint
{ $values { "obj" object } { "quot" quotation } }
-{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to the " { $link stdio } " stream." } ;
+{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;
HELP: pprint
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
{ pprint pprint* with-pprint } related-words
HELP: .
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
HELP: unparse
{ $values { "obj" object } { "str" "Factor source string" } }
HELP: pprint-short
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
HELP: short.
{ $values { "obj" object } }
-{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
HELP: .b
{ $values { "n" "an integer" } }
[ parse-fresh drop ] with-compilation-unit
[
"prettyprint.tests" lookup see
- ] with-string-writer "\n" split 1 head*
+ ] with-string-writer "\n" split but-last
] keep =
] with-scope ;
HELP: do-indent
-{ $description "Outputs the current indent nesting to the " { $link stdio } " stream." } ;
+{ $description "Outputs the current indent nesting to " { $link output-stream } "." } ;
HELP: fresh-line
{ $values { "n" "the current column position" } }
SYMBOL: pprinter-in
SYMBOL: pprinter-use
-TUPLE: pprinter last-newline line-count end-printing indent ;
+TUPLE: pprinter last-newline line-count indent ;
-: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
+: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
] [
pprinter get (>>last-newline)
line-limit? [
- "..." write pprinter get end-printing>> continue
+ "..." write pprinter get return
] when
pprinter get [ 1+ ] change-line-count drop
nl do-indent
[
dup style>> [
[
- >r pprinter get (>>end-printing) r>
short-section
- ] curry callcc0
+ ] curry with-return
] with-nesting
] if-nonempty
] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
- dup peek line-break? [ 1 head-slice* chop-break ] when ;
+ dup peek line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
-{ $subsection rest }
{ $subsection head* }
{ $subsection tail* }
+"Removing the first or last element:"
+{ $subsection rest }
+{ $subsection but-last }
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip }
{ $subsection cut }
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
+{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
+HELP: but-last-slice
+{ $values { "seq" sequence } { "slice" "a slice" } }
+{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
+{ $errors "Throws an error on an empty sequence." } ;
+
HELP: rest-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
{ $notes "Equivalent to " { $snippet "1 tail" } }
-{ $errors "Throws an error if the index is out of bounds." } ;
+{ $errors "Throws an error on an empty sequence." } ;
HELP: head-slice*
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
+HELP: but-last
+{ $values { "seq" sequence } { "headseq" "a new sequence" } }
+{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
+{ $errors "Throws an error on an empty sequence." } ;
+
HELP: rest
{ $values { "seq" sequence } { "tailseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the first item removed." }
: tail-slice* ( seq n -- slice ) from-end tail-slice ;
+: but-last-slice ( seq -- slice ) 1 head-slice* ;
+
INSTANCE: slice virtual-sequence
! One element repeated many times
: tail* ( seq n -- tailseq ) from-end tail ;
+: but-last ( seq -- headseq ) 1 head* ;
+
: copy ( src i dst -- )
pick length >r 3dup check-copy spin 0 r>
(copy) drop ; inline
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
+: unclip-last ( seq -- butfirst last )
+ [ but-last ] [ peek ] bi ;
+
: unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ;
+: unclip-last-slice ( seq -- butfirst last )
+ [ but-last-slice ] [ peek ] bi ;
+
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
-"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
$nl
"Remove duplicates:"
{ $subsection prune }
{ $subsection diff }
{ $subsection intersect }
{ $subsection union }
+{ $subsection subset? }
+{ $subsection set= }
+"A word used to implement the above:"
+{ $subsection unique }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
+ABOUT: "sets"
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
} ;
{ diff intersect union } related-words
+
+HELP: subset?
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
+
+HELP: set=
+{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
+{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
: union ( seq1 seq2 -- newseq )
append prune ;
+
+: subset? ( seq1 seq2 -- ? )
+ unique [ key? ] curry all? ;
+
+: set= ( seq1 seq2 -- ? )
+ [ unique ] bi@ = ;
USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
-continuations debugger io.files io.crc32 vocabs hashtables
-graphs compiler.units io.encodings.utf8 accessors ;
+continuations debugger io.files checksums checksums.crc32 vocabs
+hashtables graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
uses definitions ;
: record-checksum ( lines source-file -- )
- >r lines-crc32 r> set-source-file-checksum ;
+ >r crc32 checksum-lines r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname>
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces strings arrays vectors sequences
-sets math.order ;
+sets math.order accessors ;
IN: splitting
-TUPLE: groups seq n sliced? ;
+TUPLE: abstract-groups seq n ;
-: check-groups 0 <= [ "Invalid group count" throw ] when ;
+: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
-: <groups> ( seq n -- groups )
- dup check-groups f groups boa ; inline
+: construct-groups ( seq n class -- groups )
+ >r check-groups r> boa ; inline
-: <sliced-groups> ( seq n -- groups )
- <groups> t over set-groups-sliced? ;
+GENERIC: group@ ( n groups -- from to seq )
+
+M: abstract-groups nth group@ subseq ;
+
+M: abstract-groups set-nth group@ <slice> 0 swap copy ;
+
+M: abstract-groups like drop { } like ;
+
+INSTANCE: abstract-groups sequence
+
+TUPLE: groups < abstract-groups ;
+
+: <groups> ( seq n -- groups )
+ groups construct-groups ; inline
M: groups length
- dup groups-seq length swap groups-n [ + 1- ] keep /i ;
+ [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
M: groups set-length
- [ groups-n * ] keep groups-seq set-length ;
+ [ n>> * ] [ seq>> ] bi set-length ;
-: group@ ( n groups -- from to seq )
- [ groups-n [ * dup ] keep + ] keep
- groups-seq [ length min ] keep ;
+M: groups group@
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-M: groups nth
- [ group@ ] keep
- groups-sliced? [ <slice> ] [ subseq ] if ;
+TUPLE: sliced-groups < groups ;
-M: groups set-nth
- group@ <slice> 0 swap copy ;
+: <sliced-groups> ( seq n -- groups )
+ sliced-groups construct-groups ; inline
+
+M: sliced-groups nth group@ <slice> ;
+
+TUPLE: clumps < abstract-groups ;
+
+: <clumps> ( seq n -- groups )
+ clumps construct-groups ; inline
+
+M: clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
-M: groups like drop { } like ;
+M: clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
-INSTANCE: groups sequence
+M: clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+TUPLE: sliced-clumps < groups ;
+
+: <sliced-clumps> ( seq n -- groups )
+ sliced-clumps construct-groups ; inline
+
+M: sliced-clumps nth group@ <slice> ;
: group ( seq n -- array ) <groups> { } like ;
+: clump ( seq n -- array ) <clumps> { } like ;
+
: ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ;
1array
] [
"\n" split [
- 1 head-slice* [
+ but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays byte-arrays
+USING: alien arrays bit-arrays byte-arrays byte-vectors
definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
+ "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"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."
+{ $values { "dt" "a duration" } }
+{ $description "Suspends the current thread for the given duration."
$nl
-"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." }
+{ $examples
+ { $code "USING: threads calendar ;" "10 seconds sleep" }
+} ;
HELP: interrupt
{ $values { "thread" thread } }
USING: namespaces io tools.test threads kernel
-concurrency.combinators math ;
+concurrency.combinators concurrency.promises locals math
+words ;
IN: threads.tests
3 "x" set
"i" tget
] parallel-map
] unit-test
+
+[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
+
+:: spawn-namespace-test ( -- )
+ [let | p [ <promise> ] g [ gensym ] |
+ [
+ g "x" set
+ [ "x" get p fulfill ] "B" spawn drop
+ ] with-scope
+ p ?promise g eq?
+ ] ;
+
+[ t ] [ spawn-namespace-test ] unit-test
TUPLE: thread
name quot exit-handler
id
-continuation state
+continuation state runnable
mailbox variables sleep-entry ;
: self ( -- thread ) 40 getenv ; inline
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
+DEFER: stop
+
<PRIVATE
-: schedule-sleep ( thread ms -- )
+: schedule-sleep ( thread dt -- )
>r check-registered dup r> sleep-queue heap-push*
>>sleep-entry drop ;
[ ] while
drop ;
+: start ( namestack thread -- )
+ [
+ set-self
+ set-namestack
+ V{ } set-catchstack
+ { } set-retainstack
+ { } set-datastack
+ self quot>> [ call stop ] call-clear
+ ] 2 (throw) ;
+
+DEFER: next
+
+: no-runnable-threads ( -- * )
+ ! 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.
+ sleep-time [ die 0 ] unless* (sleep) next ;
+
+: (next) ( arg thread -- * )
+ f >>state
+ dup set-self
+ dup runnable>> [
+ continuation>> box> continue-with
+ ] [
+ t >>runnable start
+ ] if ;
+
: 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
+ drop no-runnable-threads
] [
- pop-back
- dup array? [ first2 ] [ f swap ] if dup set-self
- f >>state
- continuation>> box>
- continue-with
+ pop-back dup array? [ first2 ] [ f swap ] if (next)
] if ;
PRIVATE>
: stop ( -- )
- self dup exit-handler>> call
- unregister-thread next ;
+ self [ exit-handler>> call ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
- self continuation>> >box
- self (>>state)
- self swap call next
+ >r
+ >r self swap call
+ r> self (>>state)
+ r> self continuation>> >box
+ next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ;
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
-GENERIC: sleep ( ms -- )
+GENERIC: sleep ( dt -- )
M: real sleep
millis + >integer sleep-until ;
] when drop ;
: (spawn) ( thread -- )
- [
- resume-now [
- dup set-self
- dup register-thread
- V{ } set-catchstack
- { } set-retainstack
- >r { } set-datastack r>
- quot>> [ call stop ] call-clear
- ] 1 (throw)
- ] "spawn" suspend 2drop ;
+ [ register-thread ] [ namestack swap resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
>r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- )
- >r datastack namestack r>
- [ >r set-namestack set-datastack r> call ] 3curry
+ >r datastack r>
+ [ >r set-datastack r> call ] 2curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
initial-thread global
[ drop f "Initial" <thread> ] cache
<box> >>continuation
+ t >>runnable
f >>state
dup register-thread
set-self ;
USING: asn1 asn1.ldap io io.streams.string tools.test ;
[ 6 ] [
- "\u000002\u000001\u000006" <string-reader> [ asn-syntax read-ber ] with-stream
+ "\u000002\u000001\u000006" <string-reader> [ asn-syntax read-ber ] with-input-stream
] unit-test
[ "testing" ] [
- "\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-stream
+ "\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-input-stream
] unit-test
[ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
"0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus"
- <string-reader> [ asn-syntax read-ber ] with-stream
+ <string-reader> [ asn-syntax read-ber ] with-input-stream
] unit-test
[
SYMBOL: end
-: (read-array) ( stream -- )
+: (read-array) ( -- )
elements get element-id [
elements get element-syntax read-ber
dup end = [ drop ] [ , (read-array) ] if
: read-array ( -- array ) [ (read-array) ] { } make ;
-: set-case ( -- )
+: set-case ( -- object )
elements get element-newobj
elements get element-objtype {
{ "boolean" [ "\0" = not ] }
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors arrays bank calendar kernel math math.functions namespaces tools.test tools.walker ;
+IN: bank.tests
+
+SYMBOL: my-account
+[
+ "Alex's Take Over the World Fund" 0.07 1 2007 11 1 <date> 6101.94 open-account my-account set
+ [ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
+ [ 6137 ] [ my-account get 2007 12 2 <date> process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+ "Petty Cash" 0.07 1 2006 12 1 <date> 10962.18 open-account my-account set
+ [ 11027 ] [ my-account get 2007 1 2 <date> process-to-date balance>> round >integer ] unit-test
+] with-scope
+
+[
+ "Saving to buy a pony" 0.0725 1 2008 3 3 <date> 11106.24 open-account my-account set
+ [ 8416 ] [
+ my-account get [
+ 2008 3 11 <date> -750 "Need to buy food" <transaction> ,
+ 2008 3 25 <date> -500 "Going to a party" <transaction> ,
+ 2008 4 8 <date> -800 "Losing interest in the pony..." <transaction> ,
+ 2008 4 8 <date> -700 "Buying a rocking horse" <transaction> ,
+ ] { } make inserting-transactions balance>> round >integer
+ ] unit-test
+] with-scope
+
+[
+ [ 6781 ] [
+ "..." 0.07 1 2007 4 10 <date> 4398.50 open-account
+ 2007 10 26 <date> 2000 "..." <transaction> 1array inserting-transactions
+ 2008 4 10 <date> process-to-date dup balance>> swap unpaid-interest>> + round >integer
+ ] unit-test
+] with-scope
--- /dev/null
+USING: accessors calendar kernel math math.order money sequences ;
+IN: bank
+
+TUPLE: account name interest-rate interest-payment-day opening-date transactions unpaid-interest interest-last-paid ;
+
+: <account> ( name interest-rate interest-payment-day opening-date -- account )
+ V{ } clone 0 pick account boa ;
+
+TUPLE: transaction date amount description ;
+C: <transaction> transaction
+
+: >>transaction ( account transaction -- account )
+ over transactions>> push ;
+
+: total ( transactions -- balance )
+ 0 [ amount>> + ] reduce ;
+
+: balance>> ( account -- balance ) transactions>> total ;
+
+: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
+ >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
+
+: daily-rate ( yearly-rate day -- daily-rate )
+ days-in-year / ;
+
+: daily-rate>> ( account date -- rate )
+ [ interest-rate>> ] dip daily-rate ;
+
+: transactions-on-date ( account date -- transactions )
+ [ before? ] curry filter ;
+
+: balance-on-date ( account date -- balance )
+ transactions-on-date total ;
+
+: pay-interest ( account date -- )
+ over unpaid-interest>> "Interest Credit" <transaction>
+ >>transaction 0 >>unpaid-interest drop ;
+
+: interest-payment-day? ( account date -- ? )
+ day>> swap interest-payment-day>> = ;
+
+: ?pay-interest ( account date -- )
+ 2dup interest-payment-day? [ pay-interest ] [ 2drop ] if ;
+
+: unpaid-interest+ ( account amount -- account )
+ over unpaid-interest>> + >>unpaid-interest ;
+
+: accumulate-interest ( account date -- )
+ [ dupd daily-rate>> over balance>> * unpaid-interest+ ] keep
+ >>interest-last-paid drop ;
+
+: process-day ( account date -- )
+ 2dup accumulate-interest ?pay-interest ;
+
+: each-day ( quot start end -- )
+ 2dup before? [
+ >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+ ] [
+ 3drop
+ ] if ;
+
+: process-to-date ( account date -- account )
+ over interest-last-paid>> 1 days time+
+ [ dupd process-day ] spin each-day ;
+
+: inserting-transactions ( account transactions -- account )
+ [ [ date>> process-to-date ] keep >>transaction ] each ;
--- /dev/null
+Bank account simulator for compound interest calculated daily and paid monthly
-USING: io.crc32 io.encodings.ascii io.files kernel math ;
+USING: checksums checksums.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
+ "resource:extra/math/primes/list/list.factor"
+ crc32 checksum-file drop
] times ;
MAIN: crc32-primes-list
write-description
[let | k! [ 0 ] alu [ ] |
[| len | k len alu make-repeat-fasta k! ] split-lines
- ] with-locals ; inline
+ ] ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
drop
] with-file-writer
- ] with-locals ;
+ ] ;
: run-fasta 2500000 reverse-complement-in fasta ;
drop ;
: knucleotide ( -- )
- "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
+ "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
ascii [ read-input ] with-file-reader
process-input ;
-USING: crypto.md5 io.files kernel ;
+USING: checksums checksums.md5 io.files kernel ;
IN: benchmark.md5
: md5-primes-list ( -- )
- "extra/math/primes/list/list.factor" resource-path file>md5 drop ;
+ "resource:extra/math/primes/list/list.factor" md5 checksum-file drop ;
MAIN: md5-primes-list
IN: benchmark.partial-sums
: summing ( n quot -- y )
- [ + ] compose 0.0 -rot 1 -rot (each-integer) ; inline
+ [ >float ] swap [ + ] 3compose
+ 0.0 -rot 1 -rot (each-integer) ; inline
: 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;
IN: benchmark.reverse-complement.tests\r
-USING: tools.test benchmark.reverse-complement crypto.md5\r
+USING: tools.test benchmark.reverse-complement\r
+checksums checksums.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 ] bi@\r
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"\r
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
reverse-complement\r
\r
- "extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
- resource-path file>md5str\r
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
+ md5 checksum-file hex-string\r
] unit-test\r
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
- ascii <file-writer> [
- swap ascii <file-reader> [
- swap <duplex-stream> [
- 500000 <vector> (reverse-complement)
- ] with-stream
- ] with-disposal
- ] with-disposal ;
+ ascii [
+ ascii [
+ 500000 <vector> (reverse-complement)
+ ] with-file-reader
+ ] with-file-writer ;
: reverse-complement-in
"reverse-complement-in.txt" temp-file ;
-USING: crypto.sha1 io.files kernel ;
+USING: checksums checksums.sha1 io.files kernel ;
IN: benchmark.sha1
: sha1-primes-list ( -- )
- "extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
+ "resource:extra/math/primes/list/list.factor" sha1 checksum-file drop ;
MAIN: sha1-primes-list
USING: io.sockets io kernel math threads io.encodings.ascii
-debugger tools.time prettyprint concurrency.count-downs
-namespaces arrays continuations ;
+io.streams.duplex debugger tools.time prettyprint
+concurrency.count-downs namespaces arrays continuations ;
IN: benchmark.sockets
SYMBOL: counter
: server-addr "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- )
- dup accept [
+ dup accept drop [
[
read1 CHAR: x = [
"server" get dispose
] ignore-errors ;
: simple-client ( -- )
- server-addr ascii <client> [
+ server-addr ascii [
CHAR: b write1 flush
number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down
- ] with-stream ;
+ ] with-client ;
: stop-server ( -- )
- server-addr ascii <client> [
+ server-addr ascii [
CHAR: x write1
- ] with-stream ;
+ ] with-client ;
: clients ( n -- )
dup pprint " clients: " write [
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
-USING: http.client crypto.md5 splitting assocs kernel io.files
-bootstrap.image sequences io ;
+USING: http.client checksums checksums.md5 splitting assocs
+kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
: need-new-image? ( image -- ? )
dup exists?
- [ dup file>md5str swap download-checksums at = not ]
+ [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
[ drop t ] if ;
: download-image ( arch -- )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: http.client checksums checksums.md5 splitting assocs
+kernel io.files bootstrap.image sequences io namespaces
+io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
-USING: http.client crypto.md5 splitting assocs kernel io.files
-bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
SYMBOL: upload-images-destination
: compute-checksums ( -- )
checksums ascii [
- boot-image-names [ dup write bl file>md5str print ] each
+ boot-image-names [
+ [ write bl ] [ md5 checksum-file hex-string print ] bi
+ ] each
] with-file-writer ;
: upload-images ( -- )
: minutes>ms ( min -- ms ) 60 * 1000 * ;
-: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ;
+: file>string ( file -- string ) utf8 file-contents ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
- { "git" "show" } utf8 <process-stream> [ readln ] with-stream
+ { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
" " split second ;
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel\r
-byte-vectors.private combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"Literal syntax:"\r
-{ $subsection POSTPONE: BV{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: byte-array>vector\r
-{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;\r
-\r
-HELP: BV{\r
-{ $syntax "BV{ elements... }" }\r
-{ $values { "elements" "a list of bytes" } }\r
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable byte-arrays prettyprint.backend\r
-parser accessors ;\r
-IN: byte-vectors\r
-\r
-TUPLE: byte-vector underlying fill ;\r
-\r
-M: byte-vector underlying underlying>> { byte-array } declare ;\r
-\r
-M: byte-vector set-underlying (>>underlying) ;\r
-\r
-M: byte-vector length fill>> { array-capacity } declare ;\r
-\r
-M: byte-vector set-fill (>>fill) ;\r
-\r
-<PRIVATE\r
-\r
-: byte-array>vector ( byte-array length -- byte-vector )\r
- byte-vector boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- <byte-array> 0 byte-array>vector ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector )\r
- T{ byte-vector f B{ } 0 } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-array>vector ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new-sequence\r
- drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-INSTANCE: byte-vector growable\r
-\r
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing\r
-\r
-M: byte-vector >pprint-sequence ;\r
-\r
-M: byte-vector pprint-delims drop \ BV{ \ } ;\r
+++ /dev/null
-Growable byte arrays
+++ /dev/null
-collections
{ CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
{ CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
[ drop ]
- } cond ;
+ } case ;
: <png> ( path -- png )
normalize-path
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax ;
+IN: checksums.md5
+
+HELP: md5
+{ $description "MD5 checksum algorithm." } ;
+
+ARTICLE: "checksums.md5" "MD5 checksum"
+"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."
+{ $subsection md5 } ;
+
+ABOUT: "checksums.md5"
--- /dev/null
+USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
+
+[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
+[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
+
--- /dev/null
+! See http://www.faqs.org/rfcs/rfc1321.html
+
+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
+io.encodings.binary symbols math.bitfields.lib checksums ;
+IN: checksums.md5
+
+<PRIVATE
+
+SYMBOLS: a b c d old-a old-b old-c old-d ;
+
+: T ( N -- Y )
+ sin abs 4294967296 * >bignum ; foldable
+
+: initialize-md5 ( -- )
+ 0 bytes-read set
+ HEX: 67452301 dup a set old-a set
+ HEX: efcdab89 dup b set old-b set
+ HEX: 98badcfe dup c set old-c set
+ HEX: 10325476 dup d set old-d set ;
+
+: update-md ( -- )
+ old-a a update-old-new
+ old-b b update-old-new
+ old-c c update-old-new
+ old-d d update-old-new ;
+
+:: (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+
+ k x nth-unsafe w+
+ i T w+
+ s bitroll-32
+ b get w+
+ ] change ; inline
+
+: ABCD a b c d (ABCD) ; inline
+: BCDA b c d a (ABCD) ; inline
+: CDAB c d a b (ABCD) ; inline
+: DABC d a b c (ABCD) ; inline
+
+: F ( X Y Z -- FXYZ )
+ #! F(X,Y,Z) = XY v not(X) Z
+ pick bitnot bitand [ bitand ] [ bitor ] bi* ;
+
+: G ( X Y Z -- GXYZ )
+ #! G(X,Y,Z) = XZ v Y not(Z)
+ dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
+
+: H ( X Y Z -- HXYZ )
+ #! H(X,Y,Z) = X xor Y xor Z
+ bitxor bitxor ;
+
+: I ( X Y Z -- IXYZ )
+ #! I(X,Y,Z) = Y xor (X v not(Z))
+ rot swap bitnot bitor bitxor ;
+
+: S11 7 ; inline
+: S12 12 ; inline
+: S13 17 ; inline
+: S14 22 ; inline
+: S21 5 ; inline
+: S22 9 ; inline
+: S23 14 ; inline
+: S24 20 ; inline
+: S31 4 ; inline
+: S32 11 ; inline
+: S33 16 ; inline
+: S34 23 ; inline
+: S41 6 ; inline
+: S42 10 ; inline
+: S43 15 ; inline
+: S44 21 ; inline
+
+: (process-md5-block-F)
+ dup S11 1 0 [ F ] ABCD
+ dup S12 2 1 [ F ] DABC
+ dup S13 3 2 [ F ] CDAB
+ dup S14 4 3 [ F ] BCDA
+ dup S11 5 4 [ F ] ABCD
+ dup S12 6 5 [ F ] DABC
+ dup S13 7 6 [ F ] CDAB
+ dup S14 8 7 [ F ] BCDA
+ dup S11 9 8 [ F ] ABCD
+ dup S12 10 9 [ F ] DABC
+ dup S13 11 10 [ F ] CDAB
+ dup S14 12 11 [ F ] BCDA
+ dup S11 13 12 [ F ] ABCD
+ dup S12 14 13 [ F ] DABC
+ dup S13 15 14 [ F ] CDAB
+ dup S14 16 15 [ F ] BCDA ;
+
+: (process-md5-block-G)
+ dup S21 17 1 [ G ] ABCD
+ dup S22 18 6 [ G ] DABC
+ dup S23 19 11 [ G ] CDAB
+ dup S24 20 0 [ G ] BCDA
+ dup S21 21 5 [ G ] ABCD
+ dup S22 22 10 [ G ] DABC
+ dup S23 23 15 [ G ] CDAB
+ dup S24 24 4 [ G ] BCDA
+ dup S21 25 9 [ G ] ABCD
+ dup S22 26 14 [ G ] DABC
+ dup S23 27 3 [ G ] CDAB
+ dup S24 28 8 [ G ] BCDA
+ dup S21 29 13 [ G ] ABCD
+ dup S22 30 2 [ G ] DABC
+ dup S23 31 7 [ G ] CDAB
+ dup S24 32 12 [ G ] BCDA ;
+
+: (process-md5-block-H)
+ dup S31 33 5 [ H ] ABCD
+ dup S32 34 8 [ H ] DABC
+ dup S33 35 11 [ H ] CDAB
+ dup S34 36 14 [ H ] BCDA
+ dup S31 37 1 [ H ] ABCD
+ dup S32 38 4 [ H ] DABC
+ dup S33 39 7 [ H ] CDAB
+ dup S34 40 10 [ H ] BCDA
+ dup S31 41 13 [ H ] ABCD
+ dup S32 42 0 [ H ] DABC
+ dup S33 43 3 [ H ] CDAB
+ dup S34 44 6 [ H ] BCDA
+ dup S31 45 9 [ H ] ABCD
+ dup S32 46 12 [ H ] DABC
+ dup S33 47 15 [ H ] CDAB
+ dup S34 48 2 [ H ] BCDA ;
+
+: (process-md5-block-I)
+ dup S41 49 0 [ I ] ABCD
+ dup S42 50 7 [ I ] DABC
+ dup S43 51 14 [ I ] CDAB
+ dup S44 52 5 [ I ] BCDA
+ dup S41 53 12 [ I ] ABCD
+ dup S42 54 3 [ I ] DABC
+ dup S43 55 10 [ I ] CDAB
+ dup S44 56 1 [ I ] BCDA
+ dup S41 57 8 [ I ] ABCD
+ dup S42 58 15 [ I ] DABC
+ dup S43 59 6 [ I ] CDAB
+ dup S44 60 13 [ I ] BCDA
+ dup S41 61 4 [ I ] ABCD
+ dup S42 62 11 [ I ] DABC
+ dup S43 63 2 [ I ] CDAB
+ dup S44 64 9 [ I ] BCDA ;
+
+: (process-md5-block) ( block -- )
+ 4 <groups> [ le> ] map
+
+ (process-md5-block-F)
+ (process-md5-block-G)
+ (process-md5-block-H)
+ (process-md5-block-I)
+
+ drop
+
+ update-md ;
+
+: process-md5-block ( str -- )
+ dup length [ bytes-read [ + ] change ] keep 64 = [
+ (process-md5-block)
+ ] [
+ f bytes-read get pad-last-block
+ [ (process-md5-block) ] each
+ ] if ;
+
+: stream>md5 ( -- )
+ 64 read [ process-md5-block ] keep
+ length 64 = [ stream>md5 ] when ;
+
+: get-md5 ( -- str )
+ [ a b c d ] [ get 4 >le ] map concat >byte-array ;
+
+PRIVATE>
+
+SINGLETON: md5
+
+INSTANCE: md5 checksum
+
+M: md5 checksum-stream ( stream -- byte-array )
+ drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
--- /dev/null
+USING: checksums kernel ;
+IN: checksums.null
+
+SINGLETON: null
+
+INSTANCE: null checksum
+
+M: null checksum-bytes drop ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax ;
+IN: checksums.sha1
+
+HELP: sha1
+{ $description "SHA1 checksum algorithm." } ;
+
+ARTICLE: "checksums.sha1" "SHA1 checksum"
+"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
+{ $subsection sha1 } ;
+
+ABOUT: "checksums.sha1"
--- /dev/null
+USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
+
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
+! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
+[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
+10 swap <array> concat sha1 checksum-bytes hex-string ] 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"
+ sha1-interleave
+] unit-test
--- /dev/null
+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 math.bitfields.lib checksums ;
+IN: checksums.sha1
+
+! Implemented according to RFC 3174.
+
+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
+
+: initialize-sha1 ( -- )
+ 0 bytes-read set
+ HEX: 67452301 dup h0 set A set
+ HEX: efcdab89 dup h1 set B set
+ HEX: 98badcfe dup h2 set C set
+ HEX: 10325476 dup h3 set D set
+ HEX: c3d2e1f0 dup h4 set E set
+ [
+ 20 HEX: 5a827999 <array> %
+ 20 HEX: 6ed9eba1 <array> %
+ 20 HEX: 8f1bbcdc <array> %
+ 20 HEX: ca62c1d6 <array> %
+ ] { } make K set ;
+
+! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
+: sha1-W ( t -- W_t )
+ dup 3 - get-wth
+ over 8 - get-wth bitxor
+ over 14 - get-wth bitxor
+ swap 16 - get-wth bitxor 1 bitroll-32 ;
+
+! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
+! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
+! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
+! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
+: sha1-f ( B C D t -- f_tbcd )
+ 20 /i
+ {
+ { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
+ { 1 [ bitxor bitxor ] }
+ { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
+ { 3 [ bitxor bitxor ] }
+ } case ;
+
+: make-w ( str -- )
+ #! compute w, steps a-b of RFC 3174, section 6.1
+ 16 [ nth-int-be w get push ] with each
+ 16 80 dup <slice> [ sha1-W w get push ] each ;
+
+: init-letters ( -- )
+ ! step c of RFC 3174, section 6.1
+ h0 get A set
+ h1 get B set
+ h2 get C set
+ h3 get D set
+ h4 get E set ;
+
+: inner-loop ( n -- temp )
+ ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
+ [
+ [ B get C get D get ] keep sha1-f ,
+ dup get-wth ,
+ K get nth ,
+ A get 5 bitroll-32 ,
+ E get ,
+ ] { } make sum 32 bits ; inline
+
+: set-vars ( temp -- )
+ ! E = D; D = C; C = S^30(B); B = A; A = TEMP;
+ D get E set
+ C get D set
+ B get 30 bitroll-32 C set
+ A get B set
+ A set ;
+
+: calculate-letters ( -- )
+ ! step d of RFC 3174, section 6.1
+ 80 [ inner-loop set-vars ] each ;
+
+: update-hs ( -- )
+ ! step e of RFC 3174, section 6.1
+ A h0 update-old-new
+ B h1 update-old-new
+ C h2 update-old-new
+ D h3 update-old-new
+ E h4 update-old-new ;
+
+: (process-sha1-block) ( str -- )
+ 80 <vector> w set make-w init-letters calculate-letters update-hs ;
+
+: process-sha1-block ( str -- )
+ dup length [ bytes-read [ + ] change ] keep 64 = [
+ (process-sha1-block)
+ ] [
+ t bytes-read get pad-last-block
+ [ (process-sha1-block) ] each
+ ] if ;
+
+: stream>sha1 ( -- )
+ 64 read [ process-sha1-block ] keep
+ length 64 = [ stream>sha1 ] when ;
+
+: get-sha1 ( -- str )
+ [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
+
+SINGLETON: sha1
+
+INSTANCE: sha1 checksum
+
+M: sha1 checksum-stream ( stream -- sha1 )
+ drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
+
+: sha1-interleave ( string -- seq )
+ [ zero? ] left-trim
+ dup length odd? [ rest ] when
+ seq>2seq [ sha1 checksum-bytes ] bi@
+ 2seq>seq ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax ;
+IN: checksums.sha2
+
+HELP: sha-256
+{ $description "SHA-256 checksum algorithm." } ;
+
+ARTICLE: "checksums.sha2" "SHA2 checksum"
+"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
+{ $subsection sha-256 } ;
+
+ABOUT: "checksums.sha2"
--- /dev/null
+USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
--- /dev/null
+USING: crypto.common kernel splitting math sequences namespaces
+io.binary symbols math.bitfields.lib checksums ;
+IN: checksums.sha2
+
+<PRIVATE
+
+SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+
+: a 0 ; inline
+: b 1 ; inline
+: c 2 ; inline
+: d 3 ; inline
+: e 4 ; inline
+: f 5 ; inline
+: g 6 ; inline
+: h 7 ; inline
+
+: initial-H-256 ( -- seq )
+ {
+ HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
+ HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
+ } ;
+
+: K-256 ( -- seq )
+ {
+ HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
+ HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
+ HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
+ HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
+ HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
+ HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
+ HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
+ HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
+ HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
+ HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
+ HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
+ HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
+ HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
+ HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
+ HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
+ HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
+ } ;
+
+: s0-256 ( x -- x' )
+ [ -7 bitroll-32 ] keep
+ [ -18 bitroll-32 ] keep
+ -3 shift bitxor bitxor ; inline
+
+: s1-256 ( x -- x' )
+ [ -17 bitroll-32 ] keep
+ [ -19 bitroll-32 ] keep
+ -10 shift bitxor bitxor ; inline
+
+: process-M-256 ( seq n -- )
+ [ 16 - swap nth ] 2keep
+ [ 15 - swap nth s0-256 ] 2keep
+ [ 7 - swap nth ] 2keep
+ [ 2 - swap nth s1-256 ] 2keep
+ >r >r + + w+ r> r> swap set-nth ; inline
+
+: prepare-message-schedule ( seq -- w-seq )
+ word-size get group [ be> ] map block-size get 0 pad-right
+ dup 16 64 dup <slice> [
+ process-M-256
+ ] with each ;
+
+: ch ( x y z -- x' )
+ [ bitxor bitand ] keep bitxor ;
+
+: maj ( x y z -- x' )
+ >r [ bitand ] 2keep bitor r> bitand bitor ;
+
+: S0-256 ( x -- x' )
+ [ -2 bitroll-32 ] keep
+ [ -13 bitroll-32 ] keep
+ -22 bitroll-32 bitxor bitxor ; inline
+
+: S1-256 ( x -- x' )
+ [ -6 bitroll-32 ] keep
+ [ -11 bitroll-32 ] keep
+ -25 bitroll-32 bitxor bitxor ; inline
+
+: T1 ( W n -- T1 )
+ [ swap nth ] keep
+ K get nth +
+ e vars get slice3 ch +
+ e vars get nth S1-256 +
+ h vars get nth w+ ;
+
+: T2 ( -- T2 )
+ a vars get nth S0-256
+ a vars get slice3 maj w+ ;
+
+: update-vars ( T1 T2 -- )
+ vars get
+ h g pick exchange
+ g f pick exchange
+ f e pick exchange
+ pick d pick nth w+ e pick set-nth
+ d c pick exchange
+ c b pick exchange
+ b a pick exchange
+ >r w+ a r> set-nth ;
+
+: process-chunk ( M -- )
+ H get clone vars set
+ prepare-message-schedule block-size get [
+ T1 T2 update-vars
+ ] with each vars get H get [ w+ ] 2map H set ;
+
+: seq>byte-array ( n seq -- string )
+ [ swap [ >be % ] curry each ] B{ } make ;
+
+: byte-array>sha2 ( byte-array -- string )
+ t preprocess-plaintext
+ block-size get group [ process-chunk ] each
+ 4 H get seq>byte-array ;
+
+PRIVATE>
+
+SINGLETON: sha-256
+
+INSTANCE: sha-256 checksum
+
+M: sha-256 checksum-bytes
+ drop [
+ K-256 K set
+ initial-H-256 H set
+ 4 word-size set
+ 64 block-size set
+ byte-array>sha2
+ ] with-scope ;
: generate ( generator predicate -- obj )
[ dup ] swap [ dup [ nip ] unless not ] 3compose
swap [ ] do-while ;
+
+MACRO: predicates ( seq -- quot/f )
+ dup [ 1quotation [ drop ] prepend ] map
+ >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
+ [ cond ] curry ;
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }\r
{ $errors "Throws an error if one of the iterations throws an error." } ;\r
\r
+HELP: 2parallel-map\r
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }\r
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }\r
+{ $errors "Throws an error if one of the iterations throws an error." } ;\r
+\r
HELP: parallel-each\r
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }\r
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }\r
{ $errors "Throws an error if one of the iterations throws an error." } ;\r
\r
+HELP: 2parallel-each\r
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }\r
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }\r
+{ $errors "Throws an error if one of the iterations throws an error." } ;\r
+\r
HELP: parallel-filter\r
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }\r
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }\r
ARTICLE: "concurrency.combinators" "Concurrent combinators"\r
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"\r
{ $subsection parallel-each }\r
+{ $subsection 2parallel-each }\r
{ $subsection parallel-map }\r
+{ $subsection 2parallel-map }\r
{ $subsection parallel-filter } ;\r
\r
ABOUT: "concurrency.combinators"\r
IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
-concurrency.mailboxes threads sequences accessors ;\r
+concurrency.mailboxes threads sequences accessors arrays ;\r
\r
[ [ drop ] parallel-each ] must-infer\r
+{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as\r
[ [ ] parallel-map ] must-infer\r
+{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as\r
[ [ ] parallel-filter ] must-infer\r
\r
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test\r
10 over [ push ] curry parallel-each\r
length\r
] unit-test\r
+\r
+[ { 10 20 30 } ] [\r
+ { 1 4 3 } { 10 5 10 } [ * ] 2parallel-map\r
+] unit-test\r
+\r
+[ { -9 -1 -7 } ] [\r
+ { 1 4 3 } { 10 5 10 } [ - ] 2parallel-map\r
+] unit-test\r
+\r
+[\r
+ { 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each\r
+] must-fail\r
+\r
+[ 20 ]\r
+[\r
+ V{ } clone\r
+ 10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
+ length\r
+] unit-test\r
+\r
+[ { f } [ "OOPS" throw ] parallel-each ] must-fail\r
kernel ;\r
IN: concurrency.combinators\r
\r
-: parallel-map ( seq quot -- newseq )\r
- [ curry future ] curry map dup [ ?future ] change-each ;\r
- inline\r
+: (parallel-each) ( n quot -- )\r
+ >r <count-down> r> keep await ; inline\r
\r
: parallel-each ( seq quot -- )\r
- over length <count-down>\r
- [ [ >r curry r> spawn-stage ] 2curry each ] keep await ;\r
- inline\r
+ over length [\r
+ [ >r curry r> spawn-stage ] 2curry each\r
+ ] (parallel-each) ; inline\r
+\r
+: 2parallel-each ( seq1 seq2 quot -- )\r
+ 2over min-length [\r
+ [ >r 2curry r> spawn-stage ] 2curry 2each\r
+ ] (parallel-each) ; inline\r
\r
: parallel-filter ( seq quot -- newseq )\r
over >r pusher >r each r> r> like ; inline\r
+\r
+: future-values dup [ ?future ] change-each ; inline\r
+\r
+: parallel-map ( seq quot -- newseq )\r
+ [ curry future ] curry map future-values ;\r
+ inline\r
+\r
+: 2parallel-map ( seq1 seq2 quot -- newseq )\r
+ [ 2curry future ] curry 2map future-values ;\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.mailboxes ;\r
+concurrency.mailboxes debugger accessors ;\r
IN: concurrency.count-downs\r
\r
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html\r
TUPLE: count-down n promise ;\r
\r
: count-down-check ( count-down -- )\r
- dup count-down-n zero? [\r
- t swap count-down-promise fulfill\r
- ] [ drop ] if ;\r
+ dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;\r
\r
: <count-down> ( n -- count-down )\r
dup 0 < [ "Invalid count for count down" throw ] when\r
dup count-down-check ;\r
\r
: count-down ( count-down -- )\r
- dup count-down-n dup zero? [\r
- "Count down already done" throw\r
- ] [\r
- 1- over set-count-down-n\r
- count-down-check\r
- ] if ;\r
+ dup n>> dup zero?\r
+ [ "Count down already done" throw ]\r
+ [ 1- >>n count-down-check ] if ;\r
\r
: await-timeout ( count-down timeout -- )\r
- >r count-down-promise r> ?promise-timeout drop ;\r
+ >r promise>> r> ?promise-timeout ?linked t assert= ;\r
\r
: await ( count-down -- )\r
f await-timeout ;\r
: spawn-stage ( quot count-down -- )\r
[ [ count-down ] curry compose ] keep\r
"Count down stage"\r
- swap count-down-promise\r
- promise-mailbox spawn-linked-to drop ;\r
+ swap promise>> mailbox>> spawn-linked-to drop ;\r
USING: serialize sequences concurrency.messaging threads io
io.server qualified arrays namespaces kernel io.encodings.binary
accessors ;
-QUALIFIED: io.sockets
+FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
SYMBOL: local-node
: start-node ( port -- )
[ internet-server ]
- [ io.sockets:host-name swap io.sockets:<inet> ] bi
+ [ host-name swap <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 ;
+ binary [ serialize ] with-client ;
M: remote-process send ( message thread -- )
[ id>> 2array ] [ node>> ] bi
IN: concurrency.flags.tests\r
-USING: tools.test concurrency.flags kernel threads locals ;\r
+USING: tools.test concurrency.flags concurrency.combinators\r
+kernel threads locals accessors ;\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
+ f value>>\r
] ;\r
\r
[ f ] [ flag-test-1 ] unit-test\r
[let | f [ <flag> ] |\r
[ 1000 sleep f raise-flag ] "Flag test" spawn drop\r
f lower-flag\r
- f flag-value?\r
+ f value>>\r
] ;\r
\r
[ f ] [ flag-test-2 ] unit-test\r
:: flag-test-3 ( -- )\r
[let | f [ <flag> ] |\r
f raise-flag\r
- f flag-value?\r
+ f value>>\r
] ;\r
\r
[ t ] [ flag-test-3 ] unit-test\r
[let | f [ <flag> ] |\r
[ f raise-flag ] "Flag test" spawn drop\r
f wait-for-flag\r
- f flag-value?\r
+ f value>>\r
] ;\r
\r
[ t ] [ flag-test-4 ] unit-test\r
[let | f [ <flag> ] |\r
[ 1000 sleep f raise-flag ] "Flag test" spawn drop\r
f wait-for-flag\r
- f flag-value?\r
+ f value>>\r
] ;\r
\r
[ t ] [ flag-test-5 ] unit-test\r
+\r
+[ ] [\r
+ { 1 2 } <flag>\r
+ [ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ]\r
+ [ [ wait-for-flag drop ] curry parallel-each ] bi\r
+] unit-test\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: boxes kernel threads ;
+USING: dlists kernel threads concurrency.conditions accessors ;
IN: concurrency.flags
-TUPLE: flag value? thread ;
+TUPLE: flag value threads ;
-: <flag> ( -- flag ) f <box> flag boa ;
+: <flag> ( -- flag ) f <dlist> flag boa ;
: raise-flag ( flag -- )
- dup flag-value? [
- t over set-flag-value?
- dup flag-thread [ resume ] if-box?
- ] unless drop ;
+ dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
+
+: wait-for-flag-timeout ( flag timeout -- )
+ over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
: wait-for-flag ( flag -- )
- dup flag-value? [ drop ] [
- [ flag-thread >box ] curry "flag" suspend drop
- ] if ;
+ f wait-for-flag-timeout ;
: lower-flag ( flag -- )
- dup wait-for-flag f swap set-flag-value? ;
+ [ wait-for-flag ] [ f >>value drop ] bi ;
IN: concurrency.mailboxes\r
USING: dlists threads sequences continuations\r
namespaces random math quotations words kernel arrays assocs\r
-init system concurrency.conditions accessors ;\r
+init system concurrency.conditions accessors debugger ;\r
\r
TUPLE: mailbox threads data closed ;\r
\r
\r
TUPLE: linked-error error thread ;\r
\r
+M: linked-error error.\r
+ [ thread>> error-in-thread. ] [ error>> error. ] bi ;\r
+\r
C: <linked-error> linked-error\r
\r
: ?linked dup linked-error? [ rethrow ] when ;\r
--- /dev/null
+IN: contributors.tests
+USING: contributors tools.test ;
+
+\ contributors must-infer
+[ ] [ contributors ] unit-test
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.launcher io.styles io hashtables kernel
-sequences sequences.lib assocs system sorting math.parser
-sets ;
+USING: io.files io.launcher io.styles io.encodings.ascii io
+hashtables kernel sequences sequences.lib assocs system sorting
+math.parser sets ;
IN: contributors
: changelog ( -- authors )
image parent-directory [
- "git-log --pretty=format:%an" <process-stream> lines
+ "git-log --pretty=format:%an" ascii <process-reader> lines
] with-directory ;
: patch-counts ( authors -- assoc )
USING: kernel cpu.8080 cpu.8080.emulator math math io\r
-tools.time combinators sequences io.files ;\r
+tools.time combinators sequences io.files io.encodings.ascii ;\r
IN: cpu.8080.test\r
\r
: step ( cpu -- )\r
\r
: >ppm ( cpu filename -- cpu )\r
#! Dump the current screen image to a ppm image file with the given name.\r
- <file-writer> [\r
+ ascii [\r
"P3" print\r
"256 224" print\r
"1" print\r
] each-8bit drop\r
] each drop nl\r
] each\r
- ] with-stream ;\r
+ ] with-file-writer ;\r
\r
: time-test ( -- )\r
test-cpu [ 1000000 run-n drop ] time ;\r
+++ /dev/null
-USING: help.markup help.syntax kernel math sequences quotations
-math.private ;
-IN: crypto.common
-
-HELP: hex-string
-{ $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 "USING: crypto.common io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
-}
-{ $notes "Numbers are zero-padded on the left." } ;
-
-
USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints math.bitfields.lib ;
+namespaces math math.parser parser hints math.bitfields.lib
+assocs ;
IN: crypto.common
: w+ ( int int -- int ) + 32 bits ; inline
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
-: hex-string ( seq -- str )
- [ [ >hex 2 48 pad-left % ] each ] "" make ;
-
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
: seq>2seq ( seq -- seq1 seq2 )
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
- [ 2array flip concat ] keep like ;
+ [ zip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
-USING: arrays combinators crypto.common crypto.md5 crypto.sha1
-crypto.md5.private io io.binary io.files io.streams.byte-array
-kernel math math.vectors memoize sequences io.encodings.binary ;
+USING: arrays combinators crypto.common checksums checksums.md5
+checksums.sha1 checksums.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 )
initialize-sha1 process-sha1-block
- (stream>sha1) get-sha1
+ stream>sha1 get-sha1
initialize-sha1
>r process-sha1-block r>
process-sha1-block get-sha1 ;
: md5-hmac ( Ko Ki -- hmac )
initialize-md5 process-md5-block
- (stream>md5) get-md5
+ stream>md5 get-md5
initialize-md5
>r process-md5-block r>
process-md5-block get-md5 ;
ipad seq-bitxor ;
: stream>sha1-hmac ( K stream -- hmac )
- [ init-hmac sha1-hmac ] with-stream ;
+ [ init-hmac sha1-hmac ] with-input-stream ;
: file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ;
binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
- [ init-hmac md5-hmac ] with-stream ;
+ [ init-hmac md5-hmac ] with-input-stream ;
: file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: help.markup help.syntax kernel math sequences quotations
-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 byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
-
-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
-{ $values { "path" "a path" } { "byte-array" "byte-array md5 hash" } }
-{ $description "Outputs the MD5 hash of a file." }
-{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
+++ /dev/null
-USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
-
-[ "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
-
+++ /dev/null
-! See http://www.faqs.org/rfcs/rfc1321.html
-
-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
-io.encodings.binary symbols math.bitfields.lib ;
-IN: crypto.md5
-
-<PRIVATE
-
-SYMBOLS: a b c d old-a old-b old-c old-d ;
-
-: T ( N -- Y )
- sin abs 4294967296 * >bignum ; foldable
-
-: initialize-md5 ( -- )
- 0 bytes-read set
- HEX: 67452301 dup a set old-a set
- HEX: efcdab89 dup b set old-b set
- HEX: 98badcfe dup c set old-c set
- HEX: 10325476 dup d set old-d set ;
-
-: update-md ( -- )
- old-a a update-old-new
- old-b b update-old-new
- old-c c update-old-new
- old-d d update-old-new ;
-
-:: (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+
- k x nth-unsafe w+
- i T w+
- s bitroll-32
- b get w+
- ] change ; inline
-
-: ABCD a b c d (ABCD) ; inline
-: BCDA b c d a (ABCD) ; inline
-: CDAB c d a b (ABCD) ; inline
-: DABC d a b c (ABCD) ; inline
-
-: F ( X Y Z -- FXYZ )
- #! F(X,Y,Z) = XY v not(X) Z
- pick bitnot bitand [ bitand ] [ bitor ] bi* ;
-
-: G ( X Y Z -- GXYZ )
- #! G(X,Y,Z) = XZ v Y not(Z)
- dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
-
-: H ( X Y Z -- HXYZ )
- #! H(X,Y,Z) = X xor Y xor Z
- bitxor bitxor ;
-
-: I ( X Y Z -- IXYZ )
- #! I(X,Y,Z) = Y xor (X v not(Z))
- rot swap bitnot bitor bitxor ;
-
-: S11 7 ; inline
-: S12 12 ; inline
-: S13 17 ; inline
-: S14 22 ; inline
-: S21 5 ; inline
-: S22 9 ; inline
-: S23 14 ; inline
-: S24 20 ; inline
-: S31 4 ; inline
-: S32 11 ; inline
-: S33 16 ; inline
-: S34 23 ; inline
-: S41 6 ; inline
-: S42 10 ; inline
-: S43 15 ; inline
-: S44 21 ; inline
-
-: (process-md5-block-F)
- dup S11 1 0 [ F ] ABCD
- dup S12 2 1 [ F ] DABC
- dup S13 3 2 [ F ] CDAB
- dup S14 4 3 [ F ] BCDA
- dup S11 5 4 [ F ] ABCD
- dup S12 6 5 [ F ] DABC
- dup S13 7 6 [ F ] CDAB
- dup S14 8 7 [ F ] BCDA
- dup S11 9 8 [ F ] ABCD
- dup S12 10 9 [ F ] DABC
- dup S13 11 10 [ F ] CDAB
- dup S14 12 11 [ F ] BCDA
- dup S11 13 12 [ F ] ABCD
- dup S12 14 13 [ F ] DABC
- dup S13 15 14 [ F ] CDAB
- dup S14 16 15 [ F ] BCDA ;
-
-: (process-md5-block-G)
- dup S21 17 1 [ G ] ABCD
- dup S22 18 6 [ G ] DABC
- dup S23 19 11 [ G ] CDAB
- dup S24 20 0 [ G ] BCDA
- dup S21 21 5 [ G ] ABCD
- dup S22 22 10 [ G ] DABC
- dup S23 23 15 [ G ] CDAB
- dup S24 24 4 [ G ] BCDA
- dup S21 25 9 [ G ] ABCD
- dup S22 26 14 [ G ] DABC
- dup S23 27 3 [ G ] CDAB
- dup S24 28 8 [ G ] BCDA
- dup S21 29 13 [ G ] ABCD
- dup S22 30 2 [ G ] DABC
- dup S23 31 7 [ G ] CDAB
- dup S24 32 12 [ G ] BCDA ;
-
-: (process-md5-block-H)
- dup S31 33 5 [ H ] ABCD
- dup S32 34 8 [ H ] DABC
- dup S33 35 11 [ H ] CDAB
- dup S34 36 14 [ H ] BCDA
- dup S31 37 1 [ H ] ABCD
- dup S32 38 4 [ H ] DABC
- dup S33 39 7 [ H ] CDAB
- dup S34 40 10 [ H ] BCDA
- dup S31 41 13 [ H ] ABCD
- dup S32 42 0 [ H ] DABC
- dup S33 43 3 [ H ] CDAB
- dup S34 44 6 [ H ] BCDA
- dup S31 45 9 [ H ] ABCD
- dup S32 46 12 [ H ] DABC
- dup S33 47 15 [ H ] CDAB
- dup S34 48 2 [ H ] BCDA ;
-
-: (process-md5-block-I)
- dup S41 49 0 [ I ] ABCD
- dup S42 50 7 [ I ] DABC
- dup S43 51 14 [ I ] CDAB
- dup S44 52 5 [ I ] BCDA
- dup S41 53 12 [ I ] ABCD
- dup S42 54 3 [ I ] DABC
- dup S43 55 10 [ I ] CDAB
- dup S44 56 1 [ I ] BCDA
- dup S41 57 8 [ I ] ABCD
- dup S42 58 15 [ I ] DABC
- dup S43 59 6 [ I ] CDAB
- dup S44 60 13 [ I ] BCDA
- dup S41 61 4 [ I ] ABCD
- dup S42 62 11 [ I ] DABC
- dup S43 63 2 [ I ] CDAB
- dup S44 64 9 [ I ] BCDA ;
-
-: (process-md5-block) ( block -- )
- 4 <groups> [ le> ] map
-
- (process-md5-block-F)
- (process-md5-block-G)
- (process-md5-block-H)
- (process-md5-block-I)
-
- drop
-
- update-md ;
-
-: process-md5-block ( str -- )
- dup length [ bytes-read [ + ] change ] keep 64 = [
- (process-md5-block)
- ] [
- f bytes-read get pad-last-block
- [ (process-md5-block) ] each
- ] if ;
-
-: (stream>md5) ( -- )
- 64 read [ process-md5-block ] keep
- length 64 = [ (stream>md5) ] when ;
-
-: get-md5 ( -- str )
- [ a b c d ] [ get 4 >le ] map concat >byte-array ;
-
-PRIVATE>
-
-: stream>md5 ( stream -- byte-array )
- [ initialize-md5 (stream>md5) get-md5 ] with-stream ;
-
-: 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: arrays kernel math namespaces sequences tools.test crypto.sha1 ;
-
-[ "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 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"
- byte-array>sha1-interleave
-] unit-test
+++ /dev/null
-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 math.bitfields.lib ;
-IN: crypto.sha1
-
-! Implemented according to RFC 3174.
-
-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
-
-: initialize-sha1 ( -- )
- 0 bytes-read set
- HEX: 67452301 dup h0 set A set
- HEX: efcdab89 dup h1 set B set
- HEX: 98badcfe dup h2 set C set
- HEX: 10325476 dup h3 set D set
- HEX: c3d2e1f0 dup h4 set E set
- [
- 20 HEX: 5a827999 <array> %
- 20 HEX: 6ed9eba1 <array> %
- 20 HEX: 8f1bbcdc <array> %
- 20 HEX: ca62c1d6 <array> %
- ] { } make K set ;
-
-! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
-: sha1-W ( t -- W_t )
- dup 3 - get-wth
- over 8 - get-wth bitxor
- over 14 - get-wth bitxor
- swap 16 - get-wth bitxor 1 bitroll-32 ;
-
-! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
-! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
-! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
-! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
-: sha1-f ( B C D t -- f_tbcd )
- 20 /i
- {
- { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
- { 1 [ bitxor bitxor ] }
- { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
- { 3 [ bitxor bitxor ] }
- } case ;
-
-: make-w ( str -- )
- #! compute w, steps a-b of RFC 3174, section 6.1
- 16 [ nth-int-be w get push ] with each
- 16 80 dup <slice> [ sha1-W w get push ] each ;
-
-: init-letters ( -- )
- ! step c of RFC 3174, section 6.1
- h0 get A set
- h1 get B set
- h2 get C set
- h3 get D set
- h4 get E set ;
-
-: inner-loop ( n -- temp )
- ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
- [
- [ B get C get D get ] keep sha1-f ,
- dup get-wth ,
- K get nth ,
- A get 5 bitroll-32 ,
- E get ,
- ] { } make sum 32 bits ; inline
-
-: set-vars ( temp -- )
- ! E = D; D = C; C = S^30(B); B = A; A = TEMP;
- D get E set
- C get D set
- B get 30 bitroll-32 C set
- A get B set
- A set ;
-
-: calculate-letters ( -- )
- ! step d of RFC 3174, section 6.1
- 80 [ inner-loop set-vars ] each ;
-
-: update-hs ( -- )
- ! step e of RFC 3174, section 6.1
- A h0 update-old-new
- B h1 update-old-new
- C h2 update-old-new
- D h3 update-old-new
- E h4 update-old-new ;
-
-: (process-sha1-block) ( str -- )
- 80 <vector> w set make-w init-letters calculate-letters update-hs ;
-
-: process-sha1-block ( str -- )
- dup length [ bytes-read [ + ] change ] keep 64 = [
- (process-sha1-block)
- ] [
- t bytes-read get pad-last-block
- [ (process-sha1-block) ] each
- ] if ;
-
-: (stream>sha1) ( -- )
- 64 read [ process-sha1-block ] keep
- length 64 = [ (stream>sha1) ] when ;
-
-: get-sha1 ( -- str )
- [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
-
-: stream>sha1 ( stream -- sha1 )
- [ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
-
-: byte-array>sha1 ( string -- sha1 )
- binary <byte-reader> stream>sha1 ;
-
-: 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? [ rest ] when
- seq>2seq [ byte-array>sha1 ] bi@
- 2seq>seq ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ;
-[ "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
+++ /dev/null
-USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols math.bitfields.lib ;
-IN: crypto.sha2
-
-<PRIVATE
-
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
-
-: a 0 ; inline
-: b 1 ; inline
-: c 2 ; inline
-: d 3 ; inline
-: e 4 ; inline
-: f 5 ; inline
-: g 6 ; inline
-: h 7 ; inline
-
-: initial-H-256 ( -- seq )
- {
- HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
- HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
- } ;
-
-: K-256 ( -- seq )
- {
- HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
- HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
- HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
- HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
- HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
- HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
- HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
- HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
- HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
- HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
- HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
- HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
- HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
- HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
- HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
- HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
- } ;
-
-: s0-256 ( x -- x' )
- [ -7 bitroll-32 ] keep
- [ -18 bitroll-32 ] keep
- -3 shift bitxor bitxor ; inline
-
-: s1-256 ( x -- x' )
- [ -17 bitroll-32 ] keep
- [ -19 bitroll-32 ] keep
- -10 shift bitxor bitxor ; inline
-
-: process-M-256 ( seq n -- )
- [ 16 - swap nth ] 2keep
- [ 15 - swap nth s0-256 ] 2keep
- [ 7 - swap nth ] 2keep
- [ 2 - swap nth s1-256 ] 2keep
- >r >r + + w+ r> r> swap set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
- word-size get group [ be> ] map block-size get 0 pad-right
- dup 16 64 dup <slice> [
- process-M-256
- ] with each ;
-
-: ch ( x y z -- x' )
- [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
- >r [ bitand ] 2keep bitor r> bitand bitor ;
-
-: S0-256 ( x -- x' )
- [ -2 bitroll-32 ] keep
- [ -13 bitroll-32 ] keep
- -22 bitroll-32 bitxor bitxor ; inline
-
-: S1-256 ( x -- x' )
- [ -6 bitroll-32 ] keep
- [ -11 bitroll-32 ] keep
- -25 bitroll-32 bitxor bitxor ; inline
-
-: T1 ( W n -- T1 )
- [ swap nth ] keep
- K get nth +
- e vars get slice3 ch +
- e vars get nth S1-256 +
- h vars get nth w+ ;
-
-: T2 ( -- T2 )
- a vars get nth S0-256
- a vars get slice3 maj w+ ;
-
-: update-vars ( T1 T2 -- )
- vars get
- h g pick exchange
- g f pick exchange
- f e pick exchange
- pick d pick nth w+ e pick set-nth
- d c pick exchange
- c b pick exchange
- b a pick exchange
- >r w+ a r> set-nth ;
-
-: process-chunk ( M -- )
- H get clone vars set
- prepare-message-schedule block-size get [
- T1 T2 update-vars
- ] with each vars get H get [ w+ ] 2map H set ;
-
-: seq>byte-array ( n seq -- string )
- [ swap [ >be % ] curry each ] B{ } make ;
-
-: byte-array>sha2 ( byte-array -- string )
- t preprocess-plaintext
- block-size get group [ process-chunk ] each
- 4 H get seq>byte-array ;
-
-PRIVATE>
-
-: byte-array>sha-256 ( string -- string )
- [
- K-256 K set
- initial-H-256 H set
- 4 word-size set
- 64 block-size set
- byte-array>sha2
- ] with-scope ;
-
-: byte-array>sha-256-string ( string -- hexstring )
- byte-array>sha-256 hex-string ;
[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar"
<string-reader> csv ] named-unit-test
-
-
! !!!!!!!! other tests
[ { { "Phil Dawes" } } ]
"allows setting of delimiting character"
[ { { "foo" "bah" "baz" } } ]
[ "foo\tbah\tbaz\n" <string-reader> CHAR: \t [ csv ] with-delimiter ] named-unit-test
+
+"Quoted field followed immediately by newline"
+[ { { "foo" "bar" }
+ { "1" "2" } } ]
+[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test
read1 dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ delimiter> [ ] } ! end of quoted field
+ { CHAR: \n [ ] }
[ 2drop skip-to-field-end ] ! end of quoted field + padding
} case ;
: csv-row ( stream -- row )
init-vars
- [ row nip ] with-stream ;
+ [ row nip ] with-input-stream ;
: csv ( stream -- rows )
init-vars
- [ [ (csv) ] { } make ] with-stream ;
+ [ [ (csv) ] { } make ] with-input-stream ;
: with-delimiter ( char quot -- )
delimiter swap with-variable ; inline
--- /dev/null
+IN: db.pooling.tests
+USING: db.pooling tools.test ;
+
+\ <pool> must-infer
+
+{ 2 0 } [ [ ] with-db-pool ] must-infer-as
+
+{ 1 0 } [ [ ] with-pooled-connection ] must-infer-as
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel arrays namespaces sequences continuations
+destructors db ;
+IN: db.pooling
+
+TUPLE: pool db params connections ;
+
+: <pool> ( db params -- pool )
+ V{ } clone pool boa ;
+
+M: pool dispose [ dispose-each f ] change-connections drop ;
+
+: with-db-pool ( db params quot -- )
+ >r <pool> r> [ pool swap with-variable ] curry with-disposal ; inline
+
+TUPLE: return-connection db pool ;
+
+: return-connection ( db pool -- )
+ connections>> push ;
+
+: new-connection ( pool -- )
+ [ [ db>> ] [ params>> ] bi make-db db-open ] keep
+ return-connection ;
+
+: acquire-connection ( pool -- db )
+ [ dup connections>> empty? ] [ dup new-connection ] [ ] while
+ connections>> pop ;
+
+: (with-pooled-connection) ( db pool quot -- )
+ [ >r drop db r> with-variable ]
+ [ drop return-connection ]
+ 3bi ; inline
+
+: with-pooled-connection ( pool quot -- )
+ >r [ acquire-connection ] keep r>
+ [ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
+
+M: return-connection dispose
+ [ db>> ] [ pool>> ] bi return-connection ;
+
+: return-connection-later ( db pool -- )
+ \ return-connection boa add-always-destructor ;
{ define-consult POSTPONE: CONSULT: } related-words
-HELP: define-mimic
-{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
-{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
-{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
-
-HELP: MIMIC:
-{ $syntax "MIMIC: group mimicker mimicked" }
-{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
-{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
-
HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } }
-{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ;
+{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation module"
-"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use"
+"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
{ $subsection POSTPONE: CONSULT: }
-{ $subsection define-consult }
-"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
-{ $subsection POSTPONE: MIMIC: }
-{ $subsection define-mimic } ;
+{ $subsection define-consult } ;
IN: delegate
ABOUT: { "delegate" "intro" }
compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
-DEFER: example
-[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
-[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
-[ 2 ] [ \ example "prop" word-prop ] unit-test
-
TUPLE: hello this that ;
C: <hello> hello
PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
M: hello bing hello-test ;
-MIMIC: bee goodbye hello
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
-[ V{ goodbye } ] [ baz protocol-users ] unit-test
+[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
+[ H{ } ] [ bee protocol-consult ] unit-test
-! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
-! [ [ baz see ] with-string-writer ] unit-test
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
-vectors definitions prettyprint combinators.lib math sets ;
+vectors definitions prettyprint combinators.lib math hashtables sets ;
IN: delegate
+: protocol-words ( protocol -- words )
+ \ protocol-words word-prop ;
+
+: protocol-consult ( protocol -- consulters )
+ \ protocol-consult word-prop ;
+
+GENERIC: group-words ( group -- words )
+
+M: tuple-class group-words
+ "slot-names" word-prop [
+ [ reader-word ] [ writer-word ] bi
+ 2array [ 0 2array ] map
+ ] map concat ;
+
+! Consultation
+
+: consult-method ( word class quot -- )
+ [ drop swap first create-method ]
+ [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
+
+: change-word-prop ( word prop quot -- )
+ rot word-props swap change-at ; inline
+
+: register-protocol ( group class quot -- )
+ rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
+
+: define-consult ( group class quot -- )
+ [ register-protocol ] [
+ rot group-words -rot
+ [ consult-method ] 2curry each
+ ] 3bi ;
+
+: CONSULT:
+ scan-word scan-word parse-definition define-consult ; parsing
+
! Protocols
: cross-2each ( seq1 seq2 quot -- )
: forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ;
-: protocol-words ( protocol -- words )
- "protocol-words" word-prop ;
-
: protocol-users ( protocol -- users )
- "protocol-users" word-prop ;
+ protocol-consult keys ;
-: users-and-words ( protocol -- users words )
- [ protocol-users ] [ protocol-words ] bi ;
+: lost-words ( protocol wordlist -- lost-words )
+ >r protocol-words r> diff ;
: forget-old-definitions ( protocol new-wordlist -- )
- >r users-and-words r>
+ >r [ protocol-users ] [ protocol-words ] bi r>
swap diff forget-all-methods ;
-: define-protocol ( protocol wordlist -- )
- ! 2dup forget-old-definitions
- { } like "protocol-words" set-word-prop ;
+: added-words ( protocol wordlist -- added-words )
+ swap protocol-words swap diff ;
+
+: add-new-definitions ( protocol wordlist -- )
+ dupd added-words >r protocol-consult >alist r>
+ [ first2 consult-method ] cross-2each ;
+
+: initialize-protocol-props ( protocol wordlist -- )
+ [ drop H{ } clone \ protocol-consult set-word-prop ]
+ [ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
+: define-protocol ( protocol wordlist -- )
+ fill-in-depth
+ [ forget-old-definitions ]
+ [ add-new-definitions ]
+ [ initialize-protocol-props ] 2tri ;
+
: PROTOCOL:
CREATE-WORD
- dup define-symbol
- dup f "inline" set-word-prop
- parse-definition fill-in-depth define-protocol ; parsing
+ [ define-symbol ]
+ [ f "inline" set-word-prop ]
+ [ parse-definition define-protocol ] tri ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
- [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
+ [ f forget-old-definitions ] [ call-next-method ] bi ;
: show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ;
M: protocol synopsis* word-synopsis ; ! Necessary?
-GENERIC: group-words ( group -- words )
-
-M: protocol group-words
- "protocol-words" word-prop ;
-
-M: tuple-class group-words
- "slot-names" word-prop [
- [ reader-word ] [ writer-word ] bi
- 2array [ 0 2array ] map
- ] map concat ;
-
-! Consultation
-
-: define-consult-method ( word class quot -- )
- [ drop swap first create-method ]
- [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
-
-: change-word-prop ( word prop quot -- )
- >r swap word-props r> change-at ; inline
-
-: add ( item vector/f -- vector )
- 2dup member? [ nip ] [ ?push ] if ;
-
-: use-protocol ( class group -- )
- "protocol-users" [ add ] change-word-prop ;
-
-: define-consult ( group class quot -- )
- swapd >r 2dup use-protocol group-words swap r>
- [ define-consult-method ] 2curry each ;
-
-: CONSULT:
- scan-word scan-word parse-definition define-consult ; parsing
-
-! Mimic still needs to be updated
-
-: mimic-method ( mimicker mimicked generic -- )
- tuck method
- [ [ create-method-in ] [ word-def ] bi* define ]
- [ 2drop ] if* ;
-
-: define-mimic ( group mimicker mimicked -- )
- [ drop swap use-protocol ] [
- rot group-words -rot
- [ rot first mimic-method ] 2curry each
- ] 3bi ;
-
-: MIMIC:
- scan-word scan-word scan-word define-mimic ; parsing
+M: protocol group-words protocol-words ;
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs prettyprint.sections
-io definitions kernel continuations ;
+io definitions kernel continuations listener ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ;
-PROTOCOL: stream-protocol
- stream-read1 stream-read stream-read-until dispose
+PROTOCOL: input-stream-protocol
+ stream-read1 stream-read stream-read-until stream-read-quot ;
+
+PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table ;
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations io.backend libc kernel namespaces
-sequences system vectors ;
+USING: continuations io.backend io.nonblocking libc kernel
+namespaces sequences system vectors ;
IN: destructors
SYMBOL: error-destructors
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
-: dispose-each ( seq -- )
- <reversed> [ dispose ] each ;
-
: do-always-destructors ( -- )
- always-destructors get dispose-each ;
+ always-destructors get <reversed> dispose-each ;
: do-error-destructors ( -- )
- error-destructors get dispose-each ;
+ error-destructors get <reversed> dispose-each ;
: with-destructors ( quot -- )
[
C: <handle-destructor> handle-destructor
-HOOK: destruct-handle io-backend ( obj -- )
-
M: handle-destructor dispose ( obj -- )
- handle-destructor-alien destruct-handle ;
+ handle-destructor-alien close-handle ;
: close-always ( handle -- )
<handle-destructor> add-always-destructor ;
] with-byte-writer ;
: send-jedit-request ( request -- )
- jedit-server-info "localhost" rot <inet> binary <client> [
+ jedit-server-info "localhost" rot <inet> binary [
4 >be write
dup length 2 >be write
write
- ] with-stream ;
+ ] with-client ;
: jedit-location ( file line -- )
number>string "+line:" prepend 2array
] with-html-stream
] with-string-writer ;
+: check-url ( href -- href' )
+ CHAR: : over member? [
+ dup { "http://" "https://" "ftp://" } [ head? ] with contains?
+ [ drop "/" ] unless
+ ] when ;
+
: escape-link ( href text -- href-esc text-esc )
- >r escape-quoted-string r> escape-string ;
+ >r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
escape-link
} ;\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
+"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } "." ;\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
[ { 1 2 3 } ] [
3 1 '[ , [ , + ] map ] call
] unit-test
+
+[ { 1 { 2 { 3 } } } ] [
+ 1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
+] unit-test
[ { , namespaces:, @ } member? ] filter length
\ , <repetition> %
]
- [ deep-fry % ] bi
+ [ fry % ] bi
] [ namespaces:, ] if
] each
] [ ] make deep-fry ;
collections
-collections sequences
+sequences
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: kernel sequences io.files io.launcher io.encodings.ascii
+io.streams.string http.client sequences.lib combinators
+math.parser math.vectors math.intervals interval-maps memoize
+csv accessors assocs strings math splitting ;
+IN: geo-ip
+
+: db-path "IpToCountry.csv" temp-file ;
+
+: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
+
+: download-db ( -- path )
+ db-path dup exists? [
+ db-url over ".gz" append download-to
+ { "gunzip" } over ".gz" append (normalize-path) suffix try-process
+ ] unless ;
+
+TUPLE: ip-entry from to registry assigned city cntry country ;
+
+: parse-ip-entry ( row -- ip-entry )
+ 7 firstn {
+ [ string>number ]
+ [ string>number ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ [ ]
+ } spread ip-entry boa ;
+
+MEMO: ip-db ( -- seq )
+ download-db ascii file-lines
+ [ "#" head? not ] filter "\n" join <string-reader> csv
+ [ parse-ip-entry ] map ;
+
+MEMO: ip-intervals ( -- interval-map )
+ ip-db [ [ [ from>> ] [ to>> ] bi [a,b] ] keep ] { } map>assoc
+ <interval-map> ;
+
+GENERIC: lookup-ip ( ip -- ip-entry )
+
+M: string lookup-ip
+ "." split [ string>number ] map
+ { HEX: 1000000 HEX: 10000 HEX: 100 1 } v.
+ lookup-ip ;
+
+M: integer lookup-ip ip-intervals interval-at ;
--- /dev/null
+IP address geolocation using database from http://software77.net/cgi-bin/ip-country/
--- /dev/null
+enterprise
M: gesture-logger handle-gesture*
drop
dup T{ button-down } = [ over request-focus ] when
- swap gesture-logger-stream [ . ] with-stream*
+ swap gesture-logger-stream [ . ] with-output-stream*
t ;
M: gesture-logger user-input*
gesture-logger-stream [
"User input: " write print
- ] with-stream* t ;
+ ] with-output-stream* t ;
: gesture-logger ( -- )
[
}
"Send some bytes to a remote host:"
{ $code
- "\"myhost\" 1033 <inet> <client>"
- "[ { 12 17 102 } >string write ] with-stream"
+ "\"myhost\" 1033 <inet>"
+ "[ { 12 17 102 } >string write ] with-client"
}
{ $references
{ }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
{ { $snippet { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple accessors) outputs the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
{ { $snippet "set-" { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple mutators) sets the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
- { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } }
+ { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } }
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
}
{ $heading "Stack effect conventions" }
"Utilities:"
{ $subsection "stream-binary" }
{ $subsection "styles" }
-{ $heading "Files" }
-{ $subsection "io.files" }
-{ $subsection "io.mmap" }
-{ $subsection "io.monitors" }
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
{ $subsection "io.encodings.string" }
-{ $heading "Other features" }
+{ $heading "Files" }
+{ $subsection "io.files" }
+{ $subsection "io.mmap" }
+{ $subsection "io.monitors" }
+{ $heading "Communications" }
{ $subsection "network-streams" }
{ $subsection "io.launcher" }
-{ $subsection "io.timeouts" } ;
+{ $subsection "io.pipes" }
+{ $heading "Other features" }
+{ $subsection "io.timeouts" }
+{ $subsection "checksums" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
HELP: help
{ $values { "topic" "an article name or a word" } }
{ $description
- "Displays a help article or documentation associated to a word on the " { $link stdio } " stream."
+ "Displays a help article or documentation associated to a word on " { $link output-stream } "."
} ;
HELP: about
HELP: ($index)
{ $values { "articles" "a sequence of help articles" } }
-{ $description "Writes a list of " { $link $subsection } " elements to the " { $link stdio } " stream." } ;
+{ $description "Writes a list of " { $link $subsection } " elements to " { $link output-stream } "." } ;
HELP: xref-help
{ $description "Update help cross-referencing. Usually this is done automatically." } ;
HELP: print-element
{ $values { "element" "a markup element" } }
-{ $description "Prints a markup element to the " { $link stdio } " stream." } ;
+{ $description "Prints a markup element to " { $link output-stream } "." } ;
HELP: print-content
{ $values { "element" "a markup element" } }
-{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ;
+{ $description "Prints a top-level markup element to " { $link output-stream } "." } ;
HELP: simple-element
{ $class-description "Class of simple elements, which are just arrays of elements." } ;
: check-example ( element -- )
rest [
- 1 head* "\n" join 1vector
+ but-last "\n" join 1vector
[
use [ clone ] change
[ eval>string ] with-datastack
{ $code "[ Letter? ] filter >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" }
-"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
+"You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style"
+ "script" "div" "span" "select" "option" "style" "input"
] [ define-closed-html-word ] each
! Define some open HTML tags
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title"
+ "media" "title" "multiple"
] [ define-attribute-word ] each
] with-compilation-unit
] unit-test
[ "<" ] [
- [ "<" H{ } stdio get format-html-span ] make-html-string
+ [ "<" H{ } output-stream get format-html-span ] make-html-string
] unit-test
TUPLE: funky town ;
rot html-sub-stream-stream ;
: delegate-write ( string -- )
- stdio get delegate stream-write ;
+ output-stream get delegate stream-write ;
: object-link-tag ( style quot -- )
presented pick at [
: format-html-span ( string style stream -- )
[
[ [ drop delegate-write ] span-tag ] object-link-tag
- ] with-stream* ;
+ ] with-output-stream* ;
TUPLE: html-span-stream ;
: format-html-div ( string style stream -- )
[
[ [ delegate-write ] div-tag ] object-link-tag
- ] with-stream* ;
+ ] with-output-stream* ;
TUPLE: html-block-stream ;
</td>
] with each </tr>
] with each </table>
- ] with-stream* ;
+ ] with-output-stream* ;
M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ;
M: html-stream stream-nl ( stream -- )
- dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ;
+ dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
! Utilities
: with-html-stream ( quot -- )
- stdio get <html-stream> swap with-stream* ; inline
+ output-stream get <html-stream> swap with-output-stream* ; inline
: xhtml-preamble
"<?xml version=\"1.0\"?>" write-html
: vertical-layout ( list -- )
#! Given a list of HTML components, arrange them vertically.
- <table>
+ <table>
[ <tr> <td> call </td> </tr> ] each
</table> ;
: horizontal-layout ( list -- )
#! Given a list of HTML components, arrange them horizontally.
- <table>
+ <table>
<tr "top" =valign tr> [ <td> call </td> ] each </tr>
</table> ;
: simple-page ( title quot -- )
#! Call the quotation, with all output going to the
#! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
+ <html>
+ <head> <title> swap write </title> </head>
<body> call </body>
</html> ;
#! Call the quotation, with all output going to the
#! body of an html page with the given title. stylesheet-quot
#! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
+ <html>
+ <head>
+ <title> rot write </title>
+ swap call
+ </head>
<body> call </body>
</html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
: find-between ( i/f tag/f vector -- vector )
find-between* dup length 3 >= [
- [ rest-slice 1 head-slice* ] keep like
+ [ rest-slice but-last-slice ] keep like
] when ;
: find-between-first ( string vector -- vector' )
dup quoted? [ quote ] unless ;
: unquote ( str -- newstr )
- dup quoted? [ 1 head-slice* rest-slice >string ] when ;
+ dup quoted? [ but-last-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ;
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order
-io.encodings.8-bit io.encodings.binary fry debugger inspector ;
+io.encodings.8-bit io.encodings.binary io.streams.duplex
+fry debugger inspector ;
IN: http.client
: max-redirects 10 ;
: 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 ;
+: request-with-url ( request url -- request )
+ parse-url >r >r store-path r> >>host r> >>port ;
SYMBOL: redirects
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
-: do-redirect ( response -- response stream )
- dup response-code 300 399 between? [
- stdio get dispose
+: do-redirect ( response data -- response data )
+ over code>> 300 399 between? [
+ drop
redirects inc
redirects get max-redirects < [
- header>> "location" swap at
- dup absolute-url? [
- absolute-redirect
- ] [
- relative-redirect
- ] if "GET" >>method http-request
+ request get
+ swap "location" header dup absolute-url?
+ [ request-with-url ] [ store-path ] if
+ "GET" >>method http-request
] [
too-many-redirects
] if
- ] [
- stdio get
- ] if ;
-
-: close-on-error ( stream quot -- )
- '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
+ ] when ;
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 ;
-
: read-chunks ( -- )
read-crlf ";" split1 drop hex> dup { f 0 } member?
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
-: do-chunked-encoding ( response stream -- response stream/string )
- over "transfer-encoding" header "chunked" = [
- [ [ read-chunks ] "" make ] with-stream
- ] when ;
+: read-response-body ( response -- response data )
+ dup "transfer-encoding" header "chunked" =
+ [ [ read-chunks ] "" make ] [ input-stream get contents ] if ;
-: <get-request> ( url -- request )
- <request> request-with-url "GET" >>method ;
+: http-request ( request -- response data )
+ dup request [
+ dup request-addr latin1 [
+ 1 minutes timeouts
+ write-request
+ read-response
+ read-response-body
+ ] with-client
+ do-redirect
+ ] with-variable ;
-: string-or-contents ( stream/string -- string )
- dup string? [ contents ] unless ;
+: <get-request> ( url -- request )
+ <request>
+ swap request-with-url
+ "GET" >>method ;
-: http-get-stream ( url -- response stream/string )
- <get-request> http-request do-chunked-encoding ;
+: http-get* ( url -- response data )
+ <get-request> http-request ;
: success? ( code -- ? ) 200 = ;
over code>> success? [ nip ] [ download-failed ] if ;
: http-get ( url -- string )
- http-get-stream string-or-contents check-response ;
+ http-get* 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.
- swap http-get-stream check-response
- dup string? [
- latin1 [ write ] with-file-writer
- ] [
- [ swap latin1 <file-writer> stream-copy ] with-disposal
- ] if ;
+ >r http-get r> latin1 [ write ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
: <post-request> ( content-type content url -- request )
<request>
- request-with-url
- "POST" >>method
- swap >>post-data
- swap >>post-data-type ;
+ "POST" >>method
+ swap request-with-url
+ swap >>post-data
+ swap >>post-data-type ;
-: http-post ( content-type content url -- response string )
- <post-request> http-request do-chunked-encoding string-or-contents ;
+: http-post ( content-type content url -- response data )
+ <post-request> http-request ;
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite ;
+assocs io.sockets db db.sqlite continuations ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
STRING: read-response-test-1
HTTP/1.1 404 not found
-Content-Type: text/html
+Content-Type: text/html; charset=UTF8
blah
;
version: "1.1"
code: 404
message: "not found"
- header: H{ { "content-type" "text/html" } }
+ header: H{ { "content-type" "text/html; charset=UTF8" } }
cookies: V{ }
+ content-type: "text/html"
+ content-charset: "UTF8"
}
] [
read-response-test-1 lf>crlf
STRING: read-response-test-1'
HTTP/1.1 404 not found
-content-type: text/html
+content-type: text/html; charset=UTF8
;
: add-quit-action
<action>
- [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+ [ stop-server [ "Goodbye" write ] <html-content> ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
+[ test-db drop delete-file ] ignore-errors
+
test-db [
init-sessions-table
] with-db
<dispatcher>
add-quit-action
<dispatcher>
- "extra/http/test" resource-path <static> >>default
+ "resource:extra/http/test" <static> >>default
"nested" add-responder
<action>
[ "redirect-loop" f <standard-redirect> ] >>display
] unit-test
[ t ] [
- "extra/http/test/foo.html" resource-path ascii file-contents
+ "resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get =
] unit-test
! Try with a slightly malformed request
[ t ] [
- "localhost" 1237 <inet> ascii <client> [
+ "localhost" 1237 <inet> ascii [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
read-crlf drop
read-header
- ] with-stream "location" swap at "/" head?
+ ] with-client "location" swap at "/" head?
] unit-test
[ "http://localhost:1237/redirect-loop" http-get ]
[ ] [
[
<dispatcher>
- <action> <protected>
<login>
<sessions>
"" add-responder
header-value>string check-header-string write crlf
] assoc-each crlf ;
+: add-query-param ( value key assoc -- )
+ [
+ at [
+ {
+ { [ dup string? ] [ swap 2array ] }
+ { [ dup array? ] [ swap suffix ] }
+ { [ dup not ] [ drop ] }
+ } cond
+ ] when*
+ ] 2keep set-at ;
+
: query>assoc ( query -- assoc )
dup [
- "&" split [
- "=" split1 [ dup [ url-decode ] when ] bi@
- ] H{ } map>assoc
+ "&" split H{ } clone [
+ [
+ >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
+ add-query-param
+ ] curry each
+ ] keep
] when ;
: assoc>query ( hash -- str )
[
- [ url-encode ]
- [ dup number? [ number>string ] when url-encode ]
- bi*
- "=" swap 3append
- ] { } assoc>map
- "&" join ;
+ {
+ { [ dup number? ] [ number>string 1array ] }
+ { [ dup string? ] [ 1array ] }
+ { [ dup sequence? ] [ ] }
+ } cond
+ ] assoc-map
+ [
+ [
+ >r url-encode r>
+ [ url-encode "=" swap 3append , ] with each
+ ] assoc-each
+ ] { } make "&" join ;
TUPLE: cookie name value path domain expires max-age http-only ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
+: parse-content-type-attributes ( string -- attributes )
+ " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
+
+: parse-content-type ( content-type -- type encoding )
+ ";" split1 parse-content-type-attributes "charset" swap at ;
+
: read-request ( -- request )
<request>
read-method
message
header
cookies
+content-type
+content-charset
body ;
: <response>
: read-response-header
read-header >>header
- dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
+ extract-cookies
+ dup "content-type" header [
+ parse-content-type [ >>content-type ] [ >>content-charset ] bi*
+ ] when* ;
: read-response ( -- response )
<response>
: write-response-message ( response -- response )
dup message>> write crlf ;
+: unparse-content-type ( request -- content-type )
+ [ content-type>> "application/octet-stream" or ]
+ [ content-charset>> ] bi
+ [ "; charset=" swap 3append ] when* ;
+
: write-response-header ( response -- response )
dup header>> clone
- over cookies>> f like
- [ unparse-cookies "set-cookie" pick set-at ] when*
+ over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
+ over unparse-content-type "content-type" pick set-at
write-header ;
GENERIC: write-response-body* ( body -- )
M: callable write-response-body* call ;
-M: object write-response-body* stdio get stream-copy ;
+M: object write-response-body* output-stream get stream-copy ;
: write-response-body ( response -- response )
dup body>> write-response-body* ;
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 ;
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ;
-TUPLE: raw-response
+TUPLE: raw-response
version
code
message
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors sequences kernel assocs combinators\r
http.server http.server.validators http hashtables namespaces\r
-fry continuations locals ;\r
+fry continuations locals boxes xml.entities html.elements io ;\r
IN: http.server.actions\r
\r
-SYMBOL: +path+\r
-\r
SYMBOL: params\r
\r
+SYMBOL: validation-message\r
+\r
+: render-validation-message ( -- )\r
+ validation-message get value>> [\r
+ <span "error" =class span>\r
+ escape-string write\r
+ </span>\r
+ ] when* ;\r
+\r
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
: validation-failed ( -- * )\r
action get display>> call exit-with ;\r
\r
+: validation-failed-with ( string -- * )\r
+ validation-message get >box\r
+ validation-failed ;\r
+\r
M: action call-responder* ( path action -- response )\r
'[\r
, [ CHAR: / = ] right-trim empty? [\r
, action set\r
request get\r
+ <box> validation-message set\r
[ request-params params set ]\r
[\r
method>> {\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators
-locals db.tuples
+USING: kernel sequences accessors namespaces combinators words
+assocs locals db.tuples arrays splitting strings qualified
+
http.server.templating.chloe
http.server.boilerplate
http.server.auth.providers
http.server.auth.providers.db
http.server.auth.login
+http.server.auth
http.server.forms
http.server.components.inspector
-http.server.components
http.server.validators
http.server.sessions
http.server.actions
http.server.crud
http.server ;
+EXCLUDE: http.server.components => string? number? ;
IN: http.server.auth.admin
: admin-template ( name -- template )
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
+: words>strings ( seq -- seq' )
+ [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
+
+: strings>words ( seq -- seq' )
+ [ ":" split1 swap lookup ] map ;
+
+: <capabilities> ( id -- component )
+ capabilities get words>strings <menu> ;
+
: <new-user-form> ( -- form )
"user" <form>
"new-user" admin-template >>edit-template
"realname" <string> add-field
"new-password" <password> t >>required add-field
"verify-password" <password> t >>required add-field
- "email" <email> add-field ;
+ "email" <email> add-field
+ "capabilities" <capabilities> add-field ;
: <edit-user-form> ( -- form )
"user" <form>
"new-password" <password> add-field
"verify-password" <password> add-field
"email" <email> add-field
- "profile" <inspector> add-field ;
+ "profile" <inspector> add-field
+ "capabilities" <capabilities> add-field ;
: <user-list-form> ( -- form )
"user-list" <form>
same-password-twice
- user new "username" value >>username select-tuple [
- user-exists? on
- validation-failed
- ] when
+ user new "username" value >>username select-tuple
+ [ user-exists ] when
"username" value <user>
"realname" value >>realname
"email" value >>email
- "new-password" value >>password
+ "new-password" value >>encoded-password
H{ } clone >>profile
insert-tuple
[ realname>> "realname" set-value ]
[ email>> "email" set-value ]
[ profile>> "profile" set-value ]
+ [ capabilities>> words>strings "capabilities" set-value ]
} cleave
] >>init
{ "new-password" "verify-password" }
[ value empty? ] all? [
same-password-twice
- "new-password" value >>password
+ "new-password" value >>encoded-password
] unless
+ "capabilities" value {
+ { [ dup string? ] [ 1array ] }
+ { [ dup array? ] [ ] }
+ } cond strings>words >>capabilities
+
update-tuple
next f <standard-redirect>
TUPLE: user-admin < dispatcher ;
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
:: <user-admin> ( -- responder )
[let | ctor [ [ <user> ] ] |
user-admin new-dispatcher
ctor "$user-admin" <delete-user-action> "delete" add-responder
<boilerplate>
"admin" admin-template >>template
- <protected>
+
{ can-administer-users? } <protected>
] ;
+
+: make-admin ( username -- )
+ <user>
+ select-tuple
+ [ can-administer-users? suffix ] change-capabilities
+ update-tuple ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style include="resource:extra/http/server/auth/admin/admin.css" />
-
<div class="navbar">
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:title>Edit User</t:title>
- <t:form t:action="$user-admin/edit">
-
- <t:edit t:component="username" />
+ <t:form t:action="$user-admin/edit" t:for="username">
<table>
<td><t:edit t:component="email" /></td>
</tr>
+ <tr>
+ <th class="field-label big-field-label">Capabilities:</th>
+ <td><t:edit t:component="capabilities" /></td>
+ </tr>
+
<tr>
<th class="field-label">Profile:</th>
<td><t:view t:component="profile" /></td>
<p>
<button type="submit" class="link-button link">Update</button>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
- <t:form t:action="$user-admin/delete">
- <t:edit t:component="username" />
-
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$user-admin/delete" t:for="username" class="link-button link">Delete</t:button>
</t:chloe>
<th class="field-label">E-mail:</th>
<td><t:edit t:component="email" /></td>
</tr>
+
+ <tr>
+ <th class="field-label big-field-label">Capabilities:</th>
+ <td><t:edit t:component="capabilities" /></td>
+ </tr>
</table>
<p>
<button type="submit" class="link-button link">Create</button>
-
- <t:if t:var="http.server.auth.login:user-exists?">
- <t:error>username taken</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel\r
+USING: accessors assocs namespaces kernel sequences\r
http.server\r
http.server.sessions\r
http.server.auth.providers ;\r
: uchange ( quot key -- )\r
profile swap change-at\r
user-changed ; inline\r
+\r
+SYMBOL: capabilities\r
+\r
+V{ } clone capabilities set-global\r
+\r
+: define-capability ( word -- ) capabilities get push-new ;\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors 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.auth.providers http.server.auth.login\r
http sequences ;\r
IN: http.server.auth.basic\r
\r
<p>
<input type="submit" value="Update" />
-
- <t:if t:var="http.server.auth.login:login-failed?">
- <t:error>invalid password</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors quotations assocs kernel splitting\r
-base64 io combinators sequences io.files namespaces hashtables\r
-fry io.sockets arrays threads locals qualified continuations\r
+combinators sequences namespaces hashtables sets\r
+fry arrays threads locals qualified random\r
+io\r
+io.sockets\r
+io.encodings.utf8\r
+io.encodings.string\r
+io.binary\r
+continuations\r
destructors\r
-\r
+checksums\r
+checksums.sha2\r
html.elements\r
http\r
http.server\r
http.server.auth\r
http.server.auth.providers\r
-http.server.auth.providers.null\r
+http.server.auth.providers.db\r
http.server.actions\r
http.server.components\r
http.server.flows\r
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
-SYMBOL: login-failed?\r
+TUPLE: login < dispatcher users checksum ;\r
+\r
+: users ( -- provider )\r
+ login get users>> ;\r
+\r
+: encode-password ( string salt -- bytes )\r
+ [ utf8 encode ] [ 4 >be ] bi* append\r
+ login get checksum>> checksum-bytes ;\r
\r
-TUPLE: login < dispatcher users ;\r
+: >>encoded-password ( user string -- user )\r
+ 32 random-bits [ encode-password ] keep\r
+ [ >>password ] [ >>salt ] bi* ; inline\r
\r
-: users login get users>> ;\r
+: valid-login? ( password user -- ? )\r
+ [ salt>> encode-password ] [ password>> ] bi = ;\r
+\r
+: check-login ( password username -- user/f )\r
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
\r
! Destructor\r
TUPLE: user-saver user ;\r
username>> set-uid\r
"$login" end-flow ;\r
\r
+: login-failed "invalid username or password" validation-failed-with ;\r
+\r
:: <login-action> ( -- action )\r
[let | form [ <login-form> ] |\r
<action>\r
\r
form validate-form\r
\r
- "password" value "username" value\r
- users check-login [\r
- successful-login\r
- ] [\r
- login-failed? on\r
- validation-failed\r
- ] if*\r
+ "password" value "username" value check-login\r
+ [ successful-login ] [ login-failed ] if*\r
] >>submit\r
] ;\r
\r
"email" <email> add-field\r
"captcha" <captcha> add-field ;\r
\r
-SYMBOL: password-mismatch?\r
-SYMBOL: user-exists?\r
+: password-mismatch "passwords do not match" validation-failed-with ;\r
+\r
+: user-exists "username taken" validation-failed-with ;\r
\r
: same-password-twice ( -- )\r
- "new-password" value "verify-password" value = [ \r
- password-mismatch? on\r
- validation-failed\r
- ] unless ;\r
+ "new-password" value "verify-password" value =\r
+ [ password-mismatch ] unless ;\r
\r
:: <register-action> ( -- action )\r
[let | form [ <register-form> ] |\r
\r
"username" value <user>\r
"realname" value >>realname\r
- "new-password" value >>password\r
+ "new-password" value >>encoded-password\r
"email" value >>email\r
H{ } clone >>profile\r
\r
- users new-user [\r
- user-exists? on\r
- validation-failed\r
- ] unless*\r
+ users new-user [ user-exists ] unless*\r
\r
successful-login\r
\r
[ value empty? ] all? [\r
same-password-twice\r
\r
- "password" value uid users check-login\r
- [ login-failed? on validation-failed ] unless\r
+ "password" value uid check-login\r
+ [ login-failed ] unless\r
\r
- "new-password" value >>password\r
+ "new-password" value >>encoded-password\r
] unless\r
\r
"realname" value >>realname\r
"ticket" value\r
"username" value\r
users claim-ticket [\r
- "new-password" value >>password\r
+ "new-password" value >>encoded-password\r
users update-user\r
\r
"recover-4" login-template serve-template\r
\r
! ! ! Authentication logic\r
\r
-TUPLE: protected < filter-responder ;\r
+TUPLE: protected < filter-responder capabilities ;\r
\r
C: <protected> protected\r
\r
begin-flow\r
"$login/login" f <standard-redirect> ;\r
\r
+: check-capabilities ( responder user -- ? )\r
+ [ capabilities>> ] bi@ subset? ;\r
+\r
M: protected call-responder* ( path responder -- response )\r
uid dup [\r
- users get-user\r
- [ logged-in-user set ] [ save-user-after ] bi\r
- call-next-method\r
+ users get-user 2dup check-capabilities [\r
+ [ logged-in-user set ] [ save-user-after ] bi\r
+ call-next-method\r
+ ] [\r
+ 3drop show-login-page\r
+ ] if\r
] [\r
3drop show-login-page\r
] if ;\r
swap >>default\r
<login-action> <login-boilerplate> "login" add-responder\r
<logout-action> <login-boilerplate> "logout" add-responder\r
- no-users >>users ;\r
+ users-in-db >>users\r
+ sha-256 >>checksum ;\r
\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <protected> <login-boilerplate>\r
+ <edit-profile-action>
f <protected> <login-boilerplate>
\r "edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
<p>
<input type="submit" value="Log in" />
+ <t:validation-message />
- <t:if t:var="http.server.auth.login:login-failed?">
- <t:error>invalid username or password</t:error>
- </t:if>
</p>
</t:form>
<p>
<input type="submit" value="Set password" />
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
</t:form>
<p>
<input type="submit" value="Register" />
-
- <t:if t:var="http.server.auth.login:user-exists?">
- <t:error>username taken</t:error>
- </t:if>
-
- <t:if t:var="http.server.auth.login:password-mismatch?">
- <t:error>passwords do not match</t:error>
- </t:if>
+ <t:validation-message />
</p>
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
+USING: http.server.actions http.server.auth.providers \r
+http.server.auth.providers.assoc http.server.auth.login\r
+tools.test namespaces accessors kernel ;\r
\r
-<users-in-memory> "provider" set\r
+<action> <login>\r
+ <users-in-memory> >>users\r
+login set\r
\r
[ t ] [\r
"slava" <user>\r
- "foobar" >>password\r
+ "foobar" >>encoded-password\r
"slava@factorcode.org" >>email\r
H{ } clone >>profile\r
- "provider" get new-user\r
+ users new-user\r
username>> "slava" =\r
] unit-test\r
\r
[ f ] [\r
"slava" <user>\r
H{ } clone >>profile\r
- "provider" get new-user\r
+ users new-user\r
] unit-test\r
\r
-[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
\r
-[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test\r
+[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
-[ ] [ "user" get "fdasf" >>password drop ] unit-test\r
+[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
\r
-[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
\r
-[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
IN: http.server.auth.providers.db.tests\r
-USING: http.server.auth.providers\r
+USING: http.server.actions\r
+http.server.auth.login\r
+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
-users-in-db "provider" set\r
+<action> <login>\r
+ users-in-db >>users\r
+login set\r
\r
[ "auth-test.db" temp-file delete-file ] ignore-errors\r
\r
\r
[ t ] [\r
"slava" <user>\r
- "foobar" >>password\r
+ "foobar" >>encoded-password\r
"slava@factorcode.org" >>email\r
H{ } clone >>profile\r
- "provider" get new-user\r
+ users new-user\r
username>> "slava" =\r
] unit-test\r
\r
[ f ] [\r
"slava" <user>\r
H{ } clone >>profile\r
- "provider" get new-user\r
+ users new-user\r
] unit-test\r
\r
- [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+ [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
\r
- [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test\r
+ [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
- [ ] [ "user" get "fdasf" >>password drop ] unit-test\r
+ [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
\r
- [ ] [ "user" get "provider" get update-user ] unit-test\r
+ [ ] [ "user" get users update-user ] unit-test\r
\r
- [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
+ [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
\r
- [ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+ [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
] with-db\r
{
{ "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
{ "realname" "REALNAME" { VARCHAR 256 } }
- { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+ { "password" "PASSWORD" BLOB +not-null+ }
+ { "salt" "SALT" INTEGER +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } }
{ "ticket" "TICKET" { VARCHAR 256 } }
+ { "capabilities" "CAPABILITIES" FACTOR-BLOB }
{ "profile" "PROFILE" FACTOR-BLOB }
{ "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors random math.parser locals\r
-sequences math crypto.sha2 ;\r
+sequences math ;\r
IN: http.server.auth.providers\r
\r
-TUPLE: user username realname password email ticket profile deleted changed? ;\r
+TUPLE: user\r
+username realname\r
+password salt\r
+email ticket capabilities profile deleted changed? ;\r
\r
: <user> ( username -- user )\r
user new\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
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings
-io io.streams.string arrays
+io io.streams.string arrays locals
html.elements
http
http.server
SYMBOL: next-template
: call-next-template ( -- )
- next-template get write ;
+ next-template get write-html ;
M: f call-template* drop call-next-template ;
bi*
] with-scope ; inline
-M: boilerplate call-responder*
- tuck call-next-method
- dup "content-type" header "text/html" = [
- clone swap template>>
- [ [ with-boilerplate ] 2curry ] curry change-body
- ] [ nip ] if ;
+M:: boilerplate call-responder* ( path responder -- )
+ path responder call-next-method
+ dup content-type>> "text/html" = [
+ clone [| body |
+ [ body responder template>> with-boilerplate ]
+ ] change-body
+ ] when ;
<action> [\r
[\r
"hello" print\r
- "text/html" <content> swap '[ , write ] >>body\r
+ '[ , write ] <html-content>\r
] show-page\r
"byebye" print\r
[ 123 ] show-final\r
! 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
+USING: namespaces kernel assocs io.files io.streams.duplex\r
+combinators arrays io.launcher io http.server.static http.server\r
http accessors sequences strings math.parser fry ;\r
IN: http.server.cgi\r
\r
200 >>code\r
"CGI output follows" >>message\r
swap '[\r
- ,
stdio get swap <cgi-process> <process-stream> [
\r+ ,
output-stream get swap <cgi-process> <process-stream> [
\r post? [ request get post-data>> write flush ] when\r
- stdio get swap (stream-copy)\r
+ input-stream get swap (stream-copy)\r
] with-stream\r
] >>body ;\r
\r
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components ;
+http.server.components html xml.entities ;
IN: http.server.components.code
TUPLE: code-renderer < text-renderer mode ;
swap >>mode ;
M: code-renderer render-view*
- [ string-lines ] [ mode>> value ] bi* htmlize-lines ;
+ [
+ [ string-lines ] [ mode>> value ] bi* htmlize-lines
+ ] with-html-stream ;
: <code> ( id mode -- component )
swap <text>
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
-hashtables fry combinators continuations math
-calendar.format html.elements
+hashtables fry locals combinators continuations math
+calendar.format html html.elements xml.entities
http.server.validators ;
IN: http.server.components
C: <field> field
-M: field render-view* drop write ;
+M: field render-view*
+ drop escape-string write ;
M: field render-edit*
- <input type>> =type [ =id ] [ =name ] bi =value input/> ;
-
-: render-error ( message -- )
- <span "error" =class span> write </span> ;
+ <input type>> =type =name =value input/> ;
TUPLE: hidden < field ;
text-renderer new-text-renderer ;
M: text-renderer render-view*
- drop write ;
+ drop escape-string write ;
M: text-renderer render-edit*
<textarea
[ =id ]
[ =name ] bi
textarea>
- write
+ escape-string write
</textarea> ;
TUPLE: text < string ;
html-text-renderer new-text-renderer ;
M: html-text-renderer render-view*
- drop write ;
+ drop escape-string write ;
TUPLE: html-text < text ;
SINGLETON: link-renderer
M: link-renderer render-view*
- drop <a dup link-href =href a> link-title write </a> ;
+ drop <a dup link-href =href a> link-title escape-string write </a> ;
TUPLE: link < string ;
C: <choice-renderer> choice-renderer
M: choice-renderer render-view*
- drop write ;
+ drop escape-string write ;
+
+: render-option ( text selected? -- )
+ <option [ "true" =selected ] when option>
+ escape-string write
+ </option> ;
+
+: render-options ( options selected -- )
+ '[ dup , member? render-option ] each ;
M: choice-renderer render-edit*
<select swap =name select>
- choices>> [
- <option [ = [ "true" =selected ] when ] keep option>
- write
- </option>
- ] with each
+ choices>> swap 1array render-options
</select> ;
TUPLE: choice < string ;
: <choice> ( id choices -- component )
swap choice new-string
swap <choice-renderer> >>renderer ;
+
+! Menu
+TUPLE: menu-renderer choices size ;
+
+: <menu-renderer> ( choices -- renderer )
+ 5 menu-renderer boa ;
+
+M:: menu-renderer render-edit* ( value id renderer -- )
+ <select
+ renderer size>> [ number>string =size ] when*
+ id =name
+ "true" =multiple
+ select>
+ renderer choices>> value render-options
+ </select> ;
+
+TUPLE: menu < string ;
+
+: <menu> ( id choices -- component )
+ swap menu new-string
+ swap <menu-renderer> >>renderer ;
+
+! Checkboxes
+TUPLE: checkbox-renderer label ;
+
+C: <checkbox-renderer> checkbox-renderer
+
+M: checkbox-renderer render-edit*
+ <input
+ "checkbox" =type
+ swap =id
+ swap [ "true" =selected ] when
+ input>
+ label>> escape-string write
+ </input> ;
+
+TUPLE: checkbox < string ;
+
+: <checkbox> ( id label -- component )
+ checkbox swap <checkbox-renderer> new-component ;
! Copyright (C) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: splitting kernel io sequences farkup accessors\r
-http.server.components ;\r
+http.server.components xml.entities ;\r
IN: http.server.components.farkup\r
\r
TUPLE: farkup-renderer < text-renderer ;\r
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences inspector accessors
-http.server.components ;
+http.server.components xml.entities html ;
IN: http.server.components.inspector
SINGLETON: inspector-renderer
M: inspector-renderer render-view*
- drop describe ;
+ drop [ describe ] with-html-stream ;
TUPLE: inspector < component ;
--- /dev/null
+IN: http.server.db.tests
+USING: tools.test http.server.db ;
+
+\ <db-persistence> must-infer
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: db http.server http.server.sessions kernel accessors\r
-continuations namespaces destructors ;\r
+USING: db db.pooling http.server http.server.sessions kernel\r
+accessors continuations namespaces destructors ;\r
IN: http.server.db\r
\r
-TUPLE: db-persistence < filter-responder db params ;\r
+TUPLE: db-persistence < filter-responder pool ;\r
\r
-C: <db-persistence> db-persistence\r
-\r
-: connect-db ( db-persistence -- )\r
- [ db>> ] [ params>> ] bi make-db db-open\r
- [ db set ] [ add-always-destructor ] bi ;\r
+: <db-persistence> ( responder db params -- responder' )\r
+ <pool> db-persistence boa ;\r
\r
M: db-persistence call-responder*\r
- [ connect-db ] [ call-next-method ] bi ;\r
+ [\r
+ pool>> [ acquire-connection ] keep\r
+ [ return-connection-later ] [ drop db set ] 2bi\r
+ ]\r
+ [ call-next-method ] bi ;\r
] with-form ;
: <form-response> ( form template -- response )
- [ components>> components set ]
- [ "text/html" <content> swap >>body ]
- bi* ;
+ [ components>> components set ] [ <html-content> ] bi* ;
: view-form ( form -- response )
dup view-template>> <form-response> ;
! 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 sequences prettyprint io.server logging calendar
-html.elements accessors math.parser combinators.lib
-tools.vocabs debugger html continuations random combinators
+threads sequences prettyprint io.server logging calendar
+http html html.elements accessors math.parser combinators.lib
+tools.vocabs debugger continuations random combinators
destructors io.encodings.8-bit fry classes words ;
IN: http.server
<response>
200 >>code
"Document follows" >>message
- swap set-content-type ;
+ swap >>content-type ;
+
+: <html-content> ( quot -- response )
+ "text/html" <content> swap >>body ;
TUPLE: trivial-responder response ;
</html> ;
: <trivial-response> ( code message -- response )
- 2dup '[ , , trivial-response-body ]
- "text/html" <content>
- swap >>body
+ 2dup '[ , , trivial-response-body ] <html-content>
swap >>message
swap >>code ;
bi
] recover ;
-: default-timeout 1 minutes stdio get set-timeout ;
-
: ?refresh-all ( -- )
development-mode get-global
[ global [ refresh-all ] bind ] when ;
: handle-client ( -- )
[
- default-timeout
+ 1 minutes timeouts
?refresh-all
read-request
do-request
] with-destructors response set\r
] unit-test\r
\r
- [ "text/plain" ] [ response get "content-type" header ] unit-test\r
+ [ "text/plain" ] [ response get content-type>> ] unit-test\r
\r
[ f ] [ response get cookies>> empty? ] unit-test\r
] with-scope\r
! 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 accessors io.encodings.binary fry ;\r
+USING: calendar html io io.files kernel math math.order\r
+math.parser http http.server namespaces parser sequences strings\r
+assocs hashtables debugger http.mime sorting html.elements\r
+logging calendar.format accessors io.encodings.binary fry ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
-TUPLE: file-responder root hook special ;\r
+TUPLE: file-responder root hook special allow-listings ;\r
\r
-: file-http-date ( filename -- string )\r
- file-info modified>> timestamp>http-string ;\r
-\r
-: last-modified-matches? ( filename -- ? )\r
- file-http-date dup [\r
- request get "if-modified-since" header =\r
- ] when ;\r
+: modified-since? ( filename -- ? )\r
+ request get "if-modified-since" header dup [\r
+ [ file-info modified>> ] [ rfc822>timestamp ] bi* after?\r
+ ] [\r
+ 2drop t\r
+ ] if ;\r
\r
: <304> ( -- response )\r
304 "Not modified" <trivial-response> ;\r
\r
+: <403> ( -- response )\r
+ 403 "Forbidden" <trivial-response> ;\r
+\r
: <file-responder> ( root hook -- responder )\r
- H{ } clone file-responder boa ;\r
+ file-responder new\r
+ swap >>hook\r
+ swap >>root\r
+ H{ } clone >>special ;\r
\r
: <static> ( root -- responder )\r
[\r
<content>\r
- swap\r
- [ file-info size>> "content-length" set-header ]\r
- [ file-http-date "last-modified" set-header ]\r
- [ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
- tri\r
+ swap [\r
+ file-info\r
+ [ size>> "content-length" set-header ]\r
+ [ modified>> "last-modified" set-header ] bi\r
+ ]\r
+ [ '[ , binary <file-reader> output-stream get stream-copy ] >>body ] bi\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
+ over modified-since?\r
+ [ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
\r
: serving-path ( filename -- filename )\r
file-responder get root>> right-trim-separators\r
] simple-html-document ;\r
\r
: list-directory ( directory -- response )\r
- "text/html" <content>\r
- swap '[ , directory. ] >>body ;\r
+ file-responder get allow-listings>> [\r
+ '[ , directory. ] <html-content>\r
+ ] [\r
+ drop <403>\r
+ ] if ;\r
\r
: find-index ( filename -- path )\r
"index.html" append-path dup exists? [ drop f ] unless ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 html.elements unicode.case
-tuple-syntax xml xml.data xml.writer xml.utilities
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax html html.elements
+multiline xml xml.data xml.writer xml.utilities
http.server
http.server.auth
http.server.flows
+http.server.actions
http.server.components
http.server.sessions
http.server.templating
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-: filter-chloe-attrs ( assoc -- assoc' )
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
: optional-attr ( tag name -- value )
chloe-name swap at ;
+: children>string ( tag -- string )
+ [ [ process-template ] each ] with-string-writer ;
+
+: title-tag ( tag -- )
+ children>string set-title ;
+
: write-title-tag ( tag -- )
drop
"head" tags get member? "title" tags get member? not and
: form-start-tag ( tag -- )
[
- <form
- "POST" =method
- {
- [ flow-attr ]
- [ session-attr ]
- [ "action" required-attr resolve-base-path =action ]
- [ tag-attrs filter-chloe-attrs print-attrs ]
- } cleave
- form>
- hidden-form-field
+ [
+ <form
+ "POST" =method
+ {
+ [ flow-attr ]
+ [ session-attr ]
+ [ "action" required-attr resolve-base-path =action ]
+ [ tag-attrs non-chloe-attrs-only print-attrs ]
+ } cleave
+ form>
+ ] [
+ hidden-form-field
+ "for" optional-attr [ component render-edit ] when*
+ ] bi
] with-scope ;
: form-tag ( tag -- )
[ drop </form> ]
tri ;
+DEFER: process-chloe-tag
+
+STRING: button-tag-markup
+<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
+ <button type="submit"></button>
+</t:form>
+;
+
+: add-tag-attrs ( attrs tag -- )
+ tag-attrs swap update ;
+
+: button-tag ( tag -- )
+ button-tag-markup string>xml delegate
+ {
+ [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
+ [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
+ [ >r children>string 1array r> "button" tag-named set-tag-children ]
+ [ nip ]
+ } 2cleave process-chloe-tag ;
+
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
] unless ;
: if-satisfied? ( tag -- ? )
+ t swap
{
- [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
- [ "var" optional-attr [ attr>var get ] [ t ] if* ]
- [ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
- [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
- } cleave 4array [ ] all? ;
+ [ "code" optional-attr [ attr>word execute and ] when* ]
+ [ "var" optional-attr [ attr>var get and ] when* ]
+ [ "svar" optional-attr [ attr>var sget and ] when* ]
+ [ "uvar" optional-attr [ attr>var uget and ] when* ]
+ [ "value" optional-attr [ value and ] when* ]
+ } cleave ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-: error-tag ( tag -- )
+: error-message-tag ( tag -- )
children>string render-error ;
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ [ process-template ] each ] }
- { "title" [ children>string set-title ] }
+ { "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "summary" [ summary-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
- { "error" [ error-tag ] }
+ { "button" [ button-tag ] }
+ { "error-message" [ error-message-tag ] }
+ { "validation-message" [ drop render-validation-message ] }
{ "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
! responder integration
: serve-template ( template -- response )
- "text/html" <content>
- swap '[ , call-template ] >>body ;
+ '[ , call-template ] <html-content> ;
init f exec-loop ;
: run-sand ( -- )
- "extra/icfp/2006/sandmark.umz" resource-path run-prog ;
+ "resource:extra/icfp/2006/sandmark.umz" run-prog ;
--- /dev/null
+Daniel Ehrenberg\r
--- /dev/null
+USING: help.markup help.syntax ;\r
+IN: interval-maps\r
+\r
+HELP: interval-at*\r
+{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }\r
+{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ;\r
+\r
+HELP: interval-at\r
+{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } }\r
+{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ;\r
+\r
+HELP: interval-key?\r
+{ $values { "key" "an object" } { "map" "an interval map" } { "?" "a boolean" } }\r
+{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ;\r
+\r
+HELP: <interval-map>\r
+{ $values { "specification" "an assoc" } { "map" "an interval map" } }\r
+{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;\r
+\r
+ARTICLE: "interval-maps" "Interval maps"\r
+"Interval maps are a mechanism, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."\r
+"The following operations are used to query interval maps:"\r
+{ $subsection interval-at* }\r
+{ $subsection interval-at }\r
+{ $subsection interval-key? }\r
+"Use the following to construct interval maps"\r
+{ $subsection <interval-map> } ;\r
+\r
+ABOUT: "interval-maps"\r
--- /dev/null
+USING: kernel namespaces interval-maps tools.test ;\r
+IN: interval-maps.test\r
+\r
+SYMBOL: test\r
+\r
+[ ] [ { { { 4 8 } 3 } { 1 2 } } <interval-map> test set ] unit-test\r
+[ 3 ] [ 5 test get interval-at ] unit-test\r
+[ 3 ] [ 8 test get interval-at ] unit-test\r
+[ 3 ] [ 4 test get interval-at ] unit-test\r
+[ f ] [ 9 test get interval-at ] unit-test\r
+[ 2 ] [ 1 test get interval-at ] unit-test\r
+[ f ] [ 2 test get interval-at ] unit-test\r
+[ f ] [ 0 test get interval-at ] unit-test\r
+\r
+[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail\r
+\r
+[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]\r
+[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test\r
--- /dev/null
+USING: kernel sequences arrays math.intervals accessors\r
+math.order sorting math assocs locals namespaces ;\r
+IN: interval-maps\r
+\r
+TUPLE: interval-map array ;\r
+\r
+<PRIVATE\r
+TUPLE: interval-node interval value ;\r
+\r
+: fixup-value ( value ? -- value/f ? )\r
+ [ drop f f ] unless* ;\r
+\r
+: find-interval ( key interval-map -- i )\r
+ [ interval>> from>> first <=> ] binsearch ;\r
+\r
+GENERIC: >interval ( object -- interval )\r
+M: number >interval [a,a] ;\r
+M: sequence >interval first2 [a,b] ;\r
+M: interval >interval ;\r
+\r
+: all-intervals ( sequence -- intervals )\r
+ [ >r >interval r> ] assoc-map ;\r
+\r
+: ensure-disjoint ( intervals -- intervals )\r
+ dup keys [ interval-intersect not ] monotonic?\r
+ [ "Intervals are not disjoint" throw ] unless ;\r
+\r
+\r
+PRIVATE>\r
+\r
+: interval-at* ( key map -- value ? )\r
+ array>> [ find-interval ] 2keep swapd nth\r
+ [ nip value>> ] [ interval>> interval-contains? ] 2bi\r
+ fixup-value ;\r
+\r
+: interval-at ( key map -- value ) interval-at* drop ;\r
+: interval-key? ( key map -- ? ) interval-at* nip ;\r
+\r
+: <interval-map> ( specification -- map )\r
+ all-intervals { } assoc-like\r
+ [ [ first to>> ] compare ] sort ensure-disjoint\r
+ [ interval-node boa ] { } assoc>map\r
+ interval-map boa ;\r
+\r
+:: coalesce ( alist -- specification )\r
+ ! Only works with integer keys, because they're discrete\r
+ ! Makes 2array keys\r
+ [\r
+ alist sort-keys unclip first2 dupd roll\r
+ [| oldkey oldval key val | ! Underneath is start\r
+ oldkey 1+ key =\r
+ oldval val = and\r
+ [ oldkey 2array oldval 2array , key ] unless\r
+ key val\r
+ ] assoc-each [ 2array ] bi@ ,\r
+ ] { } make ;\r
--- /dev/null
+Interval maps for disjoint closed ranges\r
--- /dev/null
+collections\r
\ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse
-\ suffix [ dup 1 head* swap peek ] define-inverse
+\ suffix [ dup but-last swap peek ] define-inverse
! Constructor inverse
: deconstruct-pred ( class -- quot )
} ;
: encoding-file ( file-name -- stream )
- "extra/io/encodings/8-bit/" ".TXT"
- swapd 3append resource-path
- ascii <file-reader> ;
+ "resource:extra/io/encodings/8-bit/" ".TXT"
+ swapd 3append ascii <file-reader> ;
: tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+Name: ANSI_X3.4-1968 [RFC1345,KXS2]
+MIBenum: 3
+Source: ECMA registry
+Alias: iso-ir-6
+Alias: ANSI_X3.4-1986
+Alias: ISO_646.irv:1991
+Alias: ASCII
+Alias: ISO646-US
+Alias: US-ASCII (preferred MIME name)
+Alias: us
+Alias: IBM367
+Alias: cp367
+Alias: csASCII
+
+Name: ISO_8859-1:1987 [RFC1345,KXS2]
+MIBenum: 4
+Source: ECMA registry
+Alias: iso-ir-100
+Alias: ISO_8859-1
+Alias: ISO-8859-1 (preferred MIME name)
+Alias: latin1
+Alias: l1
+Alias: IBM819
+Alias: CP819
+Alias: csISOLatin1
+
+Name: ISO_8859-2:1987 [RFC1345,KXS2]
+MIBenum: 5
+Source: ECMA registry
+Alias: iso-ir-101
+Alias: ISO_8859-2
+Alias: ISO-8859-2 (preferred MIME name)
+Alias: latin2
+Alias: l2
+Alias: csISOLatin2
+
+Name: ISO_8859-3:1988 [RFC1345,KXS2]
+MIBenum: 6
+Source: ECMA registry
+Alias: iso-ir-109
+Alias: ISO_8859-3
+Alias: ISO-8859-3 (preferred MIME name)
+Alias: latin3
+Alias: l3
+Alias: csISOLatin3
+
+Name: ISO_8859-4:1988 [RFC1345,KXS2]
+MIBenum: 7
+Source: ECMA registry
+Alias: iso-ir-110
+Alias: ISO_8859-4
+Alias: ISO-8859-4 (preferred MIME name)
+Alias: latin4
+Alias: l4
+Alias: csISOLatin4
+
+Name: ISO_8859-5:1988 [RFC1345,KXS2]
+MIBenum: 8
+Source: ECMA registry
+Alias: iso-ir-144
+Alias: ISO_8859-5
+Alias: ISO-8859-5 (preferred MIME name)
+Alias: cyrillic
+Alias: csISOLatinCyrillic
+
+Name: ISO_8859-6:1987 [RFC1345,KXS2]
+MIBenum: 9
+Source: ECMA registry
+Alias: iso-ir-127
+Alias: ISO_8859-6
+Alias: ISO-8859-6 (preferred MIME name)
+Alias: ECMA-114
+Alias: ASMO-708
+Alias: arabic
+Alias: csISOLatinArabic
+
+Name: ISO_8859-7:1987 [RFC1947,RFC1345,KXS2]
+MIBenum: 10
+Source: ECMA registry
+Alias: iso-ir-126
+Alias: ISO_8859-7
+Alias: ISO-8859-7 (preferred MIME name)
+Alias: ELOT_928
+Alias: ECMA-118
+Alias: greek
+Alias: greek8
+Alias: csISOLatinGreek
+
+Name: ISO_8859-8:1988 [RFC1345,KXS2]
+MIBenum: 11
+Source: ECMA registry
+Alias: iso-ir-138
+Alias: ISO_8859-8
+Alias: ISO-8859-8 (preferred MIME name)
+Alias: hebrew
+Alias: csISOLatinHebrew
+
+Name: ISO_8859-9:1989 [RFC1345,KXS2]
+MIBenum: 12
+Source: ECMA registry
+Alias: iso-ir-148
+Alias: ISO_8859-9
+Alias: ISO-8859-9 (preferred MIME name)
+Alias: latin5
+Alias: l5
+Alias: csISOLatin5
+
+Name: ISO-8859-10 (preferred MIME name) [RFC1345,KXS2]
+MIBenum: 13
+Source: ECMA registry
+Alias: iso-ir-157
+Alias: l6
+Alias: ISO_8859-10:1992
+Alias: csISOLatin6
+Alias: latin6
+
+Name: ISO_6937-2-add [RFC1345,KXS2]
+MIBenum: 14
+Source: ECMA registry and ISO 6937-2:1983
+Alias: iso-ir-142
+Alias: csISOTextComm
+
+Name: JIS_X0201 [RFC1345,KXS2]
+MIBenum: 15
+Source: JIS X 0201-1976. One byte only, this is equivalent to
+ JIS/Roman (similar to ASCII) plus eight-bit half-width
+ Katakana
+Alias: X0201
+Alias: csHalfWidthKatakana
+
+Name: JIS_Encoding
+MIBenum: 16
+Source: JIS X 0202-1991. Uses ISO 2022 escape sequences to
+ shift code sets as documented in JIS X 0202-1991.
+Alias: csJISEncoding
+
+Name: Shift_JIS (preferred MIME name)
+MIBenum: 17
+Source: This charset is an extension of csHalfWidthKatakana by
+ adding graphic characters in JIS X 0208. The CCS's are
+ JIS X0201:1997 and JIS X0208:1997. The
+ complete definition is shown in Appendix 1 of JIS
+ X0208:1997.
+ This charset can be used for the top-level media type "text".
+Alias: MS_Kanji
+Alias: csShiftJIS
+
+Name: Extended_UNIX_Code_Packed_Format_for_Japanese
+MIBenum: 18
+Source: Standardized by OSF, UNIX International, and UNIX Systems
+ Laboratories Pacific. Uses ISO 2022 rules to select
+ code set 0: US-ASCII (a single 7-bit byte set)
+ code set 1: JIS X0208-1990 (a double 8-bit byte set)
+ restricted to A0-FF in both bytes
+ code set 2: Half Width Katakana (a single 7-bit byte set)
+ requiring SS2 as the character prefix
+ code set 3: JIS X0212-1990 (a double 7-bit byte set)
+ restricted to A0-FF in both bytes
+ requiring SS3 as the character prefix
+Alias: csEUCPkdFmtJapanese
+Alias: EUC-JP (preferred MIME name)
+
+Name: Extended_UNIX_Code_Fixed_Width_for_Japanese
+MIBenum: 19
+Source: Used in Japan. Each character is 2 octets.
+ code set 0: US-ASCII (a single 7-bit byte set)
+ 1st byte = 00
+ 2nd byte = 20-7E
+ code set 1: JIS X0208-1990 (a double 7-bit byte set)
+ restricted to A0-FF in both bytes
+ code set 2: Half Width Katakana (a single 7-bit byte set)
+ 1st byte = 00
+ 2nd byte = A0-FF
+ code set 3: JIS X0212-1990 (a double 7-bit byte set)
+ restricted to A0-FF in
+ the first byte
+ and 21-7E in the second byte
+Alias: csEUCFixWidJapanese
+
+Name: BS_4730 [RFC1345,KXS2]
+MIBenum: 20
+Source: ECMA registry
+Alias: iso-ir-4
+Alias: ISO646-GB
+Alias: gb
+Alias: uk
+Alias: csISO4UnitedKingdom
+
+Name: SEN_850200_C [RFC1345,KXS2]
+MIBenum: 21
+Source: ECMA registry
+Alias: iso-ir-11
+Alias: ISO646-SE2
+Alias: se2
+Alias: csISO11SwedishForNames
+
+Name: IT [RFC1345,KXS2]
+MIBenum: 22
+Source: ECMA registry
+Alias: iso-ir-15
+Alias: ISO646-IT
+Alias: csISO15Italian
+
+Name: ES [RFC1345,KXS2]
+MIBenum: 23
+Source: ECMA registry
+Alias: iso-ir-17
+Alias: ISO646-ES
+Alias: csISO17Spanish
+
+Name: DIN_66003 [RFC1345,KXS2]
+MIBenum: 24
+Source: ECMA registry
+Alias: iso-ir-21
+Alias: de
+Alias: ISO646-DE
+Alias: csISO21German
+
+Name: NS_4551-1 [RFC1345,KXS2]
+MIBenum: 25
+Source: ECMA registry
+Alias: iso-ir-60
+Alias: ISO646-NO
+Alias: no
+Alias: csISO60DanishNorwegian
+Alias: csISO60Norwegian1
+
+Name: NF_Z_62-010 [RFC1345,KXS2]
+MIBenum: 26
+Source: ECMA registry
+Alias: iso-ir-69
+Alias: ISO646-FR
+Alias: fr
+Alias: csISO69French
+
+Name: ISO-10646-UTF-1
+MIBenum: 27
+Source: Universal Transfer Format (1), this is the multibyte
+ encoding, that subsets ASCII-7. It does not have byte
+ ordering issues.
+Alias: csISO10646UTF1
+
+Name: ISO_646.basic:1983 [RFC1345,KXS2]
+MIBenum: 28
+Source: ECMA registry
+Alias: ref
+Alias: csISO646basic1983
+
+Name: INVARIANT [RFC1345,KXS2]
+MIBenum: 29
+Alias: csINVARIANT
+
+Name: ISO_646.irv:1983 [RFC1345,KXS2]
+MIBenum: 30
+Source: ECMA registry
+Alias: iso-ir-2
+Alias: irv
+Alias: csISO2IntlRefVersion
+
+Name: NATS-SEFI [RFC1345,KXS2]
+MIBenum: 31
+Source: ECMA registry
+Alias: iso-ir-8-1
+Alias: csNATSSEFI
+
+Name: NATS-SEFI-ADD [RFC1345,KXS2]
+MIBenum: 32
+Source: ECMA registry
+Alias: iso-ir-8-2
+Alias: csNATSSEFIADD
+
+Name: NATS-DANO [RFC1345,KXS2]
+MIBenum: 33
+Source: ECMA registry
+Alias: iso-ir-9-1
+Alias: csNATSDANO
+
+Name: NATS-DANO-ADD [RFC1345,KXS2]
+MIBenum: 34
+Source: ECMA registry
+Alias: iso-ir-9-2
+Alias: csNATSDANOADD
+
+Name: SEN_850200_B [RFC1345,KXS2]
+MIBenum: 35
+Source: ECMA registry
+Alias: iso-ir-10
+Alias: FI
+Alias: ISO646-FI
+Alias: ISO646-SE
+Alias: se
+Alias: csISO10Swedish
+
+Name: KS_C_5601-1987 [RFC1345,KXS2]
+MIBenum: 36
+Source: ECMA registry
+Alias: iso-ir-149
+Alias: KS_C_5601-1989
+Alias: KSC_5601
+Alias: korean
+Alias: csKSC56011987
+
+Name: ISO-2022-KR (preferred MIME name) [RFC1557,Choi]
+MIBenum: 37
+Source: RFC-1557 (see also KS_C_5601-1987)
+Alias: csISO2022KR
+
+Name: EUC-KR (preferred MIME name) [RFC1557,Choi]
+MIBenum: 38
+Source: RFC-1557 (see also KS_C_5861-1992)
+Alias: csEUCKR
+
+Name: ISO-2022-JP (preferred MIME name) [RFC1468,Murai]
+MIBenum: 39
+Source: RFC-1468 (see also RFC-2237)
+Alias: csISO2022JP
+
+Name: ISO-2022-JP-2 (preferred MIME name) [RFC1554,Ohta]
+MIBenum: 40
+Source: RFC-1554
+Alias: csISO2022JP2
+
+Name: JIS_C6220-1969-jp [RFC1345,KXS2]
+MIBenum: 41
+Source: ECMA registry
+Alias: JIS_C6220-1969
+Alias: iso-ir-13
+Alias: katakana
+Alias: x0201-7
+Alias: csISO13JISC6220jp
+
+Name: JIS_C6220-1969-ro [RFC1345,KXS2]
+MIBenum: 42
+Source: ECMA registry
+Alias: iso-ir-14
+Alias: jp
+Alias: ISO646-JP
+Alias: csISO14JISC6220ro
+
+Name: PT [RFC1345,KXS2]
+MIBenum: 43
+Source: ECMA registry
+Alias: iso-ir-16
+Alias: ISO646-PT
+Alias: csISO16Portuguese
+
+Name: greek7-old [RFC1345,KXS2]
+MIBenum: 44
+Source: ECMA registry
+Alias: iso-ir-18
+Alias: csISO18Greek7Old
+
+Name: latin-greek [RFC1345,KXS2]
+MIBenum: 45
+Source: ECMA registry
+Alias: iso-ir-19
+Alias: csISO19LatinGreek
+
+Name: NF_Z_62-010_(1973) [RFC1345,KXS2]
+MIBenum: 46
+Source: ECMA registry
+Alias: iso-ir-25
+Alias: ISO646-FR1
+Alias: csISO25French
+
+Name: Latin-greek-1 [RFC1345,KXS2]
+MIBenum: 47
+Source: ECMA registry
+Alias: iso-ir-27
+Alias: csISO27LatinGreek1
+
+Name: ISO_5427 [RFC1345,KXS2]
+MIBenum: 48
+Source: ECMA registry
+Alias: iso-ir-37
+Alias: csISO5427Cyrillic
+
+Name: JIS_C6226-1978 [RFC1345,KXS2]
+MIBenum: 49
+Source: ECMA registry
+Alias: iso-ir-42
+Alias: csISO42JISC62261978
+
+Name: BS_viewdata [RFC1345,KXS2]
+MIBenum: 50
+Source: ECMA registry
+Alias: iso-ir-47
+Alias: csISO47BSViewdata
+
+Name: INIS [RFC1345,KXS2]
+MIBenum: 51
+Source: ECMA registry
+Alias: iso-ir-49
+Alias: csISO49INIS
+
+Name: INIS-8 [RFC1345,KXS2]
+MIBenum: 52
+Source: ECMA registry
+Alias: iso-ir-50
+Alias: csISO50INIS8
+
+Name: INIS-cyrillic [RFC1345,KXS2]
+MIBenum: 53
+Source: ECMA registry
+Alias: iso-ir-51
+Alias: csISO51INISCyrillic
+
+Name: ISO_5427:1981 [RFC1345,KXS2]
+MIBenum: 54
+Source: ECMA registry
+Alias: iso-ir-54
+Alias: ISO5427Cyrillic1981
+
+Name: ISO_5428:1980 [RFC1345,KXS2]
+MIBenum: 55
+Source: ECMA registry
+Alias: iso-ir-55
+Alias: csISO5428Greek
+
+Name: GB_1988-80 [RFC1345,KXS2]
+MIBenum: 56
+Source: ECMA registry
+Alias: iso-ir-57
+Alias: cn
+Alias: ISO646-CN
+Alias: csISO57GB1988
+
+Name: GB_2312-80 [RFC1345,KXS2]
+MIBenum: 57
+Source: ECMA registry
+Alias: iso-ir-58
+Alias: chinese
+Alias: csISO58GB231280
+
+Name: NS_4551-2 [RFC1345,KXS2]
+MIBenum: 58
+Source: ECMA registry
+Alias: ISO646-NO2
+Alias: iso-ir-61
+Alias: no2
+Alias: csISO61Norwegian2
+
+Name: videotex-suppl [RFC1345,KXS2]
+MIBenum: 59
+Source: ECMA registry
+Alias: iso-ir-70
+Alias: csISO70VideotexSupp1
+
+Name: PT2 [RFC1345,KXS2]
+MIBenum: 60
+Source: ECMA registry
+Alias: iso-ir-84
+Alias: ISO646-PT2
+Alias: csISO84Portuguese2
+
+Name: ES2 [RFC1345,KXS2]
+MIBenum: 61
+Source: ECMA registry
+Alias: iso-ir-85
+Alias: ISO646-ES2
+Alias: csISO85Spanish2
+
+Name: MSZ_7795.3 [RFC1345,KXS2]
+MIBenum: 62
+Source: ECMA registry
+Alias: iso-ir-86
+Alias: ISO646-HU
+Alias: hu
+Alias: csISO86Hungarian
+
+Name: JIS_C6226-1983 [RFC1345,KXS2]
+MIBenum: 63
+Source: ECMA registry
+Alias: iso-ir-87
+Alias: x0208
+Alias: JIS_X0208-1983
+Alias: csISO87JISX0208
+
+Name: greek7 [RFC1345,KXS2]
+MIBenum: 64
+Source: ECMA registry
+Alias: iso-ir-88
+Alias: csISO88Greek7
+
+Name: ASMO_449 [RFC1345,KXS2]
+MIBenum: 65
+Source: ECMA registry
+Alias: ISO_9036
+Alias: arabic7
+Alias: iso-ir-89
+Alias: csISO89ASMO449
+
+Name: iso-ir-90 [RFC1345,KXS2]
+MIBenum: 66
+Source: ECMA registry
+Alias: csISO90
+
+Name: JIS_C6229-1984-a [RFC1345,KXS2]
+MIBenum: 67
+Source: ECMA registry
+Alias: iso-ir-91
+Alias: jp-ocr-a
+Alias: csISO91JISC62291984a
+
+Name: JIS_C6229-1984-b [RFC1345,KXS2]
+MIBenum: 68
+Source: ECMA registry
+Alias: iso-ir-92
+Alias: ISO646-JP-OCR-B
+Alias: jp-ocr-b
+Alias: csISO92JISC62991984b
+
+Name: JIS_C6229-1984-b-add [RFC1345,KXS2]
+MIBenum: 69
+Source: ECMA registry
+Alias: iso-ir-93
+Alias: jp-ocr-b-add
+Alias: csISO93JIS62291984badd
+
+Name: JIS_C6229-1984-hand [RFC1345,KXS2]
+MIBenum: 70
+Source: ECMA registry
+Alias: iso-ir-94
+Alias: jp-ocr-hand
+Alias: csISO94JIS62291984hand
+
+Name: JIS_C6229-1984-hand-add [RFC1345,KXS2]
+MIBenum: 71
+Source: ECMA registry
+Alias: iso-ir-95
+Alias: jp-ocr-hand-add
+Alias: csISO95JIS62291984handadd
+
+Name: JIS_C6229-1984-kana [RFC1345,KXS2]
+MIBenum: 72
+Source: ECMA registry
+Alias: iso-ir-96
+Alias: csISO96JISC62291984kana
+
+Name: ISO_2033-1983 [RFC1345,KXS2]
+MIBenum: 73
+Source: ECMA registry
+Alias: iso-ir-98
+Alias: e13b
+Alias: csISO2033
+
+Name: ANSI_X3.110-1983 [RFC1345,KXS2]
+MIBenum: 74
+Source: ECMA registry
+Alias: iso-ir-99
+Alias: CSA_T500-1983
+Alias: NAPLPS
+Alias: csISO99NAPLPS
+
+Name: T.61-7bit [RFC1345,KXS2]
+MIBenum: 75
+Source: ECMA registry
+Alias: iso-ir-102
+Alias: csISO102T617bit
+
+Name: T.61-8bit [RFC1345,KXS2]
+MIBenum: 76
+Alias: T.61
+Source: ECMA registry
+Alias: iso-ir-103
+Alias: csISO103T618bit
+
+Name: ECMA-cyrillic
+MIBenum: 77
+Source: ISO registry (formerly ECMA registry)
+ http://www.itscj.ipsj.jp/ISO-IR/111.pdf
+Alias: iso-ir-111
+Alias: KOI8-E
+Alias: csISO111ECMACyrillic
+
+Name: CSA_Z243.4-1985-1 [RFC1345,KXS2]
+MIBenum: 78
+Source: ECMA registry
+Alias: iso-ir-121
+Alias: ISO646-CA
+Alias: csa7-1
+Alias: ca
+Alias: csISO121Canadian1
+
+Name: CSA_Z243.4-1985-2 [RFC1345,KXS2]
+MIBenum: 79
+Source: ECMA registry
+Alias: iso-ir-122
+Alias: ISO646-CA2
+Alias: csa7-2
+Alias: csISO122Canadian2
+
+Name: CSA_Z243.4-1985-gr [RFC1345,KXS2]
+MIBenum: 80
+Source: ECMA registry
+Alias: iso-ir-123
+Alias: csISO123CSAZ24341985gr
+
+Name: ISO_8859-6-E [RFC1556,IANA]
+MIBenum: 81
+Source: RFC1556
+Alias: csISO88596E
+Alias: ISO-8859-6-E (preferred MIME name)
+
+Name: ISO_8859-6-I [RFC1556,IANA]
+MIBenum: 82
+Source: RFC1556
+Alias: csISO88596I
+Alias: ISO-8859-6-I (preferred MIME name)
+
+Name: T.101-G2 [RFC1345,KXS2]
+MIBenum: 83
+Source: ECMA registry
+Alias: iso-ir-128
+Alias: csISO128T101G2
+
+Name: ISO_8859-8-E [RFC1556,Nussbacher]
+MIBenum: 84
+Source: RFC1556
+Alias: csISO88598E
+Alias: ISO-8859-8-E (preferred MIME name)
+
+Name: ISO_8859-8-I [RFC1556,Nussbacher]
+MIBenum: 85
+Source: RFC1556
+Alias: csISO88598I
+Alias: ISO-8859-8-I (preferred MIME name)
+
+Name: CSN_369103 [RFC1345,KXS2]
+MIBenum: 86
+Source: ECMA registry
+Alias: iso-ir-139
+Alias: csISO139CSN369103
+
+Name: JUS_I.B1.002 [RFC1345,KXS2]
+MIBenum: 87
+Source: ECMA registry
+Alias: iso-ir-141
+Alias: ISO646-YU
+Alias: js
+Alias: yu
+Alias: csISO141JUSIB1002
+
+Name: IEC_P27-1 [RFC1345,KXS2]
+MIBenum: 88
+Source: ECMA registry
+Alias: iso-ir-143
+Alias: csISO143IECP271
+
+Name: JUS_I.B1.003-serb [RFC1345,KXS2]
+MIBenum: 89
+Source: ECMA registry
+Alias: iso-ir-146
+Alias: serbian
+Alias: csISO146Serbian
+
+Name: JUS_I.B1.003-mac [RFC1345,KXS2]
+MIBenum: 90
+Source: ECMA registry
+Alias: macedonian
+Alias: iso-ir-147
+Alias: csISO147Macedonian
+
+Name: greek-ccitt [RFC1345,KXS2]
+MIBenum: 91
+Source: ECMA registry
+Alias: iso-ir-150
+Alias: csISO150
+Alias: csISO150GreekCCITT
+
+Name: NC_NC00-10:81 [RFC1345,KXS2]
+MIBenum: 92
+Source: ECMA registry
+Alias: cuba
+Alias: iso-ir-151
+Alias: ISO646-CU
+Alias: csISO151Cuba
+
+Name: ISO_6937-2-25 [RFC1345,KXS2]
+MIBenum: 93
+Source: ECMA registry
+Alias: iso-ir-152
+Alias: csISO6937Add
+
+Name: GOST_19768-74 [RFC1345,KXS2]
+MIBenum: 94
+Source: ECMA registry
+Alias: ST_SEV_358-88
+Alias: iso-ir-153
+Alias: csISO153GOST1976874
+
+Name: ISO_8859-supp [RFC1345,KXS2]
+MIBenum: 95
+Source: ECMA registry
+Alias: iso-ir-154
+Alias: latin1-2-5
+Alias: csISO8859Supp
+
+Name: ISO_10367-box [RFC1345,KXS2]
+MIBenum: 96
+Source: ECMA registry
+Alias: iso-ir-155
+Alias: csISO10367Box
+
+Name: latin-lap [RFC1345,KXS2]
+MIBenum: 97
+Source: ECMA registry
+Alias: lap
+Alias: iso-ir-158
+Alias: csISO158Lap
+
+Name: JIS_X0212-1990 [RFC1345,KXS2]
+MIBenum: 98
+Source: ECMA registry
+Alias: x0212
+Alias: iso-ir-159
+Alias: csISO159JISX02121990
+
+Name: DS_2089 [RFC1345,KXS2]
+MIBenum: 99
+Source: Danish Standard, DS 2089, February 1974
+Alias: DS2089
+Alias: ISO646-DK
+Alias: dk
+Alias: csISO646Danish
+
+Name: us-dk [RFC1345,KXS2]
+MIBenum: 100
+Alias: csUSDK
+
+Name: dk-us [RFC1345,KXS2]
+MIBenum: 101
+Alias: csDKUS
+
+Name: KSC5636 [RFC1345,KXS2]
+MIBenum: 102
+Alias: ISO646-KR
+Alias: csKSC5636
+
+Name: UNICODE-1-1-UTF-7 [RFC1642]
+MIBenum: 103
+Source: RFC 1642
+Alias: csUnicode11UTF7
+
+Name: ISO-2022-CN [RFC1922]
+MIBenum: 104
+Source: RFC-1922
+
+Name: ISO-2022-CN-EXT [RFC1922]
+MIBenum: 105
+Source: RFC-1922
+
+Name: UTF-8 [RFC3629]
+MIBenum: 106
+Source: RFC 3629
+Alias: None
+
+Name: ISO-8859-13
+MIBenum: 109
+Source: ISO See (http://www.iana.org/assignments/charset-reg/ISO-8859-13)[Tumasonis]
+Alias: None
+
+Name: ISO-8859-14
+MIBenum: 110
+Source: ISO See (http://www.iana.org/assignments/charset-reg/ISO-8859-14) [Simonsen]
+Alias: iso-ir-199
+Alias: ISO_8859-14:1998
+Alias: ISO_8859-14
+Alias: latin8
+Alias: iso-celtic
+Alias: l8
+
+Name: ISO-8859-15
+MIBenum: 111
+Source: ISO
+ Please see: <http://www.iana.org/assignments/charset-reg/ISO-8859-15>
+Alias: ISO_8859-15
+Alias: Latin-9
+
+Name: ISO-8859-16
+MIBenum: 112
+Source: ISO
+Alias: iso-ir-226
+Alias: ISO_8859-16:2001
+Alias: ISO_8859-16
+Alias: latin10
+Alias: l10
+
+Name: GBK
+MIBenum: 113
+Source: Chinese IT Standardization Technical Committee
+ Please see: <http://www.iana.org/assignments/charset-reg/GBK>
+Alias: CP936
+Alias: MS936
+Alias: windows-936
+
+Name: GB18030
+MIBenum: 114
+Source: Chinese IT Standardization Technical Committee
+ Please see: <http://www.iana.org/assignments/charset-reg/GB18030>
+Alias: None
+
+Name: OSD_EBCDIC_DF04_15
+MIBenum: 115
+Source: Fujitsu-Siemens standard mainframe EBCDIC encoding
+ Please see: <http://www.iana.org/assignments/charset-reg/OSD-EBCDIC-DF04-15>
+Alias: None
+
+Name: OSD_EBCDIC_DF03_IRV
+MIBenum: 116
+Source: Fujitsu-Siemens standard mainframe EBCDIC encoding
+ Please see: <http://www.iana.org/assignments/charset-reg/OSD-EBCDIC-DF03-IRV>
+Alias: None
+
+Name: OSD_EBCDIC_DF04_1
+MIBenum: 117
+Source: Fujitsu-Siemens standard mainframe EBCDIC encoding
+ Please see: <http://www.iana.org/assignments/charset-reg/OSD-EBCDIC-DF04-1>
+Alias: None
+
+Name: ISO-11548-1
+MIBenum: 118
+Source: See <http://www.iana.org/assignments/charset-reg/ISO-11548-1> [Thibault]
+Alias: ISO_11548-1
+Alias: ISO_TR_11548-1
+Alias: csISO115481
+
+Name: KZ-1048
+MIBenum: 119
+Source: See <http://www.iana.org/assignments/charset-reg/KZ-1048> [Veremeev, Kikkarin]
+Alias: STRK1048-2002
+Alias: RK1048
+Alias: csKZ1048
+
+Name: ISO-10646-UCS-2
+MIBenum: 1000
+Source: the 2-octet Basic Multilingual Plane, aka Unicode
+ this needs to specify network byte order: the standard
+ does not specify (it is a 16-bit integer space)
+Alias: csUnicode
+
+Name: ISO-10646-UCS-4
+MIBenum: 1001
+Source: the full code space. (same comment about byte order,
+ these are 31-bit numbers.
+Alias: csUCS4
+
+Name: ISO-10646-UCS-Basic
+MIBenum: 1002
+Source: ASCII subset of Unicode. Basic Latin = collection 1
+ See ISO 10646, Appendix A
+Alias: csUnicodeASCII
+
+Name: ISO-10646-Unicode-Latin1
+MIBenum: 1003
+Source: ISO Latin-1 subset of Unicode. Basic Latin and Latin-1
+ Supplement = collections 1 and 2. See ISO 10646,
+ Appendix A. See RFC 1815.
+Alias: csUnicodeLatin1
+Alias: ISO-10646
+
+Name: ISO-10646-J-1
+Source: ISO 10646 Japanese, see RFC 1815.
+
+Name: ISO-Unicode-IBM-1261
+MIBenum: 1005
+Source: IBM Latin-2, -3, -5, Extended Presentation Set, GCSGID: 1261
+Alias: csUnicodeIBM1261
+
+Name: ISO-Unicode-IBM-1268
+MIBenum: 1006
+Source: IBM Latin-4 Extended Presentation Set, GCSGID: 1268
+Alias: csUnicodeIBM1268
+
+Name: ISO-Unicode-IBM-1276
+MIBenum: 1007
+Source: IBM Cyrillic Greek Extended Presentation Set, GCSGID: 1276
+Alias: csUnicodeIBM1276
+
+Name: ISO-Unicode-IBM-1264
+MIBenum: 1008
+Source: IBM Arabic Presentation Set, GCSGID: 1264
+Alias: csUnicodeIBM1264
+
+Name: ISO-Unicode-IBM-1265
+MIBenum: 1009
+Source: IBM Hebrew Presentation Set, GCSGID: 1265
+Alias: csUnicodeIBM1265
+
+Name: UNICODE-1-1 [RFC1641]
+MIBenum: 1010
+Source: RFC 1641
+Alias: csUnicode11
+
+Name: SCSU
+MIBenum: 1011
+Source: SCSU See (http://www.iana.org/assignments/charset-reg/SCSU) [Scherer]
+Alias: None
+
+Name: UTF-7 [RFC2152]
+MIBenum: 1012
+Source: RFC 2152
+Alias: None
+
+Name: UTF-16BE [RFC2781]
+MIBenum: 1013
+Source: RFC 2781
+Alias: None
+
+Name: UTF-16LE [RFC2781]
+MIBenum: 1014
+Source: RFC 2781
+Alias: None
+
+Name: UTF-16 [RFC2781]
+MIBenum: 1015
+Source: RFC 2781
+Alias: None
+
+Name: CESU-8 [Phipps]
+MIBenum: 1016
+Source: <http://www.unicode.org/unicode/reports/tr26>
+Alias: csCESU-8
+
+Name: UTF-32 [Davis]
+MIBenum: 1017
+Source: <http://www.unicode.org/unicode/reports/tr19/>
+Alias: None
+
+Name: UTF-32BE [Davis]
+MIBenum: 1018
+Source: <http://www.unicode.org/unicode/reports/tr19/>
+Alias: None
+
+Name: UTF-32LE [Davis]
+MIBenum: 1019
+Source: <http://www.unicode.org/unicode/reports/tr19/>
+Alias: None
+
+Name: BOCU-1 [Scherer]
+MIBenum: 1020
+Source: http://www.unicode.org/notes/tn6/
+Alias: csBOCU-1
+
+Name: ISO-8859-1-Windows-3.0-Latin-1 [HP-PCL5]
+MIBenum: 2000
+Source: Extended ISO 8859-1 Latin-1 for Windows 3.0.
+ PCL Symbol Set id: 9U
+Alias: csWindows30Latin1
+
+Name: ISO-8859-1-Windows-3.1-Latin-1 [HP-PCL5]
+MIBenum: 2001
+Source: Extended ISO 8859-1 Latin-1 for Windows 3.1.
+ PCL Symbol Set id: 19U
+Alias: csWindows31Latin1
+
+Name: ISO-8859-2-Windows-Latin-2 [HP-PCL5]
+MIBenum: 2002
+Source: Extended ISO 8859-2. Latin-2 for Windows 3.1.
+ PCL Symbol Set id: 9E
+Alias: csWindows31Latin2
+
+Name: ISO-8859-9-Windows-Latin-5 [HP-PCL5]
+MIBenum: 2003
+Source: Extended ISO 8859-9. Latin-5 for Windows 3.1
+ PCL Symbol Set id: 5T
+Alias: csWindows31Latin5
+
+Name: hp-roman8 [HP-PCL5,RFC1345,KXS2]
+MIBenum: 2004
+Source: LaserJet IIP Printer User's Manual,
+ HP part no 33471-90901, Hewlet-Packard, June 1989.
+Alias: roman8
+Alias: r8
+Alias: csHPRoman8
+
+Name: Adobe-Standard-Encoding [Adobe]
+MIBenum: 2005
+Source: PostScript Language Reference Manual
+ PCL Symbol Set id: 10J
+Alias: csAdobeStandardEncoding
+
+Name: Ventura-US [HP-PCL5]
+MIBenum: 2006
+Source: Ventura US. ASCII plus characters typically used in
+ publishing, like pilcrow, copyright, registered, trade mark,
+ section, dagger, and double dagger in the range A0 (hex)
+ to FF (hex).
+ PCL Symbol Set id: 14J
+Alias: csVenturaUS
+
+Name: Ventura-International [HP-PCL5]
+MIBenum: 2007
+Source: Ventura International. ASCII plus coded characters similar
+ to Roman8.
+ PCL Symbol Set id: 13J
+Alias: csVenturaInternational
+
+Name: DEC-MCS [RFC1345,KXS2]
+MIBenum: 2008
+Source: VAX/VMS User's Manual,
+ Order Number: AI-Y517A-TE, April 1986.
+Alias: dec
+Alias: csDECMCS
+
+Name: IBM850 [RFC1345,KXS2]
+MIBenum: 2009
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp850
+Alias: 850
+Alias: csPC850Multilingual
+
+Name: PC8-Danish-Norwegian [HP-PCL5]
+MIBenum: 2012
+Source: PC Danish Norwegian
+ 8-bit PC set for Danish Norwegian
+ PCL Symbol Set id: 11U
+Alias: csPC8DanishNorwegian
+
+Name: IBM862 [RFC1345,KXS2]
+MIBenum: 2013
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp862
+Alias: 862
+Alias: csPC862LatinHebrew
+
+Name: PC8-Turkish [HP-PCL5]
+MIBenum: 2014
+Source: PC Latin Turkish. PCL Symbol Set id: 9T
+Alias: csPC8Turkish
+
+Name: IBM-Symbols [IBM-CIDT]
+MIBenum: 2015
+Source: Presentation Set, CPGID: 259
+Alias: csIBMSymbols
+
+Name: IBM-Thai [IBM-CIDT]
+MIBenum: 2016
+Source: Presentation Set, CPGID: 838
+Alias: csIBMThai
+
+Name: HP-Legal [HP-PCL5]
+MIBenum: 2017
+Source: PCL 5 Comparison Guide, Hewlett-Packard,
+ HP part number 5961-0510, October 1992
+ PCL Symbol Set id: 1U
+Alias: csHPLegal
+
+Name: HP-Pi-font [HP-PCL5]
+MIBenum: 2018
+Source: PCL 5 Comparison Guide, Hewlett-Packard,
+ HP part number 5961-0510, October 1992
+ PCL Symbol Set id: 15U
+Alias: csHPPiFont
+
+Name: HP-Math8 [HP-PCL5]
+MIBenum: 2019
+Source: PCL 5 Comparison Guide, Hewlett-Packard,
+ HP part number 5961-0510, October 1992
+ PCL Symbol Set id: 8M
+Alias: csHPMath8
+
+Name: Adobe-Symbol-Encoding [Adobe]
+MIBenum: 2020
+Source: PostScript Language Reference Manual
+ PCL Symbol Set id: 5M
+Alias: csHPPSMath
+
+Name: HP-DeskTop [HP-PCL5]
+MIBenum: 2021
+Source: PCL 5 Comparison Guide, Hewlett-Packard,
+ HP part number 5961-0510, October 1992
+ PCL Symbol Set id: 7J
+Alias: csHPDesktop
+
+Name: Ventura-Math [HP-PCL5]
+MIBenum: 2022
+Source: PCL 5 Comparison Guide, Hewlett-Packard,
+ HP part number 5961-0510, October 1992
+ PCL Symbol Set id: 6M
+Alias: csVenturaMath
+
+Name: Microsoft-Publishing [HP-PCL5]
+MIBenum: 2023
+Source: PCL 5 Comparison Guide, Hewlett-Packard,
+ HP part number 5961-0510, October 1992
+ PCL Symbol Set id: 6J
+Alias: csMicrosoftPublishing
+
+Name: Windows-31J
+MIBenum: 2024
+Source: Windows Japanese. A further extension of Shift_JIS
+ to include NEC special characters (Row 13), NEC
+ selection of IBM extensions (Rows 89 to 92), and IBM
+ extensions (Rows 115 to 119). The CCS's are
+ JIS X0201:1997, JIS X0208:1997, and these extensions.
+ This charset can be used for the top-level media type "text",
+ but it is of limited or specialized use (see RFC2278).
+ PCL Symbol Set id: 19K
+Alias: csWindows31J
+
+Name: GB2312 (preferred MIME name)
+MIBenum: 2025
+Source: Chinese for People's Republic of China (PRC) mixed one byte,
+ two byte set:
+ 20-7E = one byte ASCII
+ A1-FE = two byte PRC Kanji
+ See GB 2312-80
+ PCL Symbol Set Id: 18C
+Alias: csGB2312
+
+Name: Big5 (preferred MIME name)
+MIBenum: 2026
+Source: Chinese for Taiwan Multi-byte set.
+ PCL Symbol Set Id: 18T
+Alias: csBig5
+
+Name: macintosh [RFC1345,KXS2]
+MIBenum: 2027
+Source: The Unicode Standard ver1.0, ISBN 0-201-56788-1, Oct 1991
+Alias: mac
+Alias: csMacintosh
+
+Name: IBM037 [RFC1345,KXS2]
+MIBenum: 2028
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp037
+Alias: ebcdic-cp-us
+Alias: ebcdic-cp-ca
+Alias: ebcdic-cp-wt
+Alias: ebcdic-cp-nl
+Alias: csIBM037
+
+Name: IBM038 [RFC1345,KXS2]
+MIBenum: 2029
+Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990
+Alias: EBCDIC-INT
+Alias: cp038
+Alias: csIBM038
+
+Name: IBM273 [RFC1345,KXS2]
+MIBenum: 2030
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP273
+Alias: csIBM273
+
+Name: IBM274 [RFC1345,KXS2]
+MIBenum: 2031
+Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990
+Alias: EBCDIC-BE
+Alias: CP274
+Alias: csIBM274
+
+Name: IBM275 [RFC1345,KXS2]
+MIBenum: 2032
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: EBCDIC-BR
+Alias: cp275
+Alias: csIBM275
+
+Name: IBM277 [RFC1345,KXS2]
+MIBenum: 2033
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: EBCDIC-CP-DK
+Alias: EBCDIC-CP-NO
+Alias: csIBM277
+
+Name: IBM278 [RFC1345,KXS2]
+MIBenum: 2034
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP278
+Alias: ebcdic-cp-fi
+Alias: ebcdic-cp-se
+Alias: csIBM278
+
+Name: IBM280 [RFC1345,KXS2]
+MIBenum: 2035
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP280
+Alias: ebcdic-cp-it
+Alias: csIBM280
+
+Name: IBM281 [RFC1345,KXS2]
+MIBenum: 2036
+Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990
+Alias: EBCDIC-JP-E
+Alias: cp281
+Alias: csIBM281
+
+Name: IBM284 [RFC1345,KXS2]
+MIBenum: 2037
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP284
+Alias: ebcdic-cp-es
+Alias: csIBM284
+
+Name: IBM285 [RFC1345,KXS2]
+MIBenum: 2038
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP285
+Alias: ebcdic-cp-gb
+Alias: csIBM285
+
+Name: IBM290 [RFC1345,KXS2]
+MIBenum: 2039
+Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990
+Alias: cp290
+Alias: EBCDIC-JP-kana
+Alias: csIBM290
+
+Name: IBM297 [RFC1345,KXS2]
+MIBenum: 2040
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp297
+Alias: ebcdic-cp-fr
+Alias: csIBM297
+
+Name: IBM420 [RFC1345,KXS2]
+MIBenum: 2041
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990,
+ IBM NLS RM p 11-11
+Alias: cp420
+Alias: ebcdic-cp-ar1
+Alias: csIBM420
+
+Name: IBM423 [RFC1345,KXS2]
+MIBenum: 2042
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp423
+Alias: ebcdic-cp-gr
+Alias: csIBM423
+
+Name: IBM424 [RFC1345,KXS2]
+MIBenum: 2043
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp424
+Alias: ebcdic-cp-he
+Alias: csIBM424
+
+Name: IBM437 [RFC1345,KXS2]
+MIBenum: 2011
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp437
+Alias: 437
+Alias: csPC8CodePage437
+
+Name: IBM500 [RFC1345,KXS2]
+MIBenum: 2044
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP500
+Alias: ebcdic-cp-be
+Alias: ebcdic-cp-ch
+Alias: csIBM500
+
+Name: IBM851 [RFC1345,KXS2]
+MIBenum: 2045
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp851
+Alias: 851
+Alias: csIBM851
+
+Name: IBM852 [RFC1345,KXS2]
+MIBenum: 2010
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp852
+Alias: 852
+Alias: csPCp852
+
+Name: IBM855 [RFC1345,KXS2]
+MIBenum: 2046
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp855
+Alias: 855
+Alias: csIBM855
+
+Name: IBM857 [RFC1345,KXS2]
+MIBenum: 2047
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp857
+Alias: 857
+Alias: csIBM857
+
+Name: IBM860 [RFC1345,KXS2]
+MIBenum: 2048
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp860
+Alias: 860
+Alias: csIBM860
+
+Name: IBM861 [RFC1345,KXS2]
+MIBenum: 2049
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp861
+Alias: 861
+Alias: cp-is
+Alias: csIBM861
+
+Name: IBM863 [RFC1345,KXS2]
+MIBenum: 2050
+Source: IBM Keyboard layouts and code pages, PN 07G4586 June 1991
+Alias: cp863
+Alias: 863
+Alias: csIBM863
+
+Name: IBM864 [RFC1345,KXS2]
+MIBenum: 2051
+Source: IBM Keyboard layouts and code pages, PN 07G4586 June 1991
+Alias: cp864
+Alias: csIBM864
+
+Name: IBM865 [RFC1345,KXS2]
+MIBenum: 2052
+Source: IBM DOS 3.3 Ref (Abridged), 94X9575 (Feb 1987)
+Alias: cp865
+Alias: 865
+Alias: csIBM865
+
+Name: IBM868 [RFC1345,KXS2]
+MIBenum: 2053
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP868
+Alias: cp-ar
+Alias: csIBM868
+
+Name: IBM869 [RFC1345,KXS2]
+MIBenum: 2054
+Source: IBM Keyboard layouts and code pages, PN 07G4586 June 1991
+Alias: cp869
+Alias: 869
+Alias: cp-gr
+Alias: csIBM869
+
+Name: IBM870 [RFC1345,KXS2]
+MIBenum: 2055
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP870
+Alias: ebcdic-cp-roece
+Alias: ebcdic-cp-yu
+Alias: csIBM870
+
+Name: IBM871 [RFC1345,KXS2]
+MIBenum: 2056
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP871
+Alias: ebcdic-cp-is
+Alias: csIBM871
+
+Name: IBM880 [RFC1345,KXS2]
+MIBenum: 2057
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp880
+Alias: EBCDIC-Cyrillic
+Alias: csIBM880
+
+Name: IBM891 [RFC1345,KXS2]
+MIBenum: 2058
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp891
+Alias: csIBM891
+
+Name: IBM903 [RFC1345,KXS2]
+MIBenum: 2059
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp903
+Alias: csIBM903
+
+Name: IBM904 [RFC1345,KXS2]
+MIBenum: 2060
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: cp904
+Alias: 904
+Alias: csIBBM904
+
+Name: IBM905 [RFC1345,KXS2]
+MIBenum: 2061
+Source: IBM 3174 Character Set Ref, GA27-3831-02, March 1990
+Alias: CP905
+Alias: ebcdic-cp-tr
+Alias: csIBM905
+
+Name: IBM918 [RFC1345,KXS2]
+MIBenum: 2062
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP918
+Alias: ebcdic-cp-ar2
+Alias: csIBM918
+
+Name: IBM1026 [RFC1345,KXS2]
+MIBenum: 2063
+Source: IBM NLS RM Vol2 SE09-8002-01, March 1990
+Alias: CP1026
+Alias: csIBM1026
+
+Name: EBCDIC-AT-DE [RFC1345,KXS2]
+MIBenum: 2064
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csIBMEBCDICATDE
+
+Name: EBCDIC-AT-DE-A [RFC1345,KXS2]
+MIBenum: 2065
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICATDEA
+
+Name: EBCDIC-CA-FR [RFC1345,KXS2]
+MIBenum: 2066
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICCAFR
+
+Name: EBCDIC-DK-NO [RFC1345,KXS2]
+MIBenum: 2067
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICDKNO
+
+Name: EBCDIC-DK-NO-A [RFC1345,KXS2]
+MIBenum: 2068
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICDKNOA
+
+Name: EBCDIC-FI-SE [RFC1345,KXS2]
+MIBenum: 2069
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICFISE
+
+Name: EBCDIC-FI-SE-A [RFC1345,KXS2]
+MIBenum: 2070
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICFISEA
+
+Name: EBCDIC-FR [RFC1345,KXS2]
+MIBenum: 2071
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICFR
+
+Name: EBCDIC-IT [RFC1345,KXS2]
+MIBenum: 2072
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICIT
+
+Name: EBCDIC-PT [RFC1345,KXS2]
+MIBenum: 2073
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICPT
+
+Name: EBCDIC-ES [RFC1345,KXS2]
+MIBenum: 2074
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICES
+
+Name: EBCDIC-ES-A [RFC1345,KXS2]
+MIBenum: 2075
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICESA
+
+Name: EBCDIC-ES-S [RFC1345,KXS2]
+MIBenum: 2076
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICESS
+
+Name: EBCDIC-UK [RFC1345,KXS2]
+MIBenum: 2077
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICUK
+
+Name: EBCDIC-US [RFC1345,KXS2]
+MIBenum: 2078
+Source: IBM 3270 Char Set Ref Ch 10, GA27-2837-9, April 1987
+Alias: csEBCDICUS
+
+Name: UNKNOWN-8BIT [RFC1428]
+MIBenum: 2079
+Alias: csUnknown8BiT
+
+Name: MNEMONIC [RFC1345,KXS2]
+MIBenum: 2080
+Source: RFC 1345, also known as "mnemonic+ascii+38"
+Alias: csMnemonic
+
+Name: MNEM [RFC1345,KXS2]
+MIBenum: 2081
+Source: RFC 1345, also known as "mnemonic+ascii+8200"
+Alias: csMnem
+
+Name: VISCII [RFC1456]
+MIBenum: 2082
+Source: RFC 1456
+Alias: csVISCII
+
+Name: VIQR [RFC1456]
+MIBenum: 2083
+Source: RFC 1456
+Alias: csVIQR
+
+Name: KOI8-R (preferred MIME name) [RFC1489]
+MIBenum: 2084
+Source: RFC 1489, based on GOST-19768-74, ISO-6937/8,
+ INIS-Cyrillic, ISO-5427.
+Alias: csKOI8R
+
+Name: HZ-GB-2312
+MIBenum: 2085
+Source: RFC 1842, RFC 1843 [RFC1842, RFC1843]
+
+Name: IBM866 [Pond]
+MIBenum: 2086
+Source: IBM NLDG Volume 2 (SE09-8002-03) August 1994
+Alias: cp866
+Alias: 866
+Alias: csIBM866
+
+Name: IBM775 [HP-PCL5]
+MIBenum: 2087
+Source: HP PCL 5 Comparison Guide (P/N 5021-0329) pp B-13, 1996
+Alias: cp775
+Alias: csPC775Baltic
+
+Name: KOI8-U [RFC2319]
+MIBenum: 2088
+Source: RFC 2319
+
+Name: IBM00858
+MIBenum: 2089
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM00858) [Mahdi]
+Alias: CCSID00858
+Alias: CP00858
+Alias: PC-Multilingual-850+euro
+
+Name: IBM00924
+MIBenum: 2090
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM00924) [Mahdi]
+Alias: CCSID00924
+Alias: CP00924
+Alias: ebcdic-Latin9--euro
+
+Name: IBM01140
+MIBenum: 2091
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01140) [Mahdi]
+Alias: CCSID01140
+Alias: CP01140
+Alias: ebcdic-us-37+euro
+
+Name: IBM01141
+MIBenum: 2092
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01141) [Mahdi]
+Alias: CCSID01141
+Alias: CP01141
+Alias: ebcdic-de-273+euro
+
+Name: IBM01142
+MIBenum: 2093
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01142) [Mahdi]
+Alias: CCSID01142
+Alias: CP01142
+Alias: ebcdic-dk-277+euro
+Alias: ebcdic-no-277+euro
+
+Name: IBM01143
+MIBenum: 2094
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01143) [Mahdi]
+Alias: CCSID01143
+Alias: CP01143
+Alias: ebcdic-fi-278+euro
+Alias: ebcdic-se-278+euro
+
+Name: IBM01144
+MIBenum: 2095
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01144) [Mahdi]
+Alias: CCSID01144
+Alias: CP01144
+Alias: ebcdic-it-280+euro
+
+Name: IBM01145
+MIBenum: 2096
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01145) [Mahdi]
+Alias: CCSID01145
+Alias: CP01145
+Alias: ebcdic-es-284+euro
+
+Name: IBM01146
+MIBenum: 2097
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01146) [Mahdi]
+Alias: CCSID01146
+Alias: CP01146
+Alias: ebcdic-gb-285+euro
+
+Name: IBM01147
+MIBenum: 2098
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01147) [Mahdi]
+Alias: CCSID01147
+Alias: CP01147
+Alias: ebcdic-fr-297+euro
+
+Name: IBM01148
+MIBenum: 2099
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01148) [Mahdi]
+Alias: CCSID01148
+Alias: CP01148
+Alias: ebcdic-international-500+euro
+
+Name: IBM01149
+MIBenum: 2100
+Source: IBM See (http://www.iana.org/assignments/charset-reg/IBM01149) [Mahdi]
+Alias: CCSID01149
+Alias: CP01149
+Alias: ebcdic-is-871+euro
+
+Name: Big5-HKSCS [Yick]
+MIBenum: 2101
+Source: See (http://www.iana.org/assignments/charset-reg/Big5-HKSCS)
+Alias: None
+
+Name: IBM1047 [Robrigado]
+MIBenum: 2102
+Source: IBM1047 (EBCDIC Latin 1/Open Systems)
+http://www-1.ibm.com/servers/eserver/iseries/software/globalization/pdf/cp01047z.pdf
+Alias: IBM-1047
+
+Name: PTCP154 [Uskov]
+MIBenum: 2103
+Source: See (http://www.iana.org/assignments/charset-reg/PTCP154)
+Alias: csPTCP154
+Alias: PT154
+Alias: CP154
+Alias: Cyrillic-Asian
+
+Name: Amiga-1251
+MIBenum: 2104
+Source: See (http://www.amiga.ultranet.ru/Amiga-1251.html)
+Alias: Ami1251
+Alias: Amiga1251
+Alias: Ami-1251
+(Aliases are provided for historical reasons and should not be used)
+ [Malyshev]
+
+Name: KOI7-switched
+MIBenum: 2105
+Source: See <http://www.iana.org/assignments/charset-reg/KOI7-switched>
+Aliases: None
+
+Name: BRF
+MIBenum: 2106
+Source: See <http://www.iana.org/assignments/charset-reg/BRF> [Thibault]
+Alias: csBRF
+
+Name: TSCII
+MIBenum: 2107
+Source: See <http://www.iana.org/assignments/charset-reg/TSCII> [Kalyanasundaram]
+Alias: csTSCII
+
+Name: windows-1250
+MIBenum: 2250
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1250) [Lazhintseva]
+Alias: None
+
+Name: windows-1251
+MIBenum: 2251
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1251) [Lazhintseva]
+Alias: None
+
+Name: windows-1252
+MIBenum: 2252
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1252) [Wendt]
+Alias: None
+
+Name: windows-1253
+MIBenum: 2253
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1253) [Lazhintseva]
+Alias: None
+
+Name: windows-1254
+MIBenum: 2254
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1254) [Lazhintseva]
+Alias: None
+
+Name: windows-1255
+MIBenum: 2255
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1255) [Lazhintseva]
+Alias: None
+
+Name: windows-1256
+MIBenum: 2256
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1256) [Lazhintseva]
+Alias: None
+
+Name: windows-1257
+MIBenum: 2257
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1257) [Lazhintseva]
+Alias: None
+
+Name: windows-1258
+MIBenum: 2258
+Source: Microsoft (http://www.iana.org/assignments/charset-reg/windows-1258) [Lazhintseva]
+Alias: None
+
+Name: TIS-620
+MIBenum: 2259
+Source: Thai Industrial Standards Institute (TISI) [Tantsetthi]
+
--- /dev/null
+USING: help.syntax help.markup ;
+IN: io.encodings.iana
+
+HELP: name>encoding
+{ $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } }
+{ "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ;
+
+HELP: encoding>name
+{ $values { "encoding" "an encoding descriptor" } { "name" "an encoding name" } }
+{ "Given an encoding descriptor, return the preferred IANA name." } ;
+
+{ name>encoding encoding>name } related-words
--- /dev/null
+USING: io.encodings.iana io.encodings.ascii tools.test ;
+
+[ ascii ] [ "US-ASCII" name>encoding ] unit-test
+[ ascii ] [ "ASCII" name>encoding ] unit-test
+[ "US-ASCII" ] [ ascii encoding>name ] unit-test
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel strings unicode.syntax.backend io.files assocs
+splitting sequences io namespaces sets
+io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ;
+IN: io.encodings.iana
+
+<PRIVATE
+VALUE: n>e-table
+
+: e>n-table H{
+ { ascii "US-ASCII" }
+ { utf8 "UTF-8" }
+ { utf16 "UTF-16" }
+ { utf16be "UTF-16BE" }
+ { utf16le "UTF-16LE" }
+ { latin1 "ISO-8859-1" }
+ { latin2 "ISO-8859-2" }
+ { latin3 "ISO-8859-3" }
+ { latin4 "ISO-8859-4" }
+ { latin/cyrillic "ISO-8859-5" }
+ { latin/arabic "ISO-8859-6" }
+ { latin/greek "ISO-8859-7" }
+ { latin/hebrew "ISO-8859-8" }
+ { latin5 "ISO-8859-9" }
+ { latin6 "ISO-8859-10" }
+} ;
+PRIVATE>
+
+: name>encoding ( name -- encoding )
+ n>e-table at ;
+
+: encoding>name ( encoding -- name )
+ e>n-table at ;
+
+<PRIVATE
+: parse-iana ( stream -- synonym-set )
+ lines { "" } split [
+ [ " " split ] map
+ [ first { "Name:" "Alias:" } member? ] filter
+ [ second ] map { "None" } diff
+ ] map ;
+
+: make-n>e ( stream -- n>e )
+ parse-iana [ [
+ dup [
+ e>n-table value-at
+ [ swap [ set ] with each ]
+ [ drop ] if*
+ ] with each
+ ] each ] H{ } make-assoc ;
+PRIVATE>
+
+"resource:extra/io/encodings/iana/character-sets"
+ascii <file-reader> make-n>e \ n>e-table set-value
--- /dev/null
+Tables for IANA encoding names
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations kernel io math
-calendar ;
+USING: help.markup help.syntax quotations kernel io io.files
+math calendar ;
IN: io.launcher
ARTICLE: "io.launcher.command" "Specifying a command"
"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" }
+ { "an " { $link appender } " wrapping a path name - output is sent to the end given file, as with " { $link <file-appender> } }
{ "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: +closed+
{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
-HELP: +inherit+
-{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
-
HELP: +stdout+
{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ;
+HELP: appender
+{ $class-description "An object representing a file to append to. Instances are created with " { $link <appender> } "." } ;
+
+HELP: <appender>
+{ $values { "path" "a pathname string" } { "appender" appender } }
+{ $description "Creates an object which may be stored in the " { $snippet "stdout" } " or " { $snippet "stderr" } " slot of a " { $link process } " instance." } ;
+
HELP: +prepend-environment+
{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
$nl
{ "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 of the given encoding." } ;
-HELP: with-process-stream
-{ $values
- { "desc" "a launch descriptor" }
- { "quot" quotation }
- { "status" "an exit code" } }
-{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
-
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
{ $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." } ;
{ $subsection try-process }
{ $subsection run-detached }
"Redirecting standard input and output to a pipe:"
-{ $subsection <process-stream> }
-{ $subsection with-process-stream } ;
+{ $subsection <process-reader> }
+{ $subsection <process-writer> }
+{ $subsection <process-stream> } ;
ARTICLE: "io.launcher.examples" "Launcher examples"
"Starting a command and waiting for it to finish:"
" <process>"
" swap >>stderr"
" \"report\" >>command"
- " ascii <process-stream> lines sort reverse [ print ] each"
+ " ascii <process-reader> lines sort reverse [ print ] each"
"] with-disposal"
} ;
USING: tools.test io.launcher ;
\ <process-stream> must-infer
+\ <process-reader> must-infer
+\ <process-writer> must-infer
! Copyright (C) 2008 Slava Pestov.
! 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 io.encodings io.streams.duplex
-io.nonblocking accessors concurrency.flags ;
+USING: system kernel namespaces strings hashtables sequences
+assocs combinators vocabs.loader init threads continuations
+math accessors concurrency.flags destructors
+io io.backend io.timeouts io.pipes io.pipes.private io.encodings
+io.streams.duplex io.nonblocking ;
IN: io.launcher
TUPLE: process < identity-tuple
killed ;
SYMBOL: +closed+
-SYMBOL: +inherit+
SYMBOL: +stdout+
+TUPLE: appender path ;
+
+: <appender> ( path -- appender ) appender boa ;
+
SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+
SYMBOL: +append-environment+
M: process timed-out kill-process ;
-HOOK: (process-stream) io-backend ( process -- handle in out )
+M: object run-pipeline-element
+ [ >process swap >>stdout swap >>stdin run-detached ]
+ [ drop [ [ close-handle ] when* ] bi@ ]
+ 3bi
+ wait-for-process ;
-: <process-stream*> ( desc encoding -- stream process )
- >r >process dup dup (process-stream) <reader&writer>
- r> <encoder-duplex> -roll
- process-started ;
+: <process-reader*> ( process encoding -- process stream )
+ [
+ >r (pipe) {
+ [ add-error-destructor ]
+ [
+ swap >process
+ [ swap out>> or ] change-stdout
+ run-detached
+ ]
+ [ out>> close-handle ]
+ [ in>> <reader> ]
+ } cleave r> <decoder>
+ ] with-destructors ;
+
+: <process-reader> ( desc encoding -- stream )
+ <process-reader*> nip ; inline
+
+: <process-writer*> ( process encoding -- process stream )
+ [
+ >r (pipe) {
+ [ add-error-destructor ]
+ [
+ swap >process
+ [ swap in>> or ] change-stdout
+ run-detached
+ ]
+ [ in>> close-handle ]
+ [ out>> <writer> ]
+ } cleave r> <encoder>
+ ] with-destructors ;
+
+: <process-writer> ( desc encoding -- stream )
+ <process-writer*> nip ; inline
+
+: <process-stream*> ( process encoding -- process stream )
+ [
+ >r (pipe) (pipe) {
+ [ [ add-error-destructor ] bi@ ]
+ [
+ rot >process
+ [ swap out>> or ] change-stdout
+ [ swap in>> or ] change-stdin
+ run-detached
+ ]
+ [ [ in>> close-handle ] [ out>> close-handle ] bi* ]
+ [ [ in>> <reader> ] [ out>> <writer> ] bi* ]
+ } 2cleave r> <encoder-duplex>
+ ] with-destructors ;
: <process-stream> ( desc encoding -- stream )
- <process-stream*> drop ; inline
-
-: with-process-stream ( desc quot -- status )
- swap <process-stream*> >r
- [ swap with-stream ] keep
- r> wait-for-process ; inline
+ <process-stream*> nip ; inline
: notify-exit ( process status -- )
>>status
GENERIC: underlying-handle ( stream -- handle )
-M: port underlying-handle port-handle ;
+M: port underlying-handle handle>> ;
M: duplex-stream underlying-handle
- dup duplex-stream-in underlying-handle
- swap duplex-stream-out underlying-handle tuck =
- [ "Invalid duplex stream" throw ] when ;
+ [ in>> underlying-handle ]
+ [ out>> underlying-handle ] bi
+ [ = [ "Invalid duplex stream" throw ] when ] keep ;
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io sequences io.buffers io.timeouts generic
-byte-vectors system io.streams.duplex io.encodings math.order
-io.backend continuations debugger classes byte-arrays namespaces
-splitting dlists assocs io.encodings.binary inspector accessors ;
+byte-vectors system io.encodings math.order io.backend
+continuations debugger classes byte-arrays namespaces splitting
+dlists assocs io.encodings.binary inspector accessors ;
IN: io.nonblocking
SYMBOL: default-buffer-size
--- /dev/null
+USING: help.markup help.syntax continuations io ;
+IN: io.pipes
+
+HELP: pipe
+{ $class-description "A low-level pipe. Instances are created by calling " { $link (pipe) } " and closed by calling " { $link dispose } "." } ;
+
+HELP: (pipe)
+{ $values { "pipe" pipe } }
+{ $description "Opens a new pipe. This is a low-level word; the " { $link <pipe> } " and " { $link run-pipeline } " words can be used in most cases instead." } ;
+
+HELP: <pipe>
+{ $values { "encoding" "an encoding specifier" } { "stream" "a bidirectional stream" } }
+{ $description "Opens a new pipe and wraps it in a stream. Data written from the stream can be read back from the same stream instance." }
+{ $notes "Pipe streams must be disposed by calling " { $link dispose } " or " { $link with-disposal } " to avoid resource leaks." } ;
+
+HELP: run-pipeline
+{ $values { "seq" "a sequence of pipeline components" } { "results" "a sequence of pipeline results" } }
+{ $description
+ "Creates a pipe between each pipeline component, with the output of each component becoming the input of the next."
+ $nl
+ "The first component reads input from " { $link input-stream } " and the last component writes output to " { $link output-stream } "."
+ $nl
+ "Each component runs in its own thread, and the word returns when all components finish executing. Each component outputs a result value."
+ $nl
+ "Pipeline components must be one of the following:"
+ { $list
+ { "A quotation. The quotation is called with both " { $link input-stream } " and " { $link output-stream } " rebound, except for the first and last pipeline components, and it must output a single value." }
+ { "A process launch descriptor. See " { $link "io.launcher.descriptors" } "." }
+ }
+}
+{ $examples
+ "Print the lines of a log file which contain the string ``error'', sort them and filter out duplicates, using Unix shell commands only:"
+ { $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" }
+} ;
+
+ARTICLE: "io.pipes" "Pipes"
+"A " { $emphasis "pipe" } " is a unidirectional channel for transfer of bytes. Data written to one end of the pipe can be read from the other. Pipes can be used to pass data between processes; they can also be used within a single process to implement communication between coroutines."
+$nl
+"Low-level pipes:"
+{ $subsection pipe }
+{ $subsection (pipe) }
+"High-level pipe streams:"
+{ $subsection <pipe> }
+"Pipelines of coroutines and processes:"
+{ $subsection run-pipeline } ;
+
+ABOUT: "io.pipes"
--- /dev/null
+USING: io io.pipes io.streams.string io.encodings.utf8
+io.streams.duplex io.encodings namespaces continuations
+tools.test kernel ;
+IN: io.pipes.tests
+
+[ "Hello" ] [
+ utf8 <pipe> [
+ "Hello" print flush
+ readln
+ ] with-stream
+] unit-test
+
+[ { } ] [ { } run-pipeline ] unit-test
+[ { f } ] [ { [ f ] } run-pipeline ] unit-test
+[ { "Hello" } ] [
+ "Hello" [
+ { [ input-stream [ utf8 <decoder> ] change readln ] } run-pipeline
+ ] with-string-reader
+] unit-test
+
+[ { f "Hello" } ] [
+ {
+ [ output-stream [ utf8 <encoder> ] change "Hello" print flush f ]
+ [ input-stream [ utf8 <decoder> ] change readln ]
+ } run-pipeline
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings io.backend io.nonblocking io.streams.duplex
+io splitting sequences sequences.lib namespaces kernel
+destructors math concurrency.combinators accessors
+arrays continuations quotations ;
+IN: io.pipes
+
+TUPLE: pipe in out ;
+
+M: pipe dispose ( pipe -- )
+ [ in>> close-handle ] [ out>> close-handle ] bi ;
+
+HOOK: (pipe) io-backend ( -- pipe )
+
+: <pipe> ( encoding -- stream )
+ [
+ >r (pipe)
+ [ add-error-destructor ]
+ [ in>> <reader> ]
+ [ out>> <writer> ]
+ tri
+ r> <encoder-duplex>
+ ] with-destructors ;
+
+<PRIVATE
+
+: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
+: ?writer [ <writer> dup add-always-destructor ] [ output-stream get ] if* ;
+
+GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
+
+M: callable run-pipeline-element
+ [
+ >r [ ?reader ] [ ?writer ] bi*
+ r> with-streams*
+ ] with-destructors ;
+
+: <pipes> ( n -- pipes )
+ [
+ [ (pipe) dup add-error-destructor ] replicate
+ T{ pipe } [ prefix ] [ suffix ] bi
+ 2 <clumps>
+ ] with-destructors ;
+
+PRIVATE>
+
+: run-pipeline ( seq -- results )
+ [ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
+ [
+ >r [ first in>> ] [ second out>> ] bi
+ r> run-pipeline-element
+ ] 2parallel-map ;
HELP: with-server
{ $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." } ;
+{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
HELP: with-datagrams
{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
-{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received. Datagram packets are logged to the " { $link stdio } " stream at the time the server was started." } ;
+{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.sockets io.files logging continuations kernel
-math math.parser namespaces parser sequences strings
-prettyprint debugger quotations calendar
+USING: io io.sockets io.files io.streams.duplex logging
+continuations kernel math math.parser namespaces parser
+sequences strings prettyprint debugger quotations calendar
threads concurrency.combinators assocs ;
IN: io.server
] with-variable ; inline
: stop-server ( -- )
- servers get [ dispose ] each ;
+ servers get dispose-each ;
<PRIVATE
ARTICLE: "network-connection" "Connection-oriented networking"
"Network connections can be established with this word:"
{ $subsection <client> }
+{ $subsection with-client }
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsection <server> }
{ $subsection accept }
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
-sequences arrays io.encodings io.nonblocking accessors ;
+sequences arrays io.encodings io.nonblocking io.streams.duplex
+accessors ;
IN: io.sockets
TUPLE: local path ;
: <client> ( addrspec encoding -- stream )
>r (client) r> <encoder-duplex> ;
+: with-client ( addrspec encoding quot -- )
+ >r <client> r> with-stream ; inline
+
HOOK: (server) io-backend ( addrspec -- handle )
: <server> ( addrspec encoding -- server )
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax io continuations quotations ;
+IN: io.streams.duplex
+
+ARTICLE: "io.streams.duplex" "Duplex streams"
+"Duplex streams combine an input stream and an output stream into a bidirectional stream."
+{ $subsection duplex-stream }
+{ $subsection <duplex-stream> }
+"A pair of combinators for rebinding both default streams at once:"
+{ $subsection with-stream }
+{ $subsection with-stream* } ;
+
+ABOUT: "io.streams.duplex"
+
+HELP: duplex-stream
+{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
+
+HELP: <duplex-stream>
+{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
+{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
+
+HELP: stream-closed-twice
+{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
+
+HELP: with-stream
+{ $values { "stream" duplex-stream } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
+
+HELP: with-stream*
+{ $values { "stream" duplex-stream } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } "." }
+{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
+
+HELP: <encoder-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" } "." }
+$low-level-note ;
--- /dev/null
+USING: io.streams.duplex io kernel continuations tools.test ;
+IN: io.streams.duplex.tests
+
+! Test duplex stream close behavior
+TUPLE: closing-stream closed? ;
+
+: <closing-stream> closing-stream new ;
+
+M: closing-stream dispose
+ dup closing-stream-closed? [
+ "Closing twice!" throw
+ ] [
+ t swap set-closing-stream-closed?
+ ] if ;
+
+TUPLE: unclosable-stream ;
+
+: <unclosable-stream> unclosable-stream new ;
+
+M: unclosable-stream dispose
+ "Can't close me!" throw ;
+
+[ ] [
+ <closing-stream> <closing-stream> <duplex-stream>
+ dup dispose dispose
+] unit-test
+
+[ t ] [
+ <unclosable-stream> <closing-stream> [
+ <duplex-stream>
+ [ dup dispose ] [ 2drop ] recover
+ ] keep closing-stream-closed?
+] unit-test
+
+[ t ] [
+ <closing-stream> [ <unclosable-stream>
+ <duplex-stream>
+ [ dup dispose ] [ 2drop ] recover
+ ] keep closing-stream-closed?
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations io io.encodings io.encodings.private
+io.timeouts debugger inspector listener accessors delegate
+delegate.protocols ;
+IN: io.streams.duplex
+
+! We ensure that the stream can only be closed once, to preserve
+! integrity of duplex I/O ports.
+
+TUPLE: duplex-stream in out closed ;
+
+: <duplex-stream> ( in out -- stream )
+ f duplex-stream boa ;
+
+ERROR: stream-closed-twice ;
+
+M: stream-closed-twice summary
+ drop "Attempt to perform I/O on closed stream" ;
+
+<PRIVATE
+
+: check-closed ( stream -- stream )
+ dup closed>> [ stream-closed-twice ] when ; inline
+
+: in ( duplex -- stream ) check-closed in>> ;
+
+: out ( duplex -- stream ) check-closed out>> ;
+
+PRIVATE>
+
+CONSULT: input-stream-protocol duplex-stream in ;
+
+CONSULT: output-stream-protocol duplex-stream out ;
+
+M: duplex-stream set-timeout
+ [ in set-timeout ] [ out set-timeout ] 2bi ;
+
+M: duplex-stream dispose
+ #! The output stream is closed first, in case both streams
+ #! are attached to the same file descriptor, the output
+ #! buffer needs to be flushed before we close the fd.
+ dup closed>> [
+ t >>closed
+ [ dup out>> dispose ]
+ [ dup in>> dispose ] [ ] cleanup
+ ] unless drop ;
+
+: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
+ tuck reencode >r redecode r> <duplex-stream> ;
+
+: with-stream* ( stream quot -- )
+ >r [ in>> ] [ out>> ] bi r> with-streams* ; inline
+
+: with-stream ( stream quot -- )
+ >r [ in>> ] [ out>> ] bi r> with-streams ; inline
--- /dev/null
+Combine an input and an output stream into a single duplex stream
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null
-USING: kernel io io.timeouts continuations ;
+USING: kernel io io.timeouts io.streams.duplex continuations ;
TUPLE: null-stream ;
M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ;
-M: null-stream stream-readln drop f ;
-M: null-stream stream-read1 drop f ;
-M: null-stream stream-read-until 2drop f f ;
-M: null-stream stream-read 2drop f ;
-M: null-stream stream-write1 2drop ;
-M: null-stream stream-write 2drop ;
-M: null-stream stream-nl drop ;
-M: null-stream stream-flush drop ;
-M: null-stream stream-format 3drop ;
-M: null-stream make-span-stream nip ;
-M: null-stream make-block-stream nip ;
-M: null-stream make-cell-stream nip ;
-M: null-stream stream-write-table 3drop ;
+
+TUPLE: null-reader < null-stream ;
+
+M: null-reader stream-readln drop f ;
+M: null-reader stream-read1 drop f ;
+M: null-reader stream-read-until 2drop f f ;
+M: null-reader stream-read 2drop f ;
+
+TUPLE: null-writer < null-stream ;
+
+M: null-writer stream-write1 2drop ;
+M: null-writer stream-write 2drop ;
+M: null-writer stream-nl drop ;
+M: null-writer stream-flush drop ;
+M: null-writer stream-format 3drop ;
+M: null-writer make-span-stream nip ;
+M: null-writer make-block-stream nip ;
+M: null-writer make-cell-stream nip ;
+M: null-writer stream-write-table 3drop ;
+
+: with-null-reader ( quot -- )
+ T{ null-reader } swap with-input-stream* ; inline
+
+: with-null-writer ( quot -- )
+ T{ null-writer } swap with-output-stream* ; inline
: with-null-stream ( quot -- )
- T{ null-stream } swap with-stream* ; inline
+ T{ duplex-stream f T{ null-reader } T{ null-writer } }
+ swap with-stream* ; inline
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel calendar alarms io.streams.duplex io.encodings ;\r
+USING: kernel calendar alarms io io.encodings accessors\r
+namespaces ;\r
IN: io.timeouts\r
\r
! Won't need this with new slot accessors\r
GENERIC: timeout ( obj -- dt/f )\r
GENERIC: set-timeout ( dt/f obj -- )\r
\r
-M: duplex-stream set-timeout\r
- 2dup\r
- duplex-stream-in set-timeout\r
- duplex-stream-out set-timeout ;\r
+M: decoder set-timeout stream>> set-timeout ;\r
\r
-M: decoder set-timeout decoder-stream set-timeout ;\r
-\r
-M: encoder set-timeout encoder-stream set-timeout ;\r
+M: encoder set-timeout stream>> set-timeout ;\r
\r
GENERIC: timed-out ( obj -- )\r
\r
] [\r
2drop call\r
] if ; inline\r
+\r
+: timeouts ( dt -- )\r
+ [ input-stream get set-timeout ]\r
+ [ output-stream get set-timeout ] bi ;\r
! Copyright (C) 2004, 2008 Slava Pestov.
! 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 io.encodings
-io.streams.duplex math.parser continuations system libc
-qualified namespaces io.timeouts io.encodings.utf8 accessors ;
+io.nonblocking sequences strings structs sbufs threads unix
+vectors io.buffers io.backend io.encodings math.parser
+continuations system libc qualified namespaces io.timeouts
+io.encodings.utf8 accessors ;
QUALIFIED: io
IN: io.unix.backend
#! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and
#! 1 are closed).
- F_SETFL O_NONBLOCK fcntl drop ;
+ [ F_SETFL O_NONBLOCK fcntl drop ]
+ [ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: integer close-handle ( fd -- )
close ;
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-stream> contents
-] unit-test
-
-[ f ] [
- <process>
- "cat"
- "launcher-test-1" temp-file
- 2array >>command
- +inherit+ >>stdout
- ascii <process-stream> contents
+ ascii <process-reader> contents
] unit-test
[ ] [
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-stream> contents
+ ascii <process-reader> contents
] unit-test
[ ] [
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-stream> contents
+ ascii <process-reader> contents
] unit-test
[ t ] [
<process>
"env" >>command
{ { "A" "B" } } >>environment
- ascii <process-stream> lines
+ ascii <process-reader> lines
"A=B" swap member?
] unit-test
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
- ascii <process-stream> lines
+ ascii <process-reader> lines
] unit-test
[ "hi\n" ] [
temp-directory "aloha" append-path
utf8 file-contents
] unit-test
+
+[ "append-test" temp-file delete-file ] ignore-errors
+
+[ "hi\nhi\n" ] [
+ 2 [
+ <process>
+ "echo hi" >>command
+ "append-test" temp-file <appender> >>stdout
+ try-process
+ ] times
+ "append-test" temp-file utf8 file-contents
+] unit-test
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-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 accessors io.files io.files.private ;
+USING: kernel namespaces math system sequences debugger
+continuations arrays assocs combinators alien.c-types strings
+threads accessors
+io io.backend io.launcher io.nonblocking io.files
+io.files.private io.unix.files io.unix.backend
+io.unix.launcher.parser
+unix unix.process ;
IN: io.unix.launcher
! Search unix first
: reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of
#! /dev/null fails.
- F_SETFL 0 fcntl drop ;
+ [ F_SETFL 0 fcntl drop ]
+ [ F_SETFD 0 fcntl drop ] bi ;
: redirect-inherit ( obj mode fd -- )
2nip reset-fd ;
>r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ;
+: redirect-file-append ( obj mode fd -- )
+ >r drop path>> normalize-path open-append r> redirect-fd ;
+
: redirect-closed ( obj mode fd -- )
>r >r drop "/dev/null" r> r> redirect-file ;
-: redirect-stream ( obj mode fd -- )
- >r drop underlying-handle dup reset-fd r> redirect-fd ;
-
: redirect ( obj mode fd -- )
{
{ [ pick not ] [ redirect-inherit ] }
{ [ pick string? ] [ redirect-file ] }
+ { [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
- { [ pick +inherit+ eq? ] [ redirect-closed ] }
- [ redirect-stream ]
+ { [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] }
+ [ >r >r underlying-handle r> r> redirect ]
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
M: unix kill-process* ( pid -- )
SIGTERM kill io-error ;
-: open-pipe ( -- pair )
- 2 "int" <c-array> dup pipe zero?
- [ 2 c-int-array> ] [ drop f ] if ;
-
-: setup-stdio-pipe ( stdin stdout -- )
- 2dup first close second close
- >r first 0 dup2 drop r> second 1 dup2 drop ;
-
-M: unix (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 handle>> = ] curry
assoc-find 2drop ;
-! Inefficient process wait polling, used on Linux and Solaris.
-! On BSD and Mac OS X, we use kqueue() which scales better.
M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
] curry each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
- path mailbox macosx-monitor new-monitor
- dup [ enqueue-notifications ] curry
- path 1array 0 0 <event-stream> >>handle ;
+ [let | path [ path normalize-path ] |
+ path mailbox macosx-monitor new-monitor
+ dup [ enqueue-notifications ] curry
+ path 1array 0 0 <event-stream> >>handle
+ ] ;
M: macosx-monitor dispose
handle>> dispose ;
--- /dev/null
+USING: tools.test io.pipes io.unix.pipes io.encodings.utf8
+io.encodings io namespaces sequences ;
+IN: io.unix.pipes.tests
+
+[ { 0 0 } ] [ { "ls" "grep x" } run-pipeline ] unit-test
+
+[ { 0 f 0 } ] [
+ {
+ "ls"
+ [
+ input-stream [ utf8 <decoder> ] change
+ output-stream [ utf8 <encoder> ] change
+ input-stream get lines reverse [ print ] each f
+ ]
+ "grep x"
+ } run-pipeline
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system alien.c-types kernel unix math sequences
+qualified io.unix.backend io.nonblocking ;
+IN: io.unix.pipes
+QUALIFIED: io.pipes
+
+M: unix io.pipes:(pipe) ( -- pair )
+ 2 "int" <c-array>
+ dup pipe io-error
+ 2 c-int-array> first2
+ [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;
USING: io.files io.sockets io kernel threads
namespaces tools.test continuations strings byte-arrays
-sequences prettyprint system io.encodings.binary io.encodings.ascii ;
+sequences prettyprint system io.encodings.binary io.encodings.ascii
+io.streams.duplex ;
IN: io.unix.tests
! Unix domain stream sockets
[ { "Hello world" "FOO" } ] [
[
- socket-server <local> ascii <client>
- [
+ socket-server <local> ascii [
readln ,
"XYZ" print flush
readln ,
- ] with-stream
+ ] with-client
] { } make
] unit-test
! Invalid parameter tests
[
- image binary [ stdio get accept ] with-file-reader
+ image binary [ input-stream get accept ] with-file-reader
] must-fail
[
- image binary [ stdio get receive ] with-file-reader
+ image binary [ input-stream get receive ] with-file-reader
] must-fail
[
image binary [
B{ 1 2 } datagram-server <local>
- stdio get send
+ input-stream 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 words init ;
+USING: io.unix.backend io.unix.files io.unix.sockets
+io.unix.launcher io.unix.mmap io.unix.pipes io.timeouts
+io.backend combinators namespaces system vocabs.loader
+sequences words init ;
"io.unix." os word-name append require
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io
io.windows io.windows.nt.pipes libc io.nonblocking
-io.streams.duplex windows.types math windows.kernel32
+windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
io.backend accessors concurrency.flags io.files assocs
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
+M: winnt open-append
+ [ dup file-info size>> ] [ drop 0 ] recover
+ >r (open-append) r> ;
+
: update-file-ptr ( n port -- )
port-handle
dup win32-file-ptr [
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 math ;\r
+sequences parser assocs hashtables math continuations ;\r
\r
[ ] [\r
<process>\r
] unit-test\r
\r
[ ] [\r
- "extra/io/windows/nt/launcher/test" resource-path [\r
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "stderr.factor" 3array >>command\r
"out.txt" temp-file >>stdout\r
] unit-test\r
\r
[ ] [\r
- "extra/io/windows/nt/launcher/test" resource-path [\r
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "stderr.factor" 3array >>command\r
"out.txt" temp-file >>stdout\r
] unit-test\r
\r
[ "output" ] [\r
- "extra/io/windows/nt/launcher/test" resource-path [\r
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "stderr.factor" 3array >>command\r
"err2.txt" temp-file >>stderr\r
- ascii <process-stream> lines first\r
+ ascii <process-reader> lines first\r
] with-directory\r
] unit-test\r
\r
] unit-test\r
\r
[ t ] [\r
- "extra/io/windows/nt/launcher/test" resource-path [\r
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "env.factor" 3array >>command\r
- ascii <process-stream> contents\r
+ ascii <process-reader> 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
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "env.factor" 3array >>command\r
+replace-environment+ >>environment-mode\r
os-envs >>environment\r
- ascii <process-stream> contents\r
+ ascii <process-reader> 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
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "env.factor" 3array >>command\r
{ { "A" "B" } } >>environment\r
- ascii <process-stream> contents\r
+ ascii <process-reader> 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
+ "resource:extra/io/windows/nt/launcher/test" [\r
<process>\r
vm "-script" "env.factor" 3array >>command\r
{ { "HOME" "XXX" } } >>environment\r
+prepend-environment+ >>environment-mode\r
- ascii <process-stream> contents\r
+ ascii <process-reader> contents\r
] with-directory eval\r
\r
"HOME" swap at "XXX" =\r
\r
[ ] [ "dir.txt" temp-file delete-file ] unit-test\r
] times\r
+\r
+[ "append-test" temp-file delete-file ] ignore-errors\r
+\r
+[ "Hello appender\r\nHello appender\r\n" ] [\r
+ 2 [\r
+ "resource:extra/io/windows/nt/launcher/test" [\r
+ <process>\r
+ vm "-script" "append.factor" 3array >>command\r
+ "append-test" temp-file <appender> >>stdout\r
+ try-process\r
+ ] with-directory\r
+ ] times\r
+ \r
+ "append-test" temp-file ascii file-contents\r
+] unit-test\r
! 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
+io.windows libc io.nonblocking io.pipes 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 io.files
DuplicateHandle win32-error=0/f
] keep *void* ;
+! /dev/null simulation
+: null-input ( -- pipe )
+ (pipe) [ in>> handle>> ] [ out>> close-handle ] bi ;
+
+: null-output ( -- pipe )
+ (pipe) [ in>> close-handle ] [ out>> handle>> ] bi ;
+
+: null-pipe ( mode -- pipe )
+ {
+ { GENERIC_READ [ null-input ] }
+ { GENERIC_WRITE [ null-output ] }
+ } case ;
+
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: 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 ;
f ! template file
CreateFile dup invalid-handle? dup close-always ;
+: redirect-append ( default path access-mode create-mode -- handle )
+ >r >r path>> r> r>
+ drop OPEN_ALWAYS
+ redirect-file
+ dup 0 FILE_END set-file-pointer ;
+
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
-: redirect-stream ( default stream access-mode create-mode -- handle )
+: redirect-handle ( default handle access-mode create-mode -- handle )
2drop nip
- underlying-handle win32-file-handle
- duplicate-handle dup t set-inherit ;
+ handle>> duplicate-handle dup t set-inherit ;
+
+: redirect-stream ( default stream access-mode create-mode -- handle )
+ >r >r underlying-handle r> r> redirect-handle ;
: 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 ] }
+ { [ pick appender? ] [ redirect-append ] }
+ { [ pick win32-file? ] [ redirect-handle ] }
[ redirect-stream ]
} cond ;
: default-stdout ( args -- handle )
- stdout-pipe>> dup [ pipe-out ] when ;
+ stdout-pipe>> dup [ out>> ] when ;
: redirect-stdout ( process args -- handle )
default-stdout
] if ;
: default-stdin ( args -- handle )
- stdin-pipe>> dup [ pipe-in ] when ;
+ stdin-pipe>> dup [ in>> ] when ;
: redirect-stdin ( process args -- handle )
default-stdin
redirect
STD_INPUT_HANDLE GetStdHandle or ;
-: add-pipe-dtors ( pipe -- )
- dup
- in>> close-later
- out>> close-later ;
-
-: fill-stdout-pipe ( args -- args )
- <unique-incoming-pipe>
- dup add-pipe-dtors
- dup pipe-in f set-inherit
- >>stdout-pipe ;
-
-: fill-stdin-pipe ( args -- args )
- <unique-outgoing-pipe>
- dup add-pipe-dtors
- dup pipe-out f set-inherit
- >>stdin-pipe ;
-
M: winnt 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: winnt (process-stream)
- [
- current-directory get (normalize-path) cd
-
- dup make-CreateProcess-args
-
- fill-stdout-pipe
- fill-stdin-pipe
-
- tuck fill-redirection
-
- dup call-CreateProcess
-
- dup stdin-pipe>> pipe-in CloseHandle drop
- dup stdout-pipe>> pipe-out CloseHandle drop
-
- dup lpProcessInformation>>
- over stdout-pipe>> in>> f <win32-file>
- rot stdin-pipe>> out>> f <win32-file>
- ] with-destructors ;
--- /dev/null
+USE: io\r
+"Hello appender" print\r
USE: namespaces\r
\r
"output" write flush\r
-"error" stderr get stream-write stderr get stream-flush\r
+"error" error-stream get stream-write error-stream get stream-flush\r
USING: alien alien.c-types libc destructors locals
kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system
-accessors threads
-io.backend io.windows io.windows.nt.backend io.monitors
-io.nonblocking io.buffers io.files io.timeouts io
+accessors threads splitting
+io.backend io.windows io.windows.nt.backend io.windows.nt.files
+io.monitors io.nonblocking io.buffers io.files io.timeouts io
windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: file-notify-records ( buffer -- seq )
[ (file-notify-records) drop ] { } make ;
-: parse-notify-records ( monitor buffer -- )
- file-notify-records
- [ parse-notify-record rot queue-change ] with each ;
+:: parse-notify-records ( monitor buffer -- )
+ buffer file-notify-records [
+ parse-notify-record
+ [ monitor path>> prepend-path normalize-path ] dip
+ monitor queue-change
+ ] each ;
: fill-queue ( monitor -- )
dup port>> check-closed
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 accessors ;
+windows.types math.bitfields windows.kernel32 windows namespaces
+kernel sequences windows.errors assocs math.parser system random
+combinators accessors io.pipes io.nonblocking ;
IN: io.windows.nt.pipes
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
-: create-named-pipe ( name mode -- handle )
- FILE_FLAG_OVERLAPPED bitor
+: create-named-pipe ( name -- handle )
+ { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
PIPE_TYPE_BYTE
1
4096
security-attributes-inherit
CreateNamedPipe
dup win32-error=0/f
- dup add-completion ;
+ dup add-completion
+ f <win32-file> ;
-: open-other-end ( name mode -- handle )
- FILE_SHARE_READ FILE_SHARE_WRITE bitor
+: open-other-end ( name -- handle )
+ GENERIC_WRITE
+ { FILE_SHARE_READ FILE_SHARE_WRITE } flags
security-attributes-inherit
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
f
CreateFile
dup win32-error=0/f
- dup add-completion ;
-
-TUPLE: pipe in out ;
-
-: <pipe> ( name in-mode out-mode -- pipe )
- [
- >r over >r create-named-pipe dup close-later
- r> r> open-other-end dup close-later
- pipe boa
- ] with-destructors ;
-
-: close-pipe ( pipe -- )
- dup
- in>> CloseHandle drop
- out>> CloseHandle drop ;
-
-: <incoming-pipe> ( name -- pipe )
- PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
-
-: <outgoing-pipe> ( name -- pipe )
- PIPE_ACCESS_DUPLEX GENERIC_READ <pipe> ;
+ dup add-completion
+ f <win32-file> ;
: unique-pipe-name ( -- string )
[
millis #
] "" make ;
-: <unique-incoming-pipe> ( -- pipe )
- unique-pipe-name <incoming-pipe> ;
-
-: <unique-outgoing-pipe> ( -- pipe )
- unique-pipe-name <outgoing-pipe> ;
-
-! /dev/null simulation
-: null-input ( -- pipe )
- <unique-outgoing-pipe>
- dup out>> CloseHandle drop
- in>> ;
-
-: null-output ( -- pipe )
- <unique-incoming-pipe>
- dup in>> CloseHandle drop
- out>> ;
-
-: null-pipe ( mode -- pipe )
- {
- { [ dup GENERIC_READ = ] [ drop null-input ] }
- { [ dup GENERIC_WRITE = ] [ drop null-output ] }
- } cond ;
+M: winnt (pipe) ( -- pipe )
+ [
+ unique-pipe-name
+ [ create-named-pipe dup close-later ]
+ [ open-other-end dup close-later ]
+ bi pipe boa
+ ] with-destructors ;
! 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
+io.sockets.impl windows.errors strings
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
IN: io.windows
-M: windows destruct-handle CloseHandle drop ;
-
M: windows destruct-socket closesocket drop ;
TUPLE: win32-file handle ptr ;
drop ;
M: win32-file close-handle ( handle -- )
- win32-file-handle CloseHandle drop ;
+ win32-file-handle close-handle ;
+
+M: alien close-handle ( handle -- )
+ CloseHandle drop ;
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode flags -- handle )
f CreateFileW dup win32-error=0/f
GetLastError ERROR_ALREADY_EXISTS = not ;
-: set-file-pointer ( handle length -- )
- dupd d>w/w <uint> FILE_BEGIN SetFilePointer
+: set-file-pointer ( handle length method -- )
+ >r dupd d>w/w <uint> r> SetFilePointer
INVALID_SET_FILE_POINTER = [
CloseHandle "SetFilePointer failed" throw
] when drop ;
-: open-append ( path -- handle length )
- [ dup file-info size>> ] [ drop 0 ] recover
- >r (open-append) r> 2dup set-file-pointer ;
+HOOK: open-append os ( path -- handle length )
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead
M: number json-print ( num -- )
number>string write ;
-! sequence and number overlap, we provide an explicit
-! disambiguation method
-M: integer json-print ( num -- )
- number>string write ;
-
M: sequence json-print ( array -- )
CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
- basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
+ basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
--- /dev/null
+Daniel Ehrenberg\r
--- /dev/null
+USING: help.syntax help.markup ;\r
+IN: lcs\r
+\r
+HELP: levenshtein\r
+{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }\r
+{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;\r
+\r
+HELP: lcs\r
+{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } }\r
+{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;\r
+\r
+HELP: diff\r
+{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } }\r
+{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;\r
+\r
+HELP: retain\r
+{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;\r
+\r
+HELP: delete\r
+{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;\r
+\r
+HELP: insert\r
+{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;\r
+\r
+ARTICLE: "lcs" "LCS, Diffing and Distance"\r
+"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."\r
+{ $subsection lcs }\r
+{ $subsection diff }\r
+{ $subsection levenshtein }\r
+"The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."\r
+{ $subsection insert }\r
+{ $subsection delete }\r
+{ $subsection retain } ;\r
+\r
+ABOUT: "lcs"\r
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test lcs ;
+
+[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
+[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
+[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
+[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
+
+[ "hell" ] [ "hello" "hell" lcs ] unit-test
+[ "hell" ] [ "hell" "hello" lcs ] unit-test
+[ "ell" ] [ "ell" "hell" lcs ] unit-test
+[ "ell" ] [ "hell" "ell" lcs ] unit-test
+[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+
+[ {
+ T{ delete f CHAR: f }
+ T{ retain f CHAR: a }
+ T{ delete f CHAR: x }
+ T{ retain f CHAR: b }
+ T{ delete f CHAR: c }
+ T{ retain f CHAR: d }
+ T{ insert f CHAR: e }
+ T{ insert f CHAR: f }
+} ] [ "faxbcd" "abdef" diff ] unit-test
--- /dev/null
+USING: sequences kernel math locals math.order math.ranges\r
+accessors combinators.lib arrays namespaces combinators ;\r
+IN: lcs\r
+\r
+<PRIVATE\r
+: levenshtein-step ( insert delete change same? -- next )\r
+ 0 1 ? + >r [ 1+ ] bi@ r> min min ;\r
+\r
+: lcs-step ( insert delete change same? -- next )\r
+ 1 -9999 ? + max max ; ! Replace -9999 with -inf when added\r
+\r
+:: loop-step ( i j matrix old new step -- )\r
+ i j 1+ matrix nth nth ! insertion\r
+ i 1+ j matrix nth nth ! deletion\r
+ i j matrix nth nth ! replace/retain\r
+ i old nth j new nth = ! same?\r
+ step call\r
+ i 1+ j 1+ matrix nth set-nth ; inline\r
+\r
+: lcs-initialize ( |str1| |str2| -- matrix )\r
+ [ drop 0 <array> ] with map ;\r
+\r
+: levenshtein-initialize ( |str1| |str2| -- matrix )\r
+ [ [ + ] curry map ] with map ;\r
+\r
+:: run-lcs ( old new init step -- matrix )\r
+ [let | matrix [ old length 1+ new length 1+ init call ] |\r
+ old length [0,b) [| i |\r
+ new length [0,b)\r
+ [| j | i j matrix old new step loop-step ]\r
+ each\r
+ ] each matrix ] ; inline\r
+PRIVATE>\r
+\r
+: levenshtein ( old new -- n )\r
+ [ levenshtein-initialize ] [ levenshtein-step ]\r
+ run-lcs peek peek ;\r
+\r
+TUPLE: retain item ;\r
+TUPLE: delete item ;\r
+TUPLE: insert item ;\r
+\r
+<PRIVATE\r
+TUPLE: trace-state old new table i j ;\r
+\r
+: old-nth ( state -- elt )\r
+ [ i>> 1- ] [ old>> ] bi nth ;\r
+\r
+: new-nth ( state -- elt )\r
+ [ j>> 1- ] [ new>> ] bi nth ;\r
+\r
+: top-beats-side? ( state -- ? )\r
+ [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]\r
+ [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;\r
+\r
+: retained? ( state -- ? )\r
+ {\r
+ [ i>> 0 > ] [ j>> 0 > ]\r
+ [ [ old-nth ] [ new-nth ] bi = ]\r
+ } <-&& ;\r
+\r
+: do-retain ( state -- state )\r
+ dup old-nth retain boa ,\r
+ [ 1- ] change-i [ 1- ] change-j ;\r
+\r
+: inserted? ( state -- ? )\r
+ [ j>> 0 > ]\r
+ [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;\r
+\r
+: do-insert ( state -- state )\r
+ dup new-nth insert boa , [ 1- ] change-j ;\r
+\r
+: deleted? ( state -- ? )\r
+ [ i>> 0 > ]\r
+ [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;\r
+\r
+: do-delete ( state -- state )\r
+ dup old-nth delete boa , [ 1- ] change-i ;\r
+\r
+: (trace-diff) ( state -- )\r
+ {\r
+ { [ dup retained? ] [ do-retain (trace-diff) ] }\r
+ { [ dup inserted? ] [ do-insert (trace-diff) ] }\r
+ { [ dup deleted? ] [ do-delete (trace-diff) ] }\r
+ [ drop ] ! i=j=0\r
+ } cond ;\r
+\r
+: trace-diff ( old new table -- diff )\r
+ [ ] [ first length 1- ] [ length 1- ] tri trace-state boa\r
+ [ (trace-diff) ] { } make reverse ;\r
+PRIVATE>\r
+\r
+: diff ( old new -- diff )\r
+ 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;\r
+\r
+: lcs ( seq1 seq2 -- lcs )\r
+ [ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;\r
--- /dev/null
+Levenshtein distance and diff between sequences\r
--- /dev/null
+algorithms\r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: levenshtein.tests
-USING: tools.test levenshtein ;
-
-[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
-[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
-[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
-[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help io kernel math namespaces sequences
-math.order ;
-IN: levenshtein
-
-: <matrix> ( m n -- matrix )
- [ drop 0 <array> ] with map ; inline
-
-: matrix-> nth nth ; inline
-: ->matrix nth set-nth ; inline
-
-SYMBOL: d
-
-: ->d ( n i j -- ) d get ->matrix ; inline
-: d-> ( i j -- n ) d get matrix-> ; inline
-
-SYMBOL: costs
-
-: init-d ( str1 str2 -- )
- [ length 1+ ] bi@ 2dup <matrix> d set
- [ 0 over ->d ] each
- [ dup 0 ->d ] each ; inline
-
-: compute-costs ( str1 str2 -- )
- swap [
- [ = 0 1 ? ] with { } map-as
- ] curry { } map-as costs set ; inline
-
-: levenshtein-step ( i j -- )
- [ 1+ d-> 1+ ] 2keep
- [ >r 1+ r> d-> 1+ ] 2keep
- [ d-> ] 2keep
- [ costs get matrix-> + min min ] 2keep
- >r 1+ r> 1+ ->d ; inline
-
-: levenshtein-result ( -- n ) d get peek peek ; inline
-
-: levenshtein ( str1 str2 -- n )
- [
- 2dup init-d
- 2dup compute-costs
- [ length ] bi@ [
- [ levenshtein-step ] curry each
- ] with each
- levenshtein-result
- ] with-scope ;
+++ /dev/null
-Levenshtein edit distance algorithm
memoize ;
IN: locals
-<PRIVATE
-
-: $with-locals-note
- drop {
- "This form must appear either in a word defined by " { $link POSTPONE: :: } " or " { $link POSTPONE: MACRO:: } ", or alternatively, " { $link with-locals } " must be called on the top-level form of the word to perform closure conversion."
- } $notes ;
-
-PRIVATE>
-
HELP: [|
{ $syntax "[| bindings... | body... ]" }
{ $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." }
"3 5 adder call ."
"8"
}
-}
-$with-locals-note ;
+} ;
HELP: [let
{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
"6 { 36 14 } frobnicate ."
"{ 36 2 }"
}
-}
-$with-locals-note ;
+} ;
HELP: [let*
{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
"1 { 32 48 } frobnicate ."
"{ 2 3 }"
}
-}
-$with-locals-note ;
+} ;
{ POSTPONE: [let POSTPONE: [let* } related-words
}
} ;
-HELP: with-locals
-{ $values { "form" "a quotation, lambda, let or wlet form" } { "quot" "a quotation" } }
-{ $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... -- 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." }
{ $subsection POSTPONE: :: }
{ $subsection POSTPONE: MEMO:: }
{ $subsection POSTPONE: MACRO:: }
-"Explicit closure conversion outside of applicative word definitions:"
-{ $subsection with-locals }
"Lexical binding forms:"
{ $subsection POSTPONE: [let }
{ $subsection POSTPONE: [let* }
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
-;
+accessors ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ 5 ] [
[let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
- with-locals
] unit-test
:: wlet-test-2 ( a b -- seq )
[ 10 20 ]
[
- 20 10 [| a! | [| b! | a b ] ] with-locals call call
+ 20 10 [| a! | [| b! | a b ] ] call call
] unit-test
:: write-test-3 ( a! -- q ) [| b | b a! ] ;
[ ] [ \ lambda-generic see ] unit-test
+:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
+
[ "[let | a! [ ] | ]" ] [
- [let | a! [ ] | ] unparse
+ \ unparse-test-1 "lambda" word-prop body>> first unparse
] unit-test
+:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
+
[ "[wlet | a! [ ] | ]" ] [
- [wlet | a! [ ] | ] unparse
+ \ unparse-test-2 "lambda" word-prop body>> first unparse
] unit-test
+:: unparse-test-3 ( -- b ) [| a! | ] ;
+
[ "[| a! | ]" ] [
- [| a! | ] unparse
+ \ unparse-test-3 "lambda" word-prop body>> first unparse
] unit-test
DEFER: xyzzy
[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
+GENERIC: next-method-test ( a -- b )
+
+M: integer next-method-test 3 + ;
+
+M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
+
+[ 5 ] [ 1 next-method-test ] unit-test
+
+: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
+
+[ { 4 5 6 } ] [ no-with-locals-test ] unit-test
] if ;
: point-free-body ( quot args -- newquot )
- >r 1 head-slice* r> [ localize ] curry map concat ;
+ >r but-last-slice r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
: pop-locals ( assoc -- )
use get delete ;
+SYMBOL: in-lambda?
+
: (parse-lambda) ( assoc end -- quot )
- parse-until >quotation swap pop-locals ;
+ t in-lambda? [ parse-until ] with-variable
+ >quotation swap pop-locals ;
: parse-lambda ( -- lambda )
"|" parse-tokens make-locals dup push-locals
: (::) CREATE-WORD parse-locals-definition ;
-: (M::) CREATE-METHOD parse-locals-definition ;
+: (M::)
+ CREATE-METHOD
+ [ parse-locals-definition ] with-method-definition ;
+
+: parsed-lambda ( form -- )
+ in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
PRIVATE>
-: [| parse-lambda parsed ; parsing
+: [| parse-lambda parsed-lambda ; parsing
: [let
scan "|" assert= parse-bindings
-\ ] (parse-lambda) <let> parsed ; parsing
+ \ ] (parse-lambda) <let> parsed-lambda ; parsing
: [let*
scan "|" assert= parse-bindings*
- >r \ ] parse-until >quotation <let*> parsed r> pop-locals ;
- parsing
+ \ ] (parse-lambda) <let*> parsed-lambda ; parsing
: [wlet
scan "|" assert= parse-wbindings
- \ ] (parse-lambda) <wlet> parsed ; parsing
-
-MACRO: with-locals ( form -- quot ) lambda-rewrite ;
+ \ ] (parse-lambda) <wlet> parsed-lambda ; parsing
: :: (::) define ; parsing
\r
: (log-message) ( msg -- )\r
#! msg: { msg word-name level service }\r
- first4 log-stream [ write-message flush ] with-stream* ;\r
+ first4 log-stream [ write-message flush ] with-output-stream* ;\r
\r
: try-dispose ( stream -- )\r
[ dispose ] curry [ error. ] recover ;\r
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: tools.test monads math kernel sequences lazy-lists promises ;
+IN: monads.tests
+
+[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
+[ "OH HAI" identity-monad fail ] must-fail
+
+[ 666 ] [
+ 111 just [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
+] unit-test
+
+[ nothing ] [
+ 111 just [ maybe-monad fail ] bind
+] unit-test
+
+[ 100 ] [
+ 5 either-monad return [ 10 * ] [ 20 * ] if-either
+] unit-test
+
+[ T{ left f "OOPS" } ] [
+ 5 either-monad return >>= [ drop "OOPS" either-monad fail ] swap call
+] unit-test
+
+[ { 10 20 30 } ] [
+ { 1 2 3 } [ 10 * ] fmap
+] unit-test
+
+[ { } ] [
+ { 1 2 3 } [ drop "OOPS" array-monad fail ] bind
+] unit-test
+
+[ 5 ] [
+ 5 state-monad return "initial state" run-st
+] unit-test
+
+[ 8 ] [
+ 5 state-monad return [ 3 + state-monad return ] bind
+ "initial state" run-st
+] unit-test
+
+[ 8 ] [
+ 5 state-monad return >>=
+ [ 3 + state-monad return ] swap call
+ "initial state" run-st
+] unit-test
+
+[ 11 ] [
+ f state-monad return >>=
+ [ drop get-st ] swap call
+ 11 run-st
+] unit-test
+
+[ 15 ] [
+ f state-monad return
+ [ drop get-st ] bind
+ [ 4 + put-st ] bind
+ [ drop get-st ] bind
+ 11 run-st
+] unit-test
+
+[ 15 ] [
+ {
+ [ f return-st ]
+ [ drop get-st ]
+ [ 4 + put-st ]
+ [ drop get-st ]
+ } do
+ 11 run-st
+] unit-test
+
+[ nothing ] [
+ {
+ [ "hi" just ]
+ [ " bye" append just ]
+ [ drop nothing ]
+ [ reverse just ]
+ } do
+] unit-test
+
+LAZY: nats-from ( n -- list )
+ dup 1+ nats-from cons ;
+
+: nats 0 nats-from ;
+
+[ 3 ] [
+ {
+ [ nats ]
+ [ dup 3 = [ list-monad return ] [ list-monad fail ] if ]
+ } do car
+] unit-test
+
+[ 9/11 ] [
+ {
+ [ ask ]
+ } do 9/11 run-reader
+] unit-test
+
+[ 8 ] [
+ {
+ [ ask ]
+ [ 3 + reader-monad return ]
+ } do
+ 5 run-reader
+] unit-test
+
+[ 6 ] [
+ f reader-monad return [ drop ask ] bind [ 1 + ] local 5 run-reader
+] unit-test
+
+[ f { 1 2 3 } ] [
+ 5 writer-monad return
+ [ drop { 1 2 3 } tell ] bind
+ run-writer
+] unit-test
+
+[ T{ identity f 7 } ]
+[
+ 4 identity-monad return
+ [ 3 + ] identity-monad return
+ identity-monad apply
+] unit-test
+
+[ nothing ] [
+ 5 just nothing maybe-monad apply
+] unit-test
+
+[ T{ just f 15 } ] [
+ 5 just [ 10 + ] just maybe-monad apply
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel sequences sequences.deep splitting
+accessors fry locals combinators namespaces lazy-lists
+shuffle ;
+IN: monads
+
+! Functors
+GENERIC# fmap 1 ( functor quot -- functor' ) inline
+
+! Monads
+
+! Mixin type for monad singleton classes, used for return/fail only
+MIXIN: monad
+
+GENERIC: monad-of ( mvalue -- singleton )
+GENERIC: return ( string singleton -- mvalue )
+GENERIC: fail ( value singleton -- mvalue )
+GENERIC: >>= ( mvalue -- quot )
+
+M: monad return monad-of return ;
+M: monad fail monad-of fail ;
+
+: bind ( mvalue quot -- mvalue' ) swap >>= call ;
+: >> ( mvalue k -- mvalue' ) '[ drop , ] bind ;
+
+:: lift-m2 ( m1 m2 f monad -- m3 )
+ m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
+
+:: apply ( mvalue mquot monad -- result )
+ mvalue [| value |
+ mquot [| quot |
+ value quot call monad return
+ ] bind
+ ] bind ;
+
+M: monad fmap over '[ @ , return ] bind ;
+
+! 'do' notation
+: do ( quots -- result ) unclip dip [ bind ] each ;
+
+! Identity
+SINGLETON: identity-monad
+INSTANCE: identity-monad monad
+
+TUPLE: identity value ;
+INSTANCE: identity monad
+
+M: identity monad-of drop identity-monad ;
+
+M: identity-monad return drop identity boa ;
+M: identity-monad fail "Fail" throw ;
+
+M: identity >>= value>> '[ , _ call ] ;
+
+: run-identity ( identity -- value ) value>> ;
+
+! Maybe
+SINGLETON: maybe-monad
+INSTANCE: maybe-monad monad
+
+SINGLETON: nothing
+
+TUPLE: just value ;
+: just \ just boa ;
+
+UNION: maybe just nothing ;
+INSTANCE: maybe monad
+
+M: maybe monad-of drop maybe-monad ;
+
+M: maybe-monad return drop just ;
+M: maybe-monad fail 2drop nothing ;
+
+M: nothing >>= '[ drop , ] ;
+M: just >>= value>> '[ , _ call ] ;
+
+: if-maybe ( maybe just-quot nothing-quot -- )
+ pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
+
+! Either
+SINGLETON: either-monad
+INSTANCE: either-monad monad
+
+TUPLE: left value ;
+: left \ left boa ;
+
+TUPLE: right value ;
+: right \ right boa ;
+
+UNION: either left right ;
+INSTANCE: either monad
+
+M: either monad-of drop either-monad ;
+
+M: either-monad return drop right ;
+M: either-monad fail drop left ;
+
+M: left >>= '[ drop , ] ;
+M: right >>= value>> '[ , _ call ] ;
+
+: if-either ( value left-quot right-quot -- )
+ [ [ value>> ] [ left? ] bi ] 2dip if ; inline
+
+! Arrays
+SINGLETON: array-monad
+INSTANCE: array-monad monad
+INSTANCE: array monad
+
+M: array-monad return drop 1array ;
+M: array-monad fail 2drop { } ;
+
+M: array monad-of drop array-monad ;
+
+M: array >>= '[ , _ map concat ] ;
+
+! List
+SINGLETON: list-monad
+INSTANCE: list-monad monad
+INSTANCE: list monad
+
+M: list-monad return drop 1list ;
+M: list-monad fail 2drop nil ;
+
+M: list monad-of drop list-monad ;
+
+M: list >>= '[ , _ lmap lconcat ] ;
+
+! State
+SINGLETON: state-monad
+INSTANCE: state-monad monad
+
+TUPLE: state quot ;
+: state \ state boa ;
+
+INSTANCE: state monad
+
+M: state monad-of drop state-monad ;
+
+M: state-monad return drop '[ , 2array ] state ;
+M: state-monad fail "Fail" throw ;
+
+: mcall quot>> call ;
+
+M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
+
+: get-st ( -- state ) [ dup 2array ] state ;
+: put-st ( value -- state ) '[ drop , f 2array ] state ;
+
+: run-st ( state initial -- ) swap mcall second ;
+
+: return-st state-monad return ;
+
+! Reader
+SINGLETON: reader-monad
+INSTANCE: reader-monad monad
+
+TUPLE: reader quot ;
+: reader \ reader boa ;
+INSTANCE: reader monad
+
+M: reader monad-of drop reader-monad ;
+
+M: reader-monad return drop '[ drop , ] reader ;
+M: reader-monad fail "Fail" throw ;
+
+M: reader >>= '[ , _ '[ dup , mcall @ mcall ] reader ] ;
+
+: run-reader ( reader env -- ) swap mcall ;
+
+: ask ( -- reader ) [ ] reader ;
+: local ( reader quot -- reader' ) swap '[ @ , mcall ] reader ;
+
+! Writer
+SINGLETON: writer-monad
+INSTANCE: writer-monad monad
+
+TUPLE: writer value log ;
+: writer \ writer boa ;
+
+M: writer monad-of drop writer-monad ;
+
+M: writer-monad return drop { } writer ;
+M: writer-monad fail "Fail" throw ;
+
+: run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
+
+M: writer >>= '[ , run-writer _ '[ @ run-writer ] dip append writer ] ;
+
+: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ;
+: listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
+: tell ( seq -- writer ) f swap writer ;
--- /dev/null
+Haskell-style monads
--- /dev/null
+extensions
--- /dev/null
+Alex Chapman
{ $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 } ;
+
+HELP: play-as-morse*
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
+{ $description "Plays a string as morse code" } ;
+
+HELP: play-as-morse
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
+{ $description "Plays a string as morse code" } ;
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
+[ ] [ "sos" 0.075 play-as-morse* ] unit-test
+[ ] [ "Factor rocks!" play-as-morse ] unit-test
! 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 ;
+USING: assocs combinators hashtables kernel lazy-lists math namespaces
+openal openal.waves parser-combinators promises sequences strings symbols
+unicode.case ;
IN: morse
<PRIVATE
<PRIVATE
-: dot ( -- ch ) CHAR: . ;
-: dash ( -- ch ) CHAR: - ;
-: char-gap ( -- ch ) CHAR: \s ;
-: word-gap ( -- ch ) CHAR: / ;
+: dot-char ( -- ch ) CHAR: . ;
+: dash-char ( -- ch ) CHAR: - ;
+: char-gap-char ( -- ch ) CHAR: \s ;
+: word-gap-char ( -- ch ) CHAR: / ;
: =parser ( obj -- parser )
[ = ] curry satisfy ;
LAZY: 'dot' ( -- parser )
- dot =parser ;
+ dot-char =parser ;
LAZY: 'dash' ( -- parser )
- dash =parser ;
+ dash-char =parser ;
LAZY: 'char-gap' ( -- parser )
- char-gap =parser ;
+ char-gap-char =parser ;
LAZY: 'word-gap' ( -- parser )
- word-gap =parser ;
+ word-gap-char =parser ;
LAZY: 'morse-char' ( -- parser )
'dot' 'dash' <|> <+> ;
] map >string
] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
+<PRIVATE
+SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
+
+: queue ( symbol -- )
+ get source get swap queue-buffer ;
+
+: dot ( -- ) dot-buffer queue ;
+: dash ( -- ) dash-buffer queue ;
+: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
+: letter-gap ( -- ) letter-gap-buffer queue ;
+
+: sine-buffer ( seconds -- id )
+ >r 8 22000 880 r> <sine-wave-buffer> send-buffer* ;
+
+: silent-buffer ( seconds -- id )
+ 8 22000 rot <silent-buffer> send-buffer* ;
+
+: make-buffers ( unit-length -- )
+ {
+ [ sine-buffer dot-buffer set ]
+ [ 3 * sine-buffer dash-buffer set ]
+ [ silent-buffer intra-char-gap-buffer set ]
+ [ 3 * silent-buffer letter-gap-buffer set ]
+ } cleave ;
+
+: playing-morse ( quot unit-length -- )
+ [
+ init-openal 1 gen-sources first source set make-buffers
+ call
+ source get source-play
+ ] with-scope ;
+
+: play-char ( ch -- )
+ [ intra-char-gap ] [
+ {
+ { dot-char [ dot ] }
+ { dash-char [ dash ] }
+ { word-gap-char [ intra-char-gap ] }
+ } case
+ ] interleave ;
+
+PRIVATE>
+
+: play-as-morse* ( str unit-length -- )
+ [
+ [ letter-gap ] [ ch>morse play-char ] interleave
+ ] swap playing-morse ;
+
+: play-as-morse ( str -- )
+ 0.05 play-as-morse* ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-message-next ( object message -- )
-over object-class class-methods 1 head* assoc-stack call ;
+over object-class class-methods but-last assoc-stack call ;
: <-~ scan parsed \ send-message-next parsed ; parsing
[
{
{ [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class< ] 2keep swap class< and ] [ +eq+ ] }
- { [ 2dup class< ] [ +lt+ ] }
- { [ 2dup swap class< ] [ +gt+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
[ +eq+ ]
} cond 2nip
- ] 2map [ zero? not ] find nip +eq+ or ;
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
: sort-methods ( alist -- alist' )
[ [ first ] bi@ classes< ] topological-sort ;
] [ ";" unexpected-eof ] if* ;
: parse-here ( -- str )
- [ (parse-here) ] "" make 1 head*
+ [ (parse-here) ] "" make but-last
lexer get next-line ;
: STRING:
[
lexer get lexer-column swap (parse-multiline-string)
lexer get set-lexer-column
- ] "" make rest 1 head* ;
+ ] "" make rest but-last ;
: <"
"\">" parse-multiline-string parsed ; parsing
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien system combinators alien.syntax namespaces
+USING: kernel arrays alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle combinators.lib
openal.backend ;
IN: openal
gen-buffer dup rot load-wav-file
[ alBufferData ] 4keep alutUnloadWAV ;
+: queue-buffers ( source buffers -- )
+ [ length ] [ >c-uint-array ] bi alSourceQueueBuffers ;
+
+: queue-buffer ( source buffer -- )
+ 1array queue-buffers ;
+
: set-source-param ( source param value -- )
alSourcei ;
--- /dev/null
+USING: kernel openal openal.waves sequences tools.test ;
+IN: openal.waves.tests
+
+
+[ ] [ 8 22000 440 1 play-sine-wave ] unit-test
--- /dev/null
+USING: accessors alien.c-types combinators kernel locals math
+math.constants math.functions math.ranges openal sequences ;
+IN: openal.waves
+
+TUPLE: buffer bits channels sample-freq seq id ;
+
+: <buffer> ( bits sample-freq seq -- buffer )
+ ! defaults to 1 channel
+ 1 -rot gen-buffer buffer boa ;
+
+: buffer-format ( buffer -- format )
+ dup buffer-channels 1 = swap buffer-bits 8 = [
+ AL_FORMAT_MONO8 AL_FORMAT_STEREO8
+ ] [
+ AL_FORMAT_MONO16 AL_FORMAT_STEREO16
+ ] if ? ;
+
+: buffer-data ( buffer -- data size )
+ #! 8 bit data is integers between 0 and 255,
+ #! 16 bit data is integers between -32768 and 32768
+ #! size is in bytes
+ [ seq>> ] [ bits>> ] bi 8 = [
+ [ 128 * >integer 128 + ] map [ >c-uchar-array ] [ length ] bi
+ ] [
+ [ 32768 * >integer ] map [ >c-short-array ] [ length 2 * ] bi
+ ] if ;
+
+: send-buffer ( buffer -- )
+ { [ id>> ] [ buffer-format ] [ buffer-data ] [ sample-freq>> ] } cleave
+ alBufferData ;
+
+: send-buffer* ( buffer -- id )
+ [ send-buffer ] [ id>> ] bi ;
+
+: (sine-wave-seq) ( samples/wave n-samples -- seq )
+ pi 2 * rot / [ * sin ] curry map ;
+
+: sine-wave-seq ( sample-freq freq seconds -- seq )
+ pick * >integer [ / ] dip (sine-wave-seq) ;
+
+: <sine-wave-buffer> ( bits sample-freq freq seconds -- buffer )
+ >r dupd r> sine-wave-seq <buffer> ;
+
+: <silent-buffer> ( bits sample-freq seconds -- buffer )
+ dupd * >integer [ drop 0 ] map <buffer> ;
+
+: play-sine-wave ( bits sample-freq freq seconds -- )
+ init-openal
+ <sine-wave-buffer> send-buffer*
+ 1 gen-sources first
+ [ AL_BUFFER rot set-source-param ] [ source-play ] bi
+ check-error ;
+
{ $description "Wrapper for " { $link glColor4d } " taking a color specifier." } ;
HELP: gl-error
-{ $description "If the most recent OpenGL call resulted in an error, print the error to the " { $link stdio } " stream." } ;
+{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
HELP: do-state
{
: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ;
-: scale-points 2array flip [ v* ] with map [ v+ ] with map ;
+: scale-points zip [ v* ] with map [ v+ ] with map ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
+++ /dev/null
-Elie Chaftari
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
-USING: alien alien.syntax combinators kernel system ;
-
-IN: openssl.libcrypto
-
-<<
-"libcrypto" {
- { [ os winnt? ] [ "libeay32.dll" "cdecl" ] }
- { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
- { [ os unix? ] [ "libcrypto.so" "cdecl" ] }
-} cond add-library
->>
-
-C-STRUCT: bio-method
- { "int" "type" }
- { "void*" "name" }
- { "void*" "bwrite" }
- { "void*" "bread" }
- { "void*" "bputs" }
- { "void*" "bgets" }
- { "void*" "ctrl" }
- { "void*" "create" }
- { "void*" "destroy" }
- { "void*" "callback-ctrl" } ;
-
-C-STRUCT: bio
- { "void*" "method" }
- { "void*" "callback" }
- { "void*" "cb-arg" }
- { "int" "init" }
- { "int" "shutdown" }
- { "int" "flags" }
- { "int" "retry-reason" }
- { "int" "num" }
- { "void*" "ptr" }
- { "void*" "next-bio" }
- { "void*" "prev-bio" }
- { "int" "references" }
- { "ulong" "num-read" }
- { "ulong" "num-write" }
- { "void*" "crypto-ex-data-stack" }
- { "int" "crypto-ex-data-dummy" } ;
-
-: BIO_NOCLOSE HEX: 00 ; inline
-: BIO_CLOSE HEX: 01 ; inline
-
-: RSA_3 HEX: 3 ; inline
-: RSA_F4 HEX: 10001 ; inline
-
-: BIO_C_SET_SSL 109 ; inline
-: BIO_C_GET_SSL 110 ; inline
-
-LIBRARY: libcrypto
-
-! ===============================================
-! bio.h
-! ===============================================
-
-FUNCTION: bio* BIO_new_file ( char* filename, char* mode ) ;
-
-FUNCTION: int BIO_printf ( bio* bio, char* format ) ;
-
-FUNCTION: long BIO_ctrl ( void* bio, int cmd, long larg, void* parg ) ;
-
-FUNCTION: void* BIO_new_socket ( int fd, int close-flag ) ;
-
-FUNCTION: void* BIO_new ( void* method ) ;
-
-FUNCTION: int BIO_set ( void* bio, void* method ) ;
-
-FUNCTION: int BIO_free ( void* bio ) ;
-
-FUNCTION: void* BIO_push ( void* bio, void* append ) ;
-
-FUNCTION: int BIO_read ( void* b, void* buf, int len ) ;
-
-FUNCTION: int BIO_gets ( void* b, char* buf, int size ) ;
-
-FUNCTION: int BIO_write ( void* b, void* buf, int len ) ;
-
-FUNCTION: int BIO_puts ( void* bp, char* buf ) ;
-
-FUNCTION: ulong ERR_get_error ( ) ;
-
-FUNCTION: char* ERR_error_string ( ulong e, void* buf ) ;
-
-FUNCTION: void* BIO_f_buffer ( ) ;
-
-! ===============================================
-! evp.h
-! ===============================================
-
-! Initialize ciphers and digest tables
-FUNCTION: void OpenSSL_add_all_ciphers ( ) ;
-
-FUNCTION: void OpenSSL_add_all_digests ( ) ;
-
-! Clean them up before exiting
-FUNCTION: void EVP_cleanup ( ) ;
-
-FUNCTION: void* EVP_get_digestbyname ( char* name ) ;
-
-FUNCTION: void EVP_MD_CTX_init ( void* ctx ) ;
-
-FUNCTION: void* PEM_read_bio_DHparams ( void* bp, void* x, void* cb,
- void* u ) ;
-
-! ===============================================
-! md5.h
-! ===============================================
-
-FUNCTION: uchar* MD5 ( uchar* d, ulong n, uchar* md ) ;
-
-! ===============================================
-! rsa.h
-! ===============================================
-
-FUNCTION: void* RSA_generate_key ( int num, ulong e, void* callback,
- void* cb_arg ) ;
-
-FUNCTION: int RSA_check_key ( void* rsa ) ;
-
-FUNCTION: void RSA_free ( void* rsa ) ;
-
-FUNCTION: int RSA_print_fp ( void* fp, void* x, int offset ) ;
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
-USING: alien alien.syntax combinators kernel system ;
-
-IN: openssl.libssl
-
-<< "libssl" {
- { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] }
- { [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ os unix? ] [ "libssl.so" "cdecl" ] }
-} cond add-library >>
-
-: X509_FILETYPE_PEM 1 ; inline
-: X509_FILETYPE_ASN1 2 ; inline
-: X509_FILETYPE_DEFAULT 3 ; inline
-
-: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
-: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
-
-: SSL_CTRL_NEED_TMP_RSA 1 ; inline
-: SSL_CTRL_SET_TMP_RSA 2 ; inline
-: SSL_CTRL_SET_TMP_DH 3 ; inline
-: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
-: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
-
-: SSL_ERROR_NONE 0 ; inline
-: SSL_ERROR_SSL 1 ; inline
-: SSL_ERROR_WANT_READ 2 ; inline
-: SSL_ERROR_WANT_WRITE 3 ; inline
-: SSL_ERROR_WANT_X509_LOOKUP 4 ; inline
-: SSL_ERROR_SYSCALL 5 ; inline ! consult errno for details
-: SSL_ERROR_ZERO_RETURN 6 ; inline
-: SSL_ERROR_WANT_CONNECT 7 ; inline
-: SSL_ERROR_WANT_ACCEPT 8 ; inline
-
-! Error messages table
-: error-messages ( -- hash )
- H{
- { 0 "SSL_ERROR_NONE" }
- { 1 "SSL_ERROR_SSL" }
- { 2 "SSL_ERROR_WANT_READ" }
- { 3 "SSL_ERROR_WANT_WRITE" }
- { 4 "SSL_ERROR_WANT_X509_LOOKUP" }
- { 5 "SSL_ERROR_SYSCALL" }
- { 6 "SSL_ERROR_ZERO_RETURN" }
- { 7 "SSL_ERROR_WANT_CONNECT" }
- { 8 "SSL_ERROR_WANT_ACCEPT" }
- } ;
-
-TYPEDEF: void* ssl-method
-TYPEDEF: void* ssl-ctx
-TYPEDEF: void* ssl-pointer
-
-LIBRARY: libssl
-
-! ===============================================
-! ssl.h
-! ===============================================
-
-FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ;
-
-! Maps OpenSSL errors to strings
-FUNCTION: void SSL_load_error_strings ( ) ;
-
-! Must be called before any other action takes place
-FUNCTION: int SSL_library_init ( ) ;
-
-! Sets the default SSL version
-FUNCTION: ssl-method SSLv2_client_method ( ) ;
-
-FUNCTION: ssl-method SSLv23_client_method ( ) ;
-
-FUNCTION: ssl-method SSLv23_server_method ( ) ;
-
-FUNCTION: ssl-method SSLv23_method ( ) ; ! SSLv3 but can rollback to v2
-
-FUNCTION: ssl-method SSLv3_client_method ( ) ;
-
-FUNCTION: ssl-method SSLv3_server_method ( ) ;
-
-FUNCTION: ssl-method SSLv3_method ( ) ;
-
-FUNCTION: ssl-method TLSv1_client_method ( ) ;
-
-FUNCTION: ssl-method TLSv1_server_method ( ) ;
-
-FUNCTION: ssl-method TLSv1_method ( ) ;
-
-! Creates the context
-FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
-
-! Load the certificates and private keys into the SSL_CTX
-FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
- char* file ) ; ! PEM type
-FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
-
-FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
-
-FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ;
-
-FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ;
-
-FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ;
-
-FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ;
-
-FUNCTION: int SSL_connect ( ssl-pointer ssl ) ;
-
-FUNCTION: int SSL_accept ( ssl-pointer ssl ) ;
-
-FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
-
-FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
-
-FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ;
-
-FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
-
-FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
-
-FUNCTION: void RAND_seed ( void* buf, int num ) ;
-
-FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ;
-
-FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ;
-
-FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ;
-
-FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
- char* str, int type ) ;
-
-FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
- char* CApath ) ;
-
-FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
-
-FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
-
-! Used to manipulate settings of the SSL_CTX and SSL objects.
-! This function should never be called directly
-FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ;
-
-FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ;
-
-FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx,
- void* u ) ;
-
-FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file,
- int type ) ;
-
-! Sets the maximum depth for the allowed ctx certificate chain verification
-FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ;
-
-! Sets DH parameters to be used to be dh.
-! The key is inherited by all ssl objects created from ctx
-FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ;
-
-FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
-
-FUNCTION: void* BIO_f_ssl ( ) ;
-
-! ===============================================
-! sha.h
-! ===============================================
-
-! For a high level interface to message digests
-! use the EVP digest routines in libcrypto.factor
-
-FUNCTION: uchar* SHA1 ( uchar* d, ulong n, uchar* md ) ;
+++ /dev/null
-
-USING: help.syntax help.markup ;
-
-IN: openssl
-
-ARTICLE: "openssl" "OpenSSL"
-
-"Factor on Windows has been tested with this version of OpenSSL: "
-
-{ $url "http://www.openssl.org/related/binaries.html" } ;
\ No newline at end of file
+++ /dev/null
-USING: alien alien.c-types alien.strings assocs bit-arrays
-hashtables io io.files io.encodings.ascii io.sockets kernel
-mirrors openssl.libcrypto openssl.libssl namespaces math
-math.parser openssl prettyprint sequences tools.test ;
-
-! =========================================================
-! Some crypto functions (still to be turned into words)
-! =========================================================
-
-[
- B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
-]
-[ "Hello world from the openssl binding" >md5 ] unit-test
-
-! Not found on netbsd, windows -- why?
-! [
- ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
- ! 82 115 0 }
-! ]
-! [ "Hello world from the openssl binding" >sha1 ] unit-test
-
-! =========================================================
-! Initialize context
-! =========================================================
-
-[ ] [ init load-error-strings ] unit-test
-
-[ ] [ ssl-v23 new-ctx ] unit-test
-
-[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
-
-! TODO: debug 'Memory protection fault at address 6c'
-! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
-
-[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
-
-! Enter PEM pass phrase: password
-[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
-SSL_FILETYPE_PEM use-private-key ] unit-test
-
-[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f
-verify-load-locations ] unit-test
-
-[ ] [ get-ctx 1 set-verify-depth ] unit-test
-
-! =========================================================
-! Load Diffie-Hellman parameters
-! =========================================================
-
-[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
-
-[ ] [ get-bio f f f read-pem-dh-params ] unit-test
-
-[ ] [ get-bio bio-free ] unit-test
-
-! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
-[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
-
-! Workaround (this function should never be called directly)
-! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
-
-! =========================================================
-! Generate ephemeral RSA key
-! =========================================================
-
-[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
-
-! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
-! get-ctx get-rsa set-tmp-rsa-callback
-
-! Workaround (this function should never be called directly)
-[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
-
-[ ] [ get-rsa free-rsa ] unit-test
-
-! =========================================================
-! Listen and accept on socket
-! =========================================================
-
-! SYMBOL: sock
-! SYMBOL: fdset
-! SYMBOL: acset
-! SYMBOL: sbio
-! SYMBOL: ssl
-!
-! : is-set ( seq -- newseq )
-! <enum> >alist [ nip ] assoc-filter >hashtable keys ;
-!
-! ! 1234 server-socket sock set
-! "127.0.0.1" 1234 <inet4> SOCK_STREAM server-fd sock set
-!
-! FD_SETSIZE 8 * <bit-array> fdset set
-!
-! FD_SETSIZE 8 * <bit-array> t 8 rot [ set-nth ] keep fdset set
-!
-! fdset get is-set .
-
-! : loop ( -- )
-! sock get f f accept
-! dup -1 = [ drop ] [
-! dup number>string print flush
-! ! BIO_NOCLOSE bio-new-socket sbio set
-! [ get-ctx new-ssl ssl set ] keep
-! ssl get swap set-ssl-fd
-! ! ssl get sbio get dup set-ssl-bio
-! ! ssl get ssl-accept
-! ! dup 0 <= [
-! ! ssl get swap ssl-get-error
-! ! ] [ drop ] if
-! ] if
-! loop ;
-
-! { } acset set
-!
-! : loop ( -- )
-! ! FD_SETSIZE fdset get f f f select . flush
-! FD_SETSIZE fdset get f f 10000 make-timeval select
-! 0 <= [ acset get [ close ] each "timeout" print ] [
-! fdset get is-set sock get swap member? [
-! sock get f f accept dup . flush
-! acset get swap add acset set
-! ] [ ] if
-! loop
-! ] if ;
-!
-! loop
-!
-! sock get close
-
-! =========================================================
-! Dump errors to file
-! =========================================================
-
-[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
-
-[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
-
-[ ] [ get-bio bio-free ] unit-test
-
-! =========================================================
-! Clean-up
-! =========================================================
-
-! sock get close
-
-get-ctx destroy-ctx
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-
-USING: alien alien.c-types alien.strings assocs kernel libc
-namespaces openssl.libcrypto openssl.libssl sequences
-io.encodings.ascii ;
-
-IN: openssl
-
-SYMBOL: bio
-SYMBOL: ssl-bio
-
-SYMBOL: ctx
-SYMBOL: dh
-SYMBOL: rsa
-
-! =========================================================
-! Callback routines
-! =========================================================
-
-: password-cb ( -- alien )
- "int" { "char*" "int" "int" "void*" } "cdecl"
- [ 3drop "password" ascii string>alien 1023 memcpy
- "password" length ] alien-callback ;
-
-! =========================================================
-! Error-handling routines
-! =========================================================
-
-: get-error ( -- num )
- ERR_get_error ;
-
-: error-string ( num -- str )
- f ERR_error_string ;
-
-: check-result ( result -- )
- 1 = [ ] [
- get-error error-string throw
- ] if ;
-
-: ssl-get-error ( ssl ret -- )
- SSL_get_error error-messages at throw ;
-
-! Write errors to a file
-: bio-new-file ( path mode -- )
- BIO_new_file bio set ;
-
-: bio-print ( bio str -- n )
- BIO_printf ;
-
-: bio-free ( bio -- )
- BIO_free check-result ;
-
-! =========================================================
-! Initialization routines
-! =========================================================
-
-: init ( -- )
- SSL_library_init drop ; ! always returns 1
-
-: load-error-strings ( -- )
- SSL_load_error_strings ;
-
-: ssl-v23 ( -- method )
- SSLv23_method ;
-
-: new-ctx ( method -- )
- SSL_CTX_new ctx set ;
-
-: use-cert-chain ( ctx file -- )
- SSL_CTX_use_certificate_chain_file check-result ;
-
-: set-default-passwd ( ctx cb -- )
- SSL_CTX_set_default_passwd_cb ;
-
-: set-default-passwd-userdata ( ctx passwd -- )
- SSL_CTX_set_default_passwd_cb_userdata ;
-
-: use-private-key ( ctx file type -- )
- SSL_CTX_use_PrivateKey_file check-result ;
-
-: verify-load-locations ( ctx file path -- )
- SSL_CTX_load_verify_locations check-result ;
-
-: set-verify-depth ( ctx depth -- )
- SSL_CTX_set_verify_depth ;
-
-: read-pem-dh-params ( bio x cb u -- )
- PEM_read_bio_DHparams dh set ;
-
-: set-tmp-dh-callback ( ctx dh -- )
- SSL_CTX_set_tmp_dh_callback ;
-
-: set-ctx-ctrl ( ctx cmd larg parg -- )
- SSL_CTX_ctrl check-result ;
-
-: generate-rsa-key ( n e cb cbarg -- )
- RSA_generate_key rsa set ;
-
-: set-tmp-rsa-callback ( ctx rsa -- )
- SSL_CTX_set_tmp_rsa_callback ;
-
-: free-rsa ( rsa -- )
- RSA_free ;
-
-: bio-new-socket ( fd flag -- sbio )
- BIO_new_socket ;
-
-: new-ssl ( ctx -- ssl )
- SSL_new ;
-
-: set-ssl-bio ( ssl bio bio -- )
- SSL_set_bio ;
-
-: set-ssl-fd ( ssl fd -- )
- SSL_set_fd check-result ;
-
-: ssl-accept ( ssl -- result )
- SSL_accept ;
-
-! =========================================================
-! Clean-up and termination routines
-! =========================================================
-
-: destroy-ctx ( ctx -- )
- SSL_CTX_free ;
-
-! =========================================================
-! Public routines
-! =========================================================
-
-: get-bio ( -- bio )
- bio get ;
-
-: get-ssl-bio ( -- bio )
- ssl-bio get ;
-
-: get-ctx ( -- ctx )
- ctx get ;
-
-: get-dh ( -- dh )
- dh get ;
-
-: get-rsa ( -- rsa )
- rsa get ;
-
-: >md5 ( str -- byte-array )
- dup length 16 "uchar" <c-array> [ MD5 ] keep nip ;
-
-: >sha1 ( str -- byte-array )
- dup length 20 "uchar" <c-array> [ SHA1 ] keep nip ;
-
+++ /dev/null
-OpenSSL binding
+++ /dev/null
-enterprise
-network
-bindings
+++ /dev/null
------BEGIN DH PARAMETERS-----
-MIGHAoGBANmAnfkETuKHOCWaE+W+F3kM/e7z5A8hZb7OqwGMQrUOaBEAr4BWeZBn
-G/87hhwZgNP69/KUchm714qd/PpOspCaUJ20x6PcmKujpAgca/f19HGMBjRawQMk
-R9oaBwazuQT0l0rTTKmvpMEcrQQIcVWii3CZI56I56oqF8biGPD7AgEC
------END DH PARAMETERS-----
+++ /dev/null
------BEGIN CERTIFICATE-----
-MIICIjCCAYugAwIBAgIBADANBgkqhkiG9w0BAQQFADBXMQswCQYDVQQGEwJVUzET
-MBEGA1UEChMKUlRGTSwgSW5jLjEZMBcGA1UECxMQV2lkZ2V0cyBEaXZpc2lvbjEY
-MBYGA1UEAxMPVGVzdCBDQTIwMDEwNTE3MB4XDTAxMDUxNzE2MDExNFoXDTA2MTIy
-NTE2MDExNFowVzELMAkGA1UEBhMCVVMxEzARBgNVBAoTClJURk0sIEluYy4xGTAX
-BgNVBAsTEFdpZGdldHMgRGl2aXNpb24xGDAWBgNVBAMTD1Rlc3QgQ0EyMDAxMDUx
-NzCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEAmkX40warmH0+lnwD9YjsJhRz
-ZX6qXadFry0y2trZ6gMs8Mv33IKPwOu8TE7V+3PESEtjI2wr8juV9OkbIPOm+td5
-M8+6vXyIW+JBo3ch99i0QMTf5/jTgsW+3IjV8yEdiGcZFp2NWKLRvZPq2VRbuF7R
-1pvgcaRuBJ0wGOohwnsCAwEAATANBgkqhkiG9w0BAQQFAAOBgQCUB8zMKIlX5io8
-TalbzH9Qke7BcvFAL+wp/5w1ToVsWkNrINSWKv6bl/jcqOD3aPhK7qhaeOU8ZWKL
-PoPPCnRl9Wo+1JtsOO3qIgJP79Bl9ooLGahixF2v/gea5qNISjQvwYllLSa//APP
-6kXHngO0RIRbiTBYHSkAzm6hDdsvVA==
------END CERTIFICATE-----
+++ /dev/null
------BEGIN RSA PRIVATE KEY-----
-Proc-Type: 4,ENCRYPTED
-DEK-Info: DES-EDE3-CBC,5772A2A7BE34B611
-
-1yJ+xAn4MudcIfXXy7ElYngJ9EohIh8yvcyVLmE4kVd0xeaL/Bqhvk25BjYCK5d9
-k1K8cjgnKEBjbC++0xtJxFSbUhwoKTLwn+sBoJDcFzMKkmJXXDbSTOaNr1sVwiAR
-SnB4lhUcHguYoV5zlRJn53ft7t1mjB6RwGH+d1Zx6t95OqM1lnKqwekwmotVAWHj
-ncu3N8qhmoPMppmzEv0fOo2/pK2WohcJykSeN5zBrZCUxoO0NBNEZkFUcVjR+KsA
-1ZeI1mU60szqg+AoU/XtFcow8RtG1QZKQbbXzyfbwaG+6LqkHaWYKHQEI1546yWK
-us1HJ734uUkZoyyyazG6PiGCYV2u/aY0i3qdmyDqTvmVIvve7E4glBrtDS9h7D40
-nPShIvOatoPzIK4Y0QSvrI3G1vTsIZT3IOZto4AWuOkLNfYS2ce7prOreF0KjhV0
-3tggw9pHdDmTjHTiIkXqheZxZ7TVu+pddZW+CuB62I8lCBGPW7os1f21e3eOD/oY
-YPCI44aJvgP+zUORuZBWqaSJ0AAIuVW9S83Yzkz/tlSFHViOebyd8Cug4TlxK1VI
-q6hbSafh4C8ma7YzlvqjMzqFifcIolcbx+1A6ot0UiayJTUra4d6Uc4Rbc9RIiG0
-jfDWC6aii9YkAgRl9WqSd31yASge/HDqVXFwR48qdlYQ57rcHviqxyrwRDnfw/lX
-Mf6LPiDKEco4MKej7SR2kK2c2AgxUzpGZeAY6ePyhxbdhA0eY21nDeFd/RbwSc5s
-eTiCCMr41OB4hfBFXKDKqsM3K7klhoz6D5WsgE6u3lDoTdz76xOSTg==
------END RSA PRIVATE KEY-----
------BEGIN CERTIFICATE-----
-MIICGDCCAYECAgEBMA0GCSqGSIb3DQEBBAUAMFcxCzAJBgNVBAYTAlVTMRMwEQYD
-VQQKEwpSVEZNLCBJbmMuMRkwFwYDVQQLExBXaWRnZXRzIERpdmlzaW9uMRgwFgYD
-VQQDEw9UZXN0IENBMjAwMTA1MTcwHhcNMDEwNTE3MTYxMDU5WhcNMDQwMzA2MTYx
-MDU5WjBRMQswCQYDVQQGEwJVUzETMBEGA1UEChMKUlRGTSwgSW5jLjEZMBcGA1UE
-CxMQV2lkZ2V0cyBEaXZpc2lvbjESMBAGA1UEAxMJbG9jYWxob3N0MIGfMA0GCSqG
-SIb3DQEBAQUAA4GNADCBiQKBgQCiWhMjNOPlPLNW4DJFBiL2fFEIkHuRor0pKw25
-J0ZYHW93lHQ4yxA6afQr99ayRjMY0D26pH41f0qjDgO4OXskBsaYOFzapSZtQMbT
-97OCZ7aHtK8z0ZGNW/cslu+1oOLomgRxJomIFgW1RyUUkQP1n0hemtUdCLOLlO7Q
-CPqZLQIDAQABMA0GCSqGSIb3DQEBBAUAA4GBAIumUwl1OoWuyN2xfoBHYAs+lRLY
-KmFLoI5+iMcGxWIsksmA+b0FLRAN43wmhPnums8eXgYbDCrKLv2xWcvKDP3mps7m
-AMivwtu/eFpYz6J8Mo1fsV4Ys08A/uPXkT23jyKo2hMu8mywkqXCXYF2e+7pEeBr
-dsbmkWK5NgoMl8eM
------END CERTIFICATE-----
[ 2 ] [
[ 2 "int" b, ] B{ } make
- <string-reader> [ "int" read-native ] with-stream
+ <string-reader> [ "int" read-native ] with-input-stream
] unit-test
[ "FRAM" ] [ "FRAM\0" [ read-c-string ] with-string-reader ] unit-test
MACRO: (unpack) ( str -- quot )
[
- \ <string-reader> ,
[
[ unpack-table at , \ , , ] each
] [ ] make
1quotation [ { } make ] append
1quotation %
- \ with-stream ,
+ \ with-string-reader ,
] [ ] make ;
: unpack-native ( seq str -- seq )
] 2each\r
" | " %\r
% \r
- " ] with-locals" % \r
+ " ]" % \r
] "" make \r
] if ;\r
\r
name>> % " [ dup ] " %\r
" | " %\r
% \r
- " ] with-locals" % \r
+ " ]" % \r
] "" make ;\r
\r
M: object build-locals ( code ast -- )\r
[ "hell" ] [ "hell" step5 "" like ] unit-test
[ "mate" ] [ "mate" step5 "" like ] unit-test
-: resource-lines resource-path utf8 file-lines ;
-
[ { } ] [
- "extra/porter-stemmer/test/voc.txt" resource-lines
+ "resource:extra/porter-stemmer/test/voc.txt" utf8 file-lines
[ stem ] map
- "extra/porter-stemmer/test/output.txt" resource-lines
+ "resource:extra/porter-stemmer/test/output.txt" utf8 file-lines
[ 2array ] 2map [ first2 = not ] filter
] unit-test
: r ( str oldsuffix newsuffix -- str )
pick consonant-seq 0 > [ nip ] [ drop ] if append ;
-: butlast ( seq -- seq ) 1 head-slice* ;
-
: step1a ( str -- newstr )
dup peek CHAR: s = [
{
{ [ "iz" ?tail ] [ "ize" append ] }
{
[ dup length 1- over double-consonant? ]
- [ dup "lsz" last-is? [ butlast ] unless ]
+ [ dup "lsz" last-is? [ but-last-slice ] unless ]
}
{
[ t ]
} cond ;
: step1c ( str -- newstr )
- dup butlast stem-vowel? [
+ dup but-last-slice stem-vowel? [
"y" ?tail [ "i" append ] when
] when ;
: remove-e? ( str -- ? )
dup consonant-seq dup 1 >
[ 2drop t ]
- [ 1 = [ butlast cvc? not ] [ drop f ] if ] if ;
+ [ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ;
: remove-e ( str -- newstr )
dup peek CHAR: e = [
- dup remove-e? [ butlast ] when
+ dup remove-e? [ but-last-slice ] when
] when ;
: ll->l ( str -- newstr )
{
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
- { [ dup consonant-seq 1 > ] [ butlast ] }
+ { [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
} cond ;
: fib-upto* ( n -- seq )
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
- 1 head-slice* { 0 1 } prepend ;
+ but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
1000000 fib-upto* [ even? ] filter sum ;
<PRIVATE
: source-022 ( -- seq )
- "extra/project-euler/022/names.txt" resource-path
+ "resource:extra/project-euler/022/names.txt"
ascii file-contents [ quotable? ] filter "," split ;
: name-scores ( seq -- seq )
<PRIVATE
: source-042 ( -- seq )
- "extra/project-euler/042/words.txt" resource-path
+ "resource:extra/project-euler/042/words.txt"
ascii file-contents [ quotable? ] filter "," split ;
: (triangle-upto) ( limit n -- )
<PRIVATE
: source-059 ( -- seq )
- "extra/project-euler/059/cipher1.txt" resource-path
+ "resource:extra/project-euler/059/cipher1.txt"
ascii file-contents [ blank? ] right-trim "," split
[ string>number ] map ;
frequency-analysis sort-values keys peek ;
: crack-key ( seq key-length -- key )
- [ " " decrypt ] dip group 1 head-slice*
+ [ " " decrypt ] dip group but-last-slice
flip [ most-frequent ] map ;
PRIVATE>
<PRIVATE
: source-067 ( -- seq )
- "extra/project-euler/067/triangle.txt" resource-path
+ "resource:extra/project-euler/067/triangle.txt"
ascii file-lines [ " " split [ string>number ] map ] map ;
PRIVATE>
<PRIVATE
: source-079 ( -- seq )
- "extra/project-euler/079/keylog.txt" resource-path ascii file-lines ;
+ "resource:extra/project-euler/079/keylog.txt" ascii file-lines ;
: >edges ( seq -- seq )
[
: file-read-unbuffered ( n path -- bytes )
over default-buffer-size [
- binary <file-reader> [ read ] with-stream
+ binary [ read ] with-file-reader
] with-variable ;
M: unix-random random-bytes* ( n tuple -- byte-array )
f
}
}
-} ] [ "extra/rss/rss1.xml" resource-path load-news-file ] unit-test
+} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
[ T{
feed
f
T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
}
}
-} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
+} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
--- /dev/null
+Alex Chapman
+++ /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 hashtables kernel sets
-semantic-db semantic-db.relations 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> ;
-
-: (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 prune ;
+++ /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 ;
-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 sorting tools.test
+USING: accessors arrays continuations db db.sqlite db.tuples io.files
+kernel math namespaces semantic-db sequences sorting tools.test
tools.walker ;
IN: semantic-db.tests
+SYMBOL: context
+
: 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
+ node create-table arc create-table
+ [ 1 ] [ "first node" create-node id>> ] unit-test
+ [ 2 ] [ "second node" create-node id>> ] unit-test
+ [ 3 ] [ "third node" create-node id>> ] unit-test
+ [ 4 ] [ f create-node id>> ] unit-test
+ [ ] [ 1 f <node> 2 f <node> 3 f <node> create-arc ] unit-test
+ [ { 1 2 3 4 } ] [ all-node-ids ] unit-test
+] with-db delete-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 ] bi@ 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 natural-sort >array ] unit-test
- [ { } ] [ "fran" get "charlie" get tuck un-parent-child parents [ node-content ] map ] unit-test
- ] with-context
-] with-db
-
-delete-db
+ test-db [
+ init-semantic-db
+ "test content" create-context context set
+ [ T{ node f 3 "test content" } ] [ context get ] unit-test
+ [ T{ node f 4 "is test content" } ] [ "is test content" context get create-relation ] unit-test
+ [ T{ node f 4 "is test content" } ] [ "is test content" context get get-relation ] unit-test
+ [ T{ node f 4 "is test content" } ] [ "is test content" context get ensure-relation ] unit-test
+ [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
+ [ T{ node f 5 "has parent" } ] [ "has parent" context get ensure-relation ] unit-test
+ [ "has parent" ] [ "has parent" context get ensure-relation node-content ] unit-test
+ [ "test content" ] [ context get node-content ] unit-test
+ ] with-db delete-db
+
+ ! "test1" "test1-relation-id-word" f f f f <relation-definition> define-relation
+ ! "test2" t t t t t <relation-definition> define-relation
+ RELATION: test3
+ test-db [
+ init-semantic-db
+ ! [ T{ node f 3 "test1" } ] [ test1-relation-id-word ] unit-test
+ ! [ T{ node f 4 "test2" } ] [ test2-relation ] unit-test
+ [ T{ node f 4 "test3" } ] [ test3-relation ] unit-test
+ ] with-db delete-db
+
+ ! test hierarchy
+ RELATION: has-parent
+ test-db [
+ init-semantic-db
+ "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
+ [ ] [ "bob" get "adam" get has-parent ] unit-test
+ { { "bob" "eve" } { "fran" "eve" } { "gertrude" "bob" } { "fran" "bob" } { "charlie" "fran" } } [ first2 [ get ] bi@ has-parent ] each
+ [ { "bob" "fran" } ] [ "eve" get has-parent-relation children [ node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ "bob" get has-parent-relation parents [ node-content ] map ] unit-test
+ [ "fran" { "charlie" } ] [ "fran" get has-parent-relation get-node-tree-s dup node>> node-content swap children>> [ node>> node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ "charlie" get has-parent-relation get-root-nodes [ node-content ] map natural-sort >array ] unit-test
+ [ { } ] [ "charlie" get dup "fran" get !has-parent has-parent-relation parents [ node-content ] map ] unit-test
+ [ { "adam" "eve" } ] [ has-parent-relation ultimate-objects node-results [ node-content ] map ] unit-test
+ [ { "fran" "gertrude" } ] [ has-parent-relation ultimate-subjects node-results [ node-content ] map ] unit-test
+ ] with-db delete-db
+
! 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 sequences ;
+USING: accessors arrays combinators combinators.cleave combinators.lib
+continuations db db.tuples db.types db.sqlite kernel math
+math.parser namespaces parser sets sequences sequences.deep
+sequences.lib strings words ;
IN: semantic-db
TUPLE: node id content ;
-: <node> ( content -- node )
- node new swap >>content ;
-
-: <id-node> ( id -- node )
- node new swap >>id ;
+C: <node> node
node "node"
{
{ "content" "content" TEXT }
} define-persistent
-: create-node-table ( -- )
- node create-table ;
-
-: delete-node ( node-id -- )
- <id-node> delete-tuples ;
+: delete-node ( node -- ) delete-tuples ;
+: create-node ( content -- node ) f swap <node> dup insert-tuple ;
+: load-node ( id -- node ) f <node> select-tuple ;
-: create-node* ( str -- node-id )
- <node> dup insert-tuple id>> ;
+: node-content ( node -- content )
+ dup content>> [ nip ] [ select-tuple content>> ] if* ;
-: create-node ( str -- )
- create-node* drop ;
+: node= ( node node -- ? ) [ id>> ] bi@ = ;
-: node-content ( id -- str )
- f <node> swap >>id select-tuple content>> ;
+! TODO: get rid of arc id and write our own sql
+TUPLE: arc id subject object relation ;
-TUPLE: arc id relation subject object ;
-
-: <arc> ( relation subject object -- arc )
- arc new swap >>object swap >>subject swap >>relation ;
+: <arc> ( subject object relation -- arc )
+ arc new swap >>relation swap >>object swap >>subject ;
: <id-arc> ( id -- arc )
arc new swap >>id ;
-: insert-arc ( arc -- )
- f <node> dup insert-tuple id>> >>id insert-tuple ;
+: delete-arc ( arc -- ) delete-tuples ;
+
+: create-arc ( subject object relation -- )
+ [ id>> ] 3apply <arc> insert-tuple ;
+
+: nodes>arc ( subject object relation -- arc )
+ [ [ id>> ] [ f ] if* ] 3apply <arc> ;
+
+: select-arcs ( subject object relation -- arcs )
+ nodes>arc select-tuples ;
+
+: has-arc? ( subject object relation -- ? )
+ select-arcs length 0 > ;
-: delete-arc ( arc-id -- )
- dup delete-node <id-arc> delete-tuples ;
+: select-arc-subjects ( subject object relation -- subjects )
+ select-arcs [ subject>> f <node> ] map ;
-: create-arc* ( relation subject object -- arc-id )
- <arc> dup insert-arc id>> ;
+: select-arc-subject ( subject object relation -- subject )
+ select-arcs ?first [ subject>> f <node> ] [ f ] if* ;
-: create-arc ( relation subject object -- )
- create-arc* drop ;
+: select-subjects ( object relation -- subjects )
+ f -rot select-arc-subjects ;
+
+: select-subject ( object relation -- subject )
+ f -rot select-arc-subject ;
+
+: select-arc-objects ( subject object relation -- objects )
+ select-arcs [ object>> f <node> ] map ;
+
+: select-arc-object ( subject object relation -- object )
+ select-arcs ?first [ object>> f <node> ] [ f ] if* ;
+
+: select-objects ( subject relation -- objects )
+ f swap select-arc-objects ;
+
+: select-object ( subject relation -- object )
+ f swap select-arc-object ;
+
+: delete-arcs ( subject object relation -- )
+ select-arcs [ delete-arc ] each ;
arc "arc"
{
- { "id" "id" INTEGER +user-assigned-id+ } ! foreign key to node table?
+ { "id" "id" +db-assigned-id+ +autoincrement+ }
{ "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" create-node drop
+ "has-context" create-node drop ;
-: semantic-db-context 1 ;
-: has-context-relation 2 ;
+: semantic-db-context T{ node f 1 "semantic-db" } ;
+: has-context-relation T{ node f 2 "has-context" } ;
: create-bootstrap-arcs ( -- )
- has-context-relation has-context-relation semantic-db-context create-arc ;
+ has-context-relation semantic-db-context has-context-relation create-arc ;
: init-semantic-db ( -- )
- create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
+ node create-table arc create-table
+ create-bootstrap-nodes create-bootstrap-arcs ;
+
+! db utilities
+: results ( bindings sql -- array )
+ f f <simple-statement> [ do-bound-query ] with-disposal ;
+
+: node-result ( result -- node )
+ dup first string>number swap second <node> ;
+
+: ?1node-result ( results -- node )
+ ?first [ node-result ] [ f ] if* ;
+
+: node-results ( results -- nodes )
+ [ node-result ] map ;
: param ( value key type -- param )
swapd <sqlite-low-level-binding> ;
-: single-int-results ( bindings sql -- array )
- f f <simple-statement> [ do-bound-query ] with-disposal
- [ first string>number ] map ;
+: all-node-ids ( -- seq )
+ f "select n.id from node n" results [ first string>number ] map ;
+
+: subjects-with-cor ( content object relation -- sql-results )
+ [ id>> ] bi@
+ [
+ ":relation" INTEGER param ,
+ ":object" INTEGER param ,
+ ":content" TEXT param ,
+ ] { } make
+ "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.subject and a.relation = :relation and a.object = :object" results ;
+
+: objects-with-csr ( content subject relation -- sql-results )
+ [ id>> ] bi@
+ [
+ ":relation" INTEGER param ,
+ ":subject" INTEGER param ,
+ ":content" TEXT param ,
+ ] { } make
+ "select n.id, n.content from node n, arc a where n.content = :content and n.id = a.object and a.relation = :relation and a.subject = :subject" results ;
+
+: (with-relation) ( content relation -- bindings sql )
+ id>> [ ":relation" INTEGER param , ":content" TEXT param , ] { } make
+ "select distinct n.id, n.content from node n, arc a where n.content = :content and a.relation = :relation" ;
+
+: subjects-with-relation ( content relation -- sql-results )
+ (with-relation) " and a.object = n.id" append results ;
+
+: objects-with-relation ( content relation -- sql-results )
+ (with-relation) " and a.subject = n.id" append results ;
+
+: (ultimate) ( relation b a -- sql-results )
+ [
+ "select distinct n.id, n.content from node n, arc a where a.relation = :relation and n.id = a." % % " and n.id not in (select b." % % " from arc b where b.relation = :relation)" %
+ ] "" make [ id>> ":relation" INTEGER param 1array ] dip results ;
+
+: ultimate-objects ( relation -- sql-results )
+ "subject" "object" (ultimate) ;
+
+: ultimate-subjects ( relation -- sql-results )
+ "object" "subject" (ultimate) ;
+
+! contexts:
+! - a node n is a context iff there exists a relation r such that r has context n
+: create-context ( context-name -- context ) create-node ;
+
+: get-context ( context-name -- context/f )
+ has-context-relation subjects-with-relation ?1node-result ;
+
+: ensure-context ( context-name -- context )
+ dup get-context [
+ nip
+ ] [
+ create-context
+ ] if* ;
+
+! relations:
+! - have a context in context 'semantic-db'
+
+: create-relation ( relation-name context -- relation )
+ [ create-node dup ] dip has-context-relation create-arc ;
+
+: get-relation ( relation-name context -- relation/f )
+ has-context-relation subjects-with-cor ?1node-result ;
+
+: ensure-relation ( relation-name context -- relation )
+ 2dup get-relation [
+ 2nip
+ ] [
+ create-relation
+ ] if* ;
+
+TUPLE: relation-definition relate id-word unrelate related? subjects objects ;
+C: <relation-definition> relation-definition
+
+<PRIVATE
+
+: default-word-name ( relate-word-name word-type -- word-name )
+ {
+ { "relate" [ ] }
+ { "id-word" [ "-relation" append ] }
+ { "unrelate" [ "!" swap append ] }
+ { "related?" [ "?" append ] }
+ { "subjects" [ "-subjects" append ] }
+ { "objects" [ "-objects" append ] }
+ } case ;
+
+: choose-word-name ( relation-definition given-word-name word-type -- word-name )
+ over string? [
+ drop nip
+ ] [
+ nip [ relate>> ] dip default-word-name
+ ] if ;
+
+: (define-relation-word) ( id-word word-name definition -- id-word )
+ >r create-in over [ execute ] curry r> compose define ;
+
+: define-relation-word ( relation-definition id-word given-word-name word-type definition -- relation-definition id-word )
+ >r >r [
+ pick swap r> choose-word-name r> (define-relation-word)
+ ] [
+ r> r> 2drop
+ ] if* ;
+
+: define-relation-words ( relation-definition id-word -- )
+ over relate>> "relate" [ create-arc ] define-relation-word
+ over unrelate>> "unrelate" [ delete-arcs ] define-relation-word
+ over related?>> "related?" [ has-arc? ] define-relation-word
+ over subjects>> "subjects" [ select-subjects ] define-relation-word
+ over objects>> "objects" [ select-objects ] define-relation-word
+ 2drop ;
+
+: define-id-word ( relation-definition id-word -- )
+ [ relate>> ] dip tuck word-vocabulary
+ [ ensure-context ensure-relation ] 2curry define ;
+
+: create-id-word ( relation-definition -- id-word )
+ dup id-word>> "id-word" choose-word-name create-in ;
+
+PRIVATE>
+
+: define-relation ( relation-definition -- )
+ dup create-id-word 2dup define-id-word define-relation-words ;
+
+: RELATION:
+ scan t t t t t <relation-definition> define-relation ; parsing
+
+! hierarchy
+TUPLE: node-tree node children ;
+C: <node-tree> node-tree
+
+: children ( node has-parent-relation -- children ) select-subjects ;
+: parents ( node has-parent-relation -- parents ) select-objects ;
+
+: get-node-tree ( node child-selector -- node-tree )
+ 2dup call >r [ get-node-tree ] curry r> swap map <node-tree> ;
+
+! : get-node-tree ( node has-parent-relation -- node-tree )
+! 2dup children >r [ get-node-tree ] curry r> swap map <node-tree> ;
+: get-node-tree-s ( node has-parent-relation -- tree )
+ [ select-subjects ] curry get-node-tree ;
+
+: get-node-tree-o ( node has-child-relation -- tree )
+ [ select-objects ] curry get-node-tree ;
+
+: (get-node-chain) ( node next-selector seq -- seq )
+ pick [
+ over push >r [ call ] keep r> (get-node-chain)
+ ] [
+ 2nip
+ ] if* ;
+
+: get-node-chain ( node next-selector -- seq )
+ V{ } clone (get-node-chain) ;
+
+: get-node-chain-o ( node relation -- seq )
+ [ select-object ] curry get-node-chain ;
+
+: get-node-chain-s ( node relation -- seq )
+ [ select-subject ] curry get-node-chain ;
+
+: (get-root-nodes) ( node has-parent-relation -- root-nodes/node )
+ 2dup parents dup empty? [
+ 2drop
+ ] [
+ >r nip [ (get-root-nodes) ] curry r> swap map
+ ] if ;
-: 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* ;
+: get-root-nodes ( node has-parent-relation -- root-nodes )
+ (get-root-nodes) flatten prune ;
IN: shuffle
+: 2dip -rot 2slip ; inline
+
MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ;
{ "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
+ exe ascii <process-reader> contents string>number ;
\ No newline at end of file
! 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 ;
+sequences namespaces io.sockets continuations calendar
+io.encodings.ascii io.streams.duplex ;
IN: smtp.server
! Mock SMTP server for testing purposes.
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> ascii <server> [
accept drop [
- 1 minutes stdio get set-timeout
+ 1 minutes timeouts
"220 hello\r\n" write flush
process
global [ flush ] bind
: with-smtp-connection ( quot -- )
smtp-server get
dup log-smtp-connection
- ascii <client> [
+ ascii [
smtp-domain [ host-name or ] change
- read-timeout get stdio get set-timeout
+ read-timeout get timeouts
call
- ] with-stream ; inline
+ ] with-client ; inline
: crlf "\r\n" write ;
: init-sound ( index cpu filename -- )
swapd >r space-invaders-sounds nth AL_BUFFER r>
- resource-path create-buffer-from-wav set-source-param ;
+ create-buffer-from-wav set-source-param ;
: init-sounds ( cpu -- )
init-openal
[ 9 gen-sources swap set-space-invaders-sounds ] keep
- [ SOUND-SHOT "extra/space-invaders/resources/Shot.wav" init-sound ] keep
- [ SOUND-UFO "extra/space-invaders/resources/Ufo.wav" init-sound ] keep
+ [ SOUND-SHOT "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep
+ [ SOUND-UFO "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep
[ space-invaders-sounds SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
- [ SOUND-BASE-HIT "extra/space-invaders/resources/BaseHit.wav" init-sound ] keep
- [ SOUND-INVADER-HIT "extra/space-invaders/resources/InvHit.wav" init-sound ] keep
- [ SOUND-WALK1 "extra/space-invaders/resources/Walk1.wav" init-sound ] keep
- [ SOUND-WALK2 "extra/space-invaders/resources/Walk2.wav" init-sound ] keep
- [ SOUND-WALK3 "extra/space-invaders/resources/Walk3.wav" init-sound ] keep
- [ SOUND-WALK4 "extra/space-invaders/resources/Walk4.wav" init-sound ] keep
- [ SOUND-UFO-HIT "extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
+ [ SOUND-BASE-HIT "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep
+ [ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep
+ [ SOUND-WALK1 "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep
+ [ SOUND-WALK2 "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep
+ [ SOUND-WALK3 "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep
+ [ SOUND-WALK4 "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep
+ [ SOUND-UFO-HIT "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
f swap set-space-invaders-looping? ;
: <space-invaders> ( -- cpu )
{ $description "originally written as " { $code "spot inc" } ", code that would no longer run, this word moves the state of the XML parser to the next place in the source file, keeping track of appropriate debugging information." } ;
HELP: parsing-error
-{ $class-description "class to which parsing errors delegate, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;
+{ $class-description "class from which parsing errors inherit, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;
! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: io io.streams.string kernel math namespaces sequences\r
-strings circular prettyprint debugger ascii ;\r
+strings circular prettyprint debugger ascii sbufs fry inspector\r
+accessors sequences.lib ;\r
IN: state-parser\r
\r
! * Basic underlying words\r
\r
C: <spot> spot\r
\r
-: get-char ( -- char ) spot get spot-char ;\r
-: set-char ( char -- ) spot get set-spot-char ;\r
-: get-line ( -- line ) spot get spot-line ;\r
-: set-line ( line -- ) spot get set-spot-line ;\r
-: get-column ( -- column ) spot get spot-column ;\r
-: set-column ( column -- ) spot get set-spot-column ;\r
-: get-next ( -- char ) spot get spot-next ;\r
-: set-next ( char -- ) spot get set-spot-next ;\r
+: get-char ( -- char ) spot get char>> ;\r
+: set-char ( char -- ) spot get swap >>char drop ;\r
+: get-line ( -- line ) spot get line>> ;\r
+: set-line ( line -- ) spot get swap >>line drop ;\r
+: get-column ( -- column ) spot get column>> ;\r
+: set-column ( column -- ) spot get swap >>column drop ;\r
+: get-next ( -- char ) spot get next>> ;\r
+: set-next ( char -- ) spot get swap >>next drop ;\r
\r
! * Errors\r
TUPLE: parsing-error line column ;\r
-: <parsing-error> ( -- parsing-error )\r
- get-line get-column parsing-error boa ;\r
-\r
-: construct-parsing-error ( ... slots class -- error )\r
- construct <parsing-error> over set-delegate ; inline\r
-\r
-: parsing-error. ( parsing-error -- )\r
- "Parsing error" print\r
- "Line: " write dup parsing-error-line .\r
- "Column: " write parsing-error-column . ;\r
-\r
-TUPLE: expected should-be was ;\r
-: <expected> ( should-be was -- error )\r
- { set-expected-should-be set-expected-was }\r
- expected construct-parsing-error ;\r
-M: expected error.\r
- dup parsing-error.\r
- "Token expected: " write dup expected-should-be print\r
- "Token present: " write expected-was print ;\r
-\r
-TUPLE: unexpected-end ;\r
-: <unexpected-end> ( -- unexpected-end )\r
- { } unexpected-end construct-parsing-error ;\r
-M: unexpected-end error.\r
- parsing-error.\r
- "File unexpectedly ended." print ;\r
-\r
-TUPLE: missing-close ;\r
-: <missing-close> ( -- missing-close )\r
- { } missing-close construct-parsing-error ;\r
-M: missing-close error.\r
- parsing-error.\r
- "Missing closing token." print ;\r
+\r
+: parsing-error ( class -- obj )\r
+ new\r
+ get-line >>line\r
+ get-column >>column ;\r
+M: parsing-error summary ( obj -- str )\r
+ [\r
+ "Parsing error" print\r
+ "Line: " write dup line>> .\r
+ "Column: " write column>> .\r
+ ] with-string-writer ;\r
+\r
+TUPLE: expected < parsing-error should-be was ;\r
+: expected ( should-be was -- * )\r
+ \ expected parsing-error\r
+ swap >>was\r
+ swap >>should-be throw ;\r
+M: expected summary ( obj -- str )\r
+ [\r
+ dup call-next-method write\r
+ "Token expected: " write dup should-be>> print\r
+ "Token present: " write was>> print\r
+ ] with-string-writer ;\r
+\r
+TUPLE: unexpected-end < parsing-error ;\r
+: unexpected-end \ unexpected-end parsing-error throw ;\r
+M: unexpected-end summary ( obj -- str )\r
+ [\r
+ call-next-method write\r
+ "File unexpectedly ended." print\r
+ ] with-string-writer ;\r
+\r
+TUPLE: missing-close < parsing-error ;\r
+: missing-close \ missing-close parsing-error throw ;\r
+M: missing-close summary ( obj -- str )\r
+ [\r
+ call-next-method write\r
+ "Missing closing token." print\r
+ ] with-string-writer ;\r
\r
SYMBOL: prolog-data\r
\r
[ 0 get-line 1+ set-line ] [ get-column 1+ ] if\r
set-column ;\r
\r
-: (next) ( -- char ) ! this normalizes \r\n and \r\r
+! (next) normalizes \r\n and \r\r
+: (next) ( -- char )\r
get-next read1\r
2dup swap CHAR: \r = [\r
CHAR: \n =\r
\r
: next ( -- )\r
#! Increment spot.\r
- get-char [\r
- <unexpected-end> throw\r
- ] unless\r
- (next) record ;\r
+ get-char [ unexpected-end ] unless (next) record ;\r
\r
: next* ( -- )\r
get-char [ (next) record ] when ;\r
#! Take the substring of a string starting at spot\r
#! from code until the quotation given is true and\r
#! advance spot to after the substring.\r
- [ [\r
- dup slip swap dup [ get-char , ] unless\r
- ] skip-until ] "" make nip ; inline\r
+ 10 <sbuf> [\r
+ '[ @ [ t ] [ get-char , push f ] if ] skip-until\r
+ ] keep >string ; inline\r
\r
: take-rest ( -- string )\r
[ f ] take-until ;\r
: take-char ( ch -- string )\r
[ dup get-char = ] take-until nip ;\r
\r
+TUPLE: not-enough-characters < parsing-error ;\r
+: not-enough-characters\r
+ \ not-enough-characters parsing-error throw ;\r
+M: not-enough-characters summary ( obj -- str )\r
+ [\r
+ call-next-method write\r
+ "Not enough characters" print\r
+ ] with-string-writer ;\r
+\r
+: take ( n -- string )\r
+ [ 1- ] [ <sbuf> ] bi [\r
+ '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop\r
+ ] keep get-char [ over push ] when* >string ;\r
+\r
: pass-blank ( -- )\r
#! Advance code past any whitespace, including newlines\r
[ get-char blank? not ] skip-until ;\r
dup length <circular-string>\r
[ 2dup string-matches? ] take-until nip\r
dup length rot length 1- - head\r
- get-char [ <missing-close> throw ] unless next ;\r
+ get-char [ missing-close ] unless next ;\r
\r
: expect ( ch -- )\r
get-char 2dup = [ 2drop ] [\r
- >r 1string r> 1string <expected> throw\r
+ >r 1string r> 1string expected\r
] if next ;\r
\r
: expect-string ( string -- )\r
dup [ drop get-char next ] map 2dup =\r
- [ 2drop ] [ <expected> throw ] if ;\r
+ [ 2drop ] [ expected ] if ;\r
\r
: init-parser ( -- )\r
0 1 0 f <spot> spot set\r
read1 set-next next ;\r
\r
: state-parse ( stream quot -- )\r
- ! with-stream implicitly creates a new scope which we use\r
- swap [ init-parser call ] with-stream ; inline\r
+ ! with-input-stream implicitly creates a new scope which we use\r
+ swap [ init-parser call ] with-input-stream ; inline\r
\r
: string-parse ( input quot -- )\r
>r <string-reader> r> state-parse ; inline\r
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: html kernel semantic-db tangle.html tools.test ;
+IN: tangle.html.tests
+
+[ "test" ] [ "test" >html ] unit-test
+[ "<ul><li>An Item</li></ul>" ] [ { "An Item" } <ulist> >html ] unit-test
+[ "<ul><li>One</li><li>Two</li><li>Three, ah ah ah</li></ul>" ] [ { "One" "Two" "Three, ah ah ah" } <ulist> >html ] unit-test
+[ "<a href='foo/bar'>some link</a>" ] [ "foo/bar" "some link" <link> >html ] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
+IN: tangle.html
+
+TUPLE: element attributes ;
+
+TUPLE: ulist < element items ;
+: <ulist> ( items -- element )
+ H{ } clone swap ulist boa ;
+
+TUPLE: link < element href text ;
+: <link> ( href text -- element )
+ H{ } clone -rot link boa ;
+
+GENERIC: >html ( element -- str )
+
+M: string >html ( str -- str ) ;
+
+M: link >html ( link -- str )
+ [ <a dup href>> =href a> text>> write </a> ] with-string-writer ;
+
+M: node >html ( node -- str )
+ dup node>path [
+ swap node-content <link> >html
+ ] [
+ node-content
+ ] if* ;
+
+M: ulist >html ( ulist -- str )
+ [
+ <ul> items>> [ <li> >html write </li> ] each </ul>
+ ] with-string-writer ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel semantic-db sequences tangle.html ;
+IN: tangle.menu
+
+RELATION: subitem-of
+RELATION: before
+
+: get-menus ( -- nodes )
+ subitem-of-relation ultimate-objects node-results ;
+
+: get-menu ( name -- node )
+ get-menus [ node-content = ] with find nip ;
+
+: ensure-menu ( name -- node )
+ dup get-menu [ nip ] [ create-node ] if* ;
+
+: load-menu ( name -- menu )
+ get-menu subitem-of-relation get-node-tree-s ;
+
+: menu>ulist ( menu -- str ) children>> <ulist> ;
+: menu>html ( menu -- str ) menu>ulist >html ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel semantic-db sequences sequences.lib ;
+IN: tangle.page
+
+RELATION: has-abbreviation
+RELATION: has-content
+RELATION: has-subsection
+RELATION: before
+RELATION: authored-by
+RELATION: authored-on
+
+TUPLE: page name abbreviation author created content ;
+C: <page> page
+
+: load-page-content ( node -- content )
+ has-content-objects [ node-content ] map concat ;
+
+: load-page ( node -- page )
+ dup [ has-abbreviation-objects ?first ] keep
+ [ authored-by-objects ?first ] keep
+ [ authored-on-objects ?first ] keep
+ load-page-content <page> ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel semantic-db sequences sequences.lib splitting ;
+IN: tangle.path
+
+RELATION: has-filename
+RELATION: in-directory
+
+: create-root ( -- node ) "" create-node ;
+
+: get-root ( -- node )
+ in-directory-relation ultimate-objects ?1node-result ;
+
+: ensure-root ( -- node ) get-root [ create-root ] unless* ;
+
+: create-file ( parent name -- node )
+ create-node swap dupd in-directory ;
+
+: files-in-directory ( node -- nodes ) in-directory-subjects ;
+
+: file-in-directory ( name node -- node )
+ in-directory-relation subjects-with-cor ?1node-result ;
+
+: parent-directory ( file-node -- dir-node )
+ in-directory-objects ?first ;
+
+: (path>node) ( node name -- node )
+ swap [ file-in-directory ] [ drop f ] if* ;
+
+: path>node ( path -- node )
+ ensure-root swap [ (path>node) ] each ;
+
+: path>file ( path -- file )
+ path>node [ has-filename-subjects ?first ] [ f ] if* ;
+
+: (node>path) ( root seq node -- seq )
+ pick over node= [
+ drop nip
+ ] [
+ dup node-content pick push
+ parent-directory [
+ (node>path)
+ ] [
+ 2drop f
+ ] if*
+ ] if ;
+
+: node>path* ( root node -- path )
+ V{ } clone swap (node>path) dup empty?
+ [ drop f ] [ <reversed> ] if ;
+
+: node>path ( node -- path )
+ ensure-root swap node>path* ;
+
+: file>path ( node -- path )
+ has-filename-objects ?first [ node>path ] [ f ] if* ;
--- /dev/null
+/*
+ * jQuery 1.2.3 - New Wave Javascript
+ *
+ * Copyright (c) 2008 John Resig (jquery.com)
+ * Dual licensed under the MIT (MIT-LICENSE.txt)
+ * and GPL (GPL-LICENSE.txt) licenses.
+ *
+ * $Date: 2008-02-06 00:21:25 -0500 (Wed, 06 Feb 2008) $
+ * $Rev: 4663 $
+ */
+(function(){if(window.jQuery)var _jQuery=window.jQuery;var jQuery=window.jQuery=function(selector,context){return new jQuery.prototype.init(selector,context);};if(window.$)var _$=window.$;window.$=jQuery;var quickExpr=/^[^<]*(<(.|\s)+>)[^>]*$|^#(\w+)$/;var isSimple=/^.[^:#\[\.]*$/;jQuery.fn=jQuery.prototype={init:function(selector,context){selector=selector||document;if(selector.nodeType){this[0]=selector;this.length=1;return this;}else if(typeof selector=="string"){var match=quickExpr.exec(selector);if(match&&(match[1]||!context)){if(match[1])selector=jQuery.clean([match[1]],context);else{var elem=document.getElementById(match[3]);if(elem)if(elem.id!=match[3])return jQuery().find(selector);else{this[0]=elem;this.length=1;return this;}else
+selector=[];}}else
+return new jQuery(context).find(selector);}else if(jQuery.isFunction(selector))return new jQuery(document)[jQuery.fn.ready?"ready":"load"](selector);return this.setArray(selector.constructor==Array&&selector||(selector.jquery||selector.length&&selector!=window&&!selector.nodeType&&selector[0]!=undefined&&selector[0].nodeType)&&jQuery.makeArray(selector)||[selector]);},jquery:"1.2.3",size:function(){return this.length;},length:0,get:function(num){return num==undefined?jQuery.makeArray(this):this[num];},pushStack:function(elems){var ret=jQuery(elems);ret.prevObject=this;return ret;},setArray:function(elems){this.length=0;Array.prototype.push.apply(this,elems);return this;},each:function(callback,args){return jQuery.each(this,callback,args);},index:function(elem){var ret=-1;this.each(function(i){if(this==elem)ret=i;});return ret;},attr:function(name,value,type){var options=name;if(name.constructor==String)if(value==undefined)return this.length&&jQuery[type||"attr"](this[0],name)||undefined;else{options={};options[name]=value;}return this.each(function(i){for(name in options)jQuery.attr(type?this.style:this,name,jQuery.prop(this,options[name],type,i,name));});},css:function(key,value){if((key=='width'||key=='height')&&parseFloat(value)<0)value=undefined;return this.attr(key,value,"curCSS");},text:function(text){if(typeof text!="object"&&text!=null)return this.empty().append((this[0]&&this[0].ownerDocument||document).createTextNode(text));var ret="";jQuery.each(text||this,function(){jQuery.each(this.childNodes,function(){if(this.nodeType!=8)ret+=this.nodeType!=1?this.nodeValue:jQuery.fn.text([this]);});});return ret;},wrapAll:function(html){if(this[0])jQuery(html,this[0].ownerDocument).clone().insertBefore(this[0]).map(function(){var elem=this;while(elem.firstChild)elem=elem.firstChild;return elem;}).append(this);return this;},wrapInner:function(html){return this.each(function(){jQuery(this).contents().wrapAll(html);});},wrap:function(html){return this.each(function(){jQuery(this).wrapAll(html);});},append:function(){return this.domManip(arguments,true,false,function(elem){if(this.nodeType==1)this.appendChild(elem);});},prepend:function(){return this.domManip(arguments,true,true,function(elem){if(this.nodeType==1)this.insertBefore(elem,this.firstChild);});},before:function(){return this.domManip(arguments,false,false,function(elem){this.parentNode.insertBefore(elem,this);});},after:function(){return this.domManip(arguments,false,true,function(elem){this.parentNode.insertBefore(elem,this.nextSibling);});},end:function(){return this.prevObject||jQuery([]);},find:function(selector){var elems=jQuery.map(this,function(elem){return jQuery.find(selector,elem);});return this.pushStack(/[^+>] [^+>]/.test(selector)||selector.indexOf("..")>-1?jQuery.unique(elems):elems);},clone:function(events){var ret=this.map(function(){if(jQuery.browser.msie&&!jQuery.isXMLDoc(this)){var clone=this.cloneNode(true),container=document.createElement("div");container.appendChild(clone);return jQuery.clean([container.innerHTML])[0];}else
+return this.cloneNode(true);});var clone=ret.find("*").andSelf().each(function(){if(this[expando]!=undefined)this[expando]=null;});if(events===true)this.find("*").andSelf().each(function(i){if(this.nodeType==3)return;var events=jQuery.data(this,"events");for(var type in events)for(var handler in events[type])jQuery.event.add(clone[i],type,events[type][handler],events[type][handler].data);});return ret;},filter:function(selector){return this.pushStack(jQuery.isFunction(selector)&&jQuery.grep(this,function(elem,i){return selector.call(elem,i);})||jQuery.multiFilter(selector,this));},not:function(selector){if(selector.constructor==String)if(isSimple.test(selector))return this.pushStack(jQuery.multiFilter(selector,this,true));else
+selector=jQuery.multiFilter(selector,this);var isArrayLike=selector.length&&selector[selector.length-1]!==undefined&&!selector.nodeType;return this.filter(function(){return isArrayLike?jQuery.inArray(this,selector)<0:this!=selector;});},add:function(selector){return!selector?this:this.pushStack(jQuery.merge(this.get(),selector.constructor==String?jQuery(selector).get():selector.length!=undefined&&(!selector.nodeName||jQuery.nodeName(selector,"form"))?selector:[selector]));},is:function(selector){return selector?jQuery.multiFilter(selector,this).length>0:false;},hasClass:function(selector){return this.is("."+selector);},val:function(value){if(value==undefined){if(this.length){var elem=this[0];if(jQuery.nodeName(elem,"select")){var index=elem.selectedIndex,values=[],options=elem.options,one=elem.type=="select-one";if(index<0)return null;for(var i=one?index:0,max=one?index+1:options.length;i<max;i++){var option=options[i];if(option.selected){value=jQuery.browser.msie&&!option.attributes.value.specified?option.text:option.value;if(one)return value;values.push(value);}}return values;}else
+return(this[0].value||"").replace(/\r/g,"");}return undefined;}return this.each(function(){if(this.nodeType!=1)return;if(value.constructor==Array&&/radio|checkbox/.test(this.type))this.checked=(jQuery.inArray(this.value,value)>=0||jQuery.inArray(this.name,value)>=0);else if(jQuery.nodeName(this,"select")){var values=value.constructor==Array?value:[value];jQuery("option",this).each(function(){this.selected=(jQuery.inArray(this.value,values)>=0||jQuery.inArray(this.text,values)>=0);});if(!values.length)this.selectedIndex=-1;}else
+this.value=value;});},html:function(value){return value==undefined?(this.length?this[0].innerHTML:null):this.empty().append(value);},replaceWith:function(value){return this.after(value).remove();},eq:function(i){return this.slice(i,i+1);},slice:function(){return this.pushStack(Array.prototype.slice.apply(this,arguments));},map:function(callback){return this.pushStack(jQuery.map(this,function(elem,i){return callback.call(elem,i,elem);}));},andSelf:function(){return this.add(this.prevObject);},data:function(key,value){var parts=key.split(".");parts[1]=parts[1]?"."+parts[1]:"";if(value==null){var data=this.triggerHandler("getData"+parts[1]+"!",[parts[0]]);if(data==undefined&&this.length)data=jQuery.data(this[0],key);return data==null&&parts[1]?this.data(parts[0]):data;}else
+return this.trigger("setData"+parts[1]+"!",[parts[0],value]).each(function(){jQuery.data(this,key,value);});},removeData:function(key){return this.each(function(){jQuery.removeData(this,key);});},domManip:function(args,table,reverse,callback){var clone=this.length>1,elems;return this.each(function(){if(!elems){elems=jQuery.clean(args,this.ownerDocument);if(reverse)elems.reverse();}var obj=this;if(table&&jQuery.nodeName(this,"table")&&jQuery.nodeName(elems[0],"tr"))obj=this.getElementsByTagName("tbody")[0]||this.appendChild(this.ownerDocument.createElement("tbody"));var scripts=jQuery([]);jQuery.each(elems,function(){var elem=clone?jQuery(this).clone(true)[0]:this;if(jQuery.nodeName(elem,"script")){scripts=scripts.add(elem);}else{if(elem.nodeType==1)scripts=scripts.add(jQuery("script",elem).remove());callback.call(obj,elem);}});scripts.each(evalScript);});}};jQuery.prototype.init.prototype=jQuery.prototype;function evalScript(i,elem){if(elem.src)jQuery.ajax({url:elem.src,async:false,dataType:"script"});else
+jQuery.globalEval(elem.text||elem.textContent||elem.innerHTML||"");if(elem.parentNode)elem.parentNode.removeChild(elem);}jQuery.extend=jQuery.fn.extend=function(){var target=arguments[0]||{},i=1,length=arguments.length,deep=false,options;if(target.constructor==Boolean){deep=target;target=arguments[1]||{};i=2;}if(typeof target!="object"&&typeof target!="function")target={};if(length==1){target=this;i=0;}for(;i<length;i++)if((options=arguments[i])!=null)for(var name in options){if(target===options[name])continue;if(deep&&options[name]&&typeof options[name]=="object"&&target[name]&&!options[name].nodeType)target[name]=jQuery.extend(target[name],options[name]);else if(options[name]!=undefined)target[name]=options[name];}return target;};var expando="jQuery"+(new Date()).getTime(),uuid=0,windowData={};var exclude=/z-?index|font-?weight|opacity|zoom|line-?height/i;jQuery.extend({noConflict:function(deep){window.$=_$;if(deep)window.jQuery=_jQuery;return jQuery;},isFunction:function(fn){return!!fn&&typeof fn!="string"&&!fn.nodeName&&fn.constructor!=Array&&/function/i.test(fn+"");},isXMLDoc:function(elem){return elem.documentElement&&!elem.body||elem.tagName&&elem.ownerDocument&&!elem.ownerDocument.body;},globalEval:function(data){data=jQuery.trim(data);if(data){var head=document.getElementsByTagName("head")[0]||document.documentElement,script=document.createElement("script");script.type="text/javascript";if(jQuery.browser.msie)script.text=data;else
+script.appendChild(document.createTextNode(data));head.appendChild(script);head.removeChild(script);}},nodeName:function(elem,name){return elem.nodeName&&elem.nodeName.toUpperCase()==name.toUpperCase();},cache:{},data:function(elem,name,data){elem=elem==window?windowData:elem;var id=elem[expando];if(!id)id=elem[expando]=++uuid;if(name&&!jQuery.cache[id])jQuery.cache[id]={};if(data!=undefined)jQuery.cache[id][name]=data;return name?jQuery.cache[id][name]:id;},removeData:function(elem,name){elem=elem==window?windowData:elem;var id=elem[expando];if(name){if(jQuery.cache[id]){delete jQuery.cache[id][name];name="";for(name in jQuery.cache[id])break;if(!name)jQuery.removeData(elem);}}else{try{delete elem[expando];}catch(e){if(elem.removeAttribute)elem.removeAttribute(expando);}delete jQuery.cache[id];}},each:function(object,callback,args){if(args){if(object.length==undefined){for(var name in object)if(callback.apply(object[name],args)===false)break;}else
+for(var i=0,length=object.length;i<length;i++)if(callback.apply(object[i],args)===false)break;}else{if(object.length==undefined){for(var name in object)if(callback.call(object[name],name,object[name])===false)break;}else
+for(var i=0,length=object.length,value=object[0];i<length&&callback.call(value,i,value)!==false;value=object[++i]){}}return object;},prop:function(elem,value,type,i,name){if(jQuery.isFunction(value))value=value.call(elem,i);return value&&value.constructor==Number&&type=="curCSS"&&!exclude.test(name)?value+"px":value;},className:{add:function(elem,classNames){jQuery.each((classNames||"").split(/\s+/),function(i,className){if(elem.nodeType==1&&!jQuery.className.has(elem.className,className))elem.className+=(elem.className?" ":"")+className;});},remove:function(elem,classNames){if(elem.nodeType==1)elem.className=classNames!=undefined?jQuery.grep(elem.className.split(/\s+/),function(className){return!jQuery.className.has(classNames,className);}).join(" "):"";},has:function(elem,className){return jQuery.inArray(className,(elem.className||elem).toString().split(/\s+/))>-1;}},swap:function(elem,options,callback){var old={};for(var name in options){old[name]=elem.style[name];elem.style[name]=options[name];}callback.call(elem);for(var name in options)elem.style[name]=old[name];},css:function(elem,name,force){if(name=="width"||name=="height"){var val,props={position:"absolute",visibility:"hidden",display:"block"},which=name=="width"?["Left","Right"]:["Top","Bottom"];function getWH(){val=name=="width"?elem.offsetWidth:elem.offsetHeight;var padding=0,border=0;jQuery.each(which,function(){padding+=parseFloat(jQuery.curCSS(elem,"padding"+this,true))||0;border+=parseFloat(jQuery.curCSS(elem,"border"+this+"Width",true))||0;});val-=Math.round(padding+border);}if(jQuery(elem).is(":visible"))getWH();else
+jQuery.swap(elem,props,getWH);return Math.max(0,val);}return jQuery.curCSS(elem,name,force);},curCSS:function(elem,name,force){var ret;function color(elem){if(!jQuery.browser.safari)return false;var ret=document.defaultView.getComputedStyle(elem,null);return!ret||ret.getPropertyValue("color")=="";}if(name=="opacity"&&jQuery.browser.msie){ret=jQuery.attr(elem.style,"opacity");return ret==""?"1":ret;}if(jQuery.browser.opera&&name=="display"){var save=elem.style.outline;elem.style.outline="0 solid black";elem.style.outline=save;}if(name.match(/float/i))name=styleFloat;if(!force&&elem.style&&elem.style[name])ret=elem.style[name];else if(document.defaultView&&document.defaultView.getComputedStyle){if(name.match(/float/i))name="float";name=name.replace(/([A-Z])/g,"-$1").toLowerCase();var getComputedStyle=document.defaultView.getComputedStyle(elem,null);if(getComputedStyle&&!color(elem))ret=getComputedStyle.getPropertyValue(name);else{var swap=[],stack=[];for(var a=elem;a&&color(a);a=a.parentNode)stack.unshift(a);for(var i=0;i<stack.length;i++)if(color(stack[i])){swap[i]=stack[i].style.display;stack[i].style.display="block";}ret=name=="display"&&swap[stack.length-1]!=null?"none":(getComputedStyle&&getComputedStyle.getPropertyValue(name))||"";for(var i=0;i<swap.length;i++)if(swap[i]!=null)stack[i].style.display=swap[i];}if(name=="opacity"&&ret=="")ret="1";}else if(elem.currentStyle){var camelCase=name.replace(/\-(\w)/g,function(all,letter){return letter.toUpperCase();});ret=elem.currentStyle[name]||elem.currentStyle[camelCase];if(!/^\d+(px)?$/i.test(ret)&&/^\d/.test(ret)){var style=elem.style.left,runtimeStyle=elem.runtimeStyle.left;elem.runtimeStyle.left=elem.currentStyle.left;elem.style.left=ret||0;ret=elem.style.pixelLeft+"px";elem.style.left=style;elem.runtimeStyle.left=runtimeStyle;}}return ret;},clean:function(elems,context){var ret=[];context=context||document;if(typeof context.createElement=='undefined')context=context.ownerDocument||context[0]&&context[0].ownerDocument||document;jQuery.each(elems,function(i,elem){if(!elem)return;if(elem.constructor==Number)elem=elem.toString();if(typeof elem=="string"){elem=elem.replace(/(<(\w+)[^>]*?)\/>/g,function(all,front,tag){return tag.match(/^(abbr|br|col|img|input|link|meta|param|hr|area|embed)$/i)?all:front+"></"+tag+">";});var tags=jQuery.trim(elem).toLowerCase(),div=context.createElement("div");var wrap=!tags.indexOf("<opt")&&[1,"<select multiple='multiple'>","</select>"]||!tags.indexOf("<leg")&&[1,"<fieldset>","</fieldset>"]||tags.match(/^<(thead|tbody|tfoot|colg|cap)/)&&[1,"<table>","</table>"]||!tags.indexOf("<tr")&&[2,"<table><tbody>","</tbody></table>"]||(!tags.indexOf("<td")||!tags.indexOf("<th"))&&[3,"<table><tbody><tr>","</tr></tbody></table>"]||!tags.indexOf("<col")&&[2,"<table><tbody></tbody><colgroup>","</colgroup></table>"]||jQuery.browser.msie&&[1,"div<div>","</div>"]||[0,"",""];div.innerHTML=wrap[1]+elem+wrap[2];while(wrap[0]--)div=div.lastChild;if(jQuery.browser.msie){var tbody=!tags.indexOf("<table")&&tags.indexOf("<tbody")<0?div.firstChild&&div.firstChild.childNodes:wrap[1]=="<table>"&&tags.indexOf("<tbody")<0?div.childNodes:[];for(var j=tbody.length-1;j>=0;--j)if(jQuery.nodeName(tbody[j],"tbody")&&!tbody[j].childNodes.length)tbody[j].parentNode.removeChild(tbody[j]);if(/^\s/.test(elem))div.insertBefore(context.createTextNode(elem.match(/^\s*/)[0]),div.firstChild);}elem=jQuery.makeArray(div.childNodes);}if(elem.length===0&&(!jQuery.nodeName(elem,"form")&&!jQuery.nodeName(elem,"select")))return;if(elem[0]==undefined||jQuery.nodeName(elem,"form")||elem.options)ret.push(elem);else
+ret=jQuery.merge(ret,elem);});return ret;},attr:function(elem,name,value){if(!elem||elem.nodeType==3||elem.nodeType==8)return undefined;var fix=jQuery.isXMLDoc(elem)?{}:jQuery.props;if(name=="selected"&&jQuery.browser.safari)elem.parentNode.selectedIndex;if(fix[name]){if(value!=undefined)elem[fix[name]]=value;return elem[fix[name]];}else if(jQuery.browser.msie&&name=="style")return jQuery.attr(elem.style,"cssText",value);else if(value==undefined&&jQuery.browser.msie&&jQuery.nodeName(elem,"form")&&(name=="action"||name=="method"))return elem.getAttributeNode(name).nodeValue;else if(elem.tagName){if(value!=undefined){if(name=="type"&&jQuery.nodeName(elem,"input")&&elem.parentNode)throw"type property can't be changed";elem.setAttribute(name,""+value);}if(jQuery.browser.msie&&/href|src/.test(name)&&!jQuery.isXMLDoc(elem))return elem.getAttribute(name,2);return elem.getAttribute(name);}else{if(name=="opacity"&&jQuery.browser.msie){if(value!=undefined){elem.zoom=1;elem.filter=(elem.filter||"").replace(/alpha\([^)]*\)/,"")+(parseFloat(value).toString()=="NaN"?"":"alpha(opacity="+value*100+")");}return elem.filter&&elem.filter.indexOf("opacity=")>=0?(parseFloat(elem.filter.match(/opacity=([^)]*)/)[1])/100).toString():"";}name=name.replace(/-([a-z])/ig,function(all,letter){return letter.toUpperCase();});if(value!=undefined)elem[name]=value;return elem[name];}},trim:function(text){return(text||"").replace(/^\s+|\s+$/g,"");},makeArray:function(array){var ret=[];if(typeof array!="array")for(var i=0,length=array.length;i<length;i++)ret.push(array[i]);else
+ret=array.slice(0);return ret;},inArray:function(elem,array){for(var i=0,length=array.length;i<length;i++)if(array[i]==elem)return i;return-1;},merge:function(first,second){if(jQuery.browser.msie){for(var i=0;second[i];i++)if(second[i].nodeType!=8)first.push(second[i]);}else
+for(var i=0;second[i];i++)first.push(second[i]);return first;},unique:function(array){var ret=[],done={};try{for(var i=0,length=array.length;i<length;i++){var id=jQuery.data(array[i]);if(!done[id]){done[id]=true;ret.push(array[i]);}}}catch(e){ret=array;}return ret;},grep:function(elems,callback,inv){var ret=[];for(var i=0,length=elems.length;i<length;i++)if(!inv&&callback(elems[i],i)||inv&&!callback(elems[i],i))ret.push(elems[i]);return ret;},map:function(elems,callback){var ret=[];for(var i=0,length=elems.length;i<length;i++){var value=callback(elems[i],i);if(value!==null&&value!=undefined){if(value.constructor!=Array)value=[value];ret=ret.concat(value);}}return ret;}});var userAgent=navigator.userAgent.toLowerCase();jQuery.browser={version:(userAgent.match(/.+(?:rv|it|ra|ie)[\/: ]([\d.]+)/)||[])[1],safari:/webkit/.test(userAgent),opera:/opera/.test(userAgent),msie:/msie/.test(userAgent)&&!/opera/.test(userAgent),mozilla:/mozilla/.test(userAgent)&&!/(compatible|webkit)/.test(userAgent)};var styleFloat=jQuery.browser.msie?"styleFloat":"cssFloat";jQuery.extend({boxModel:!jQuery.browser.msie||document.compatMode=="CSS1Compat",props:{"for":"htmlFor","class":"className","float":styleFloat,cssFloat:styleFloat,styleFloat:styleFloat,innerHTML:"innerHTML",className:"className",value:"value",disabled:"disabled",checked:"checked",readonly:"readOnly",selected:"selected",maxlength:"maxLength",selectedIndex:"selectedIndex",defaultValue:"defaultValue",tagName:"tagName",nodeName:"nodeName"}});jQuery.each({parent:function(elem){return elem.parentNode;},parents:function(elem){return jQuery.dir(elem,"parentNode");},next:function(elem){return jQuery.nth(elem,2,"nextSibling");},prev:function(elem){return jQuery.nth(elem,2,"previousSibling");},nextAll:function(elem){return jQuery.dir(elem,"nextSibling");},prevAll:function(elem){return jQuery.dir(elem,"previousSibling");},siblings:function(elem){return jQuery.sibling(elem.parentNode.firstChild,elem);},children:function(elem){return jQuery.sibling(elem.firstChild);},contents:function(elem){return jQuery.nodeName(elem,"iframe")?elem.contentDocument||elem.contentWindow.document:jQuery.makeArray(elem.childNodes);}},function(name,fn){jQuery.fn[name]=function(selector){var ret=jQuery.map(this,fn);if(selector&&typeof selector=="string")ret=jQuery.multiFilter(selector,ret);return this.pushStack(jQuery.unique(ret));};});jQuery.each({appendTo:"append",prependTo:"prepend",insertBefore:"before",insertAfter:"after",replaceAll:"replaceWith"},function(name,original){jQuery.fn[name]=function(){var args=arguments;return this.each(function(){for(var i=0,length=args.length;i<length;i++)jQuery(args[i])[original](this);});};});jQuery.each({removeAttr:function(name){jQuery.attr(this,name,"");if(this.nodeType==1)this.removeAttribute(name);},addClass:function(classNames){jQuery.className.add(this,classNames);},removeClass:function(classNames){jQuery.className.remove(this,classNames);},toggleClass:function(classNames){jQuery.className[jQuery.className.has(this,classNames)?"remove":"add"](this,classNames);},remove:function(selector){if(!selector||jQuery.filter(selector,[this]).r.length){jQuery("*",this).add(this).each(function(){jQuery.event.remove(this);jQuery.removeData(this);});if(this.parentNode)this.parentNode.removeChild(this);}},empty:function(){jQuery(">*",this).remove();while(this.firstChild)this.removeChild(this.firstChild);}},function(name,fn){jQuery.fn[name]=function(){return this.each(fn,arguments);};});jQuery.each(["Height","Width"],function(i,name){var type=name.toLowerCase();jQuery.fn[type]=function(size){return this[0]==window?jQuery.browser.opera&&document.body["client"+name]||jQuery.browser.safari&&window["inner"+name]||document.compatMode=="CSS1Compat"&&document.documentElement["client"+name]||document.body["client"+name]:this[0]==document?Math.max(Math.max(document.body["scroll"+name],document.documentElement["scroll"+name]),Math.max(document.body["offset"+name],document.documentElement["offset"+name])):size==undefined?(this.length?jQuery.css(this[0],type):null):this.css(type,size.constructor==String?size:size+"px");};});var chars=jQuery.browser.safari&&parseInt(jQuery.browser.version)<417?"(?:[\\w*_-]|\\\\.)":"(?:[\\w\u0128-\uFFFF*_-]|\\\\.)",quickChild=new RegExp("^>\\s*("+chars+"+)"),quickID=new RegExp("^("+chars+"+)(#)("+chars+"+)"),quickClass=new RegExp("^([#.]?)("+chars+"*)");jQuery.extend({expr:{"":function(a,i,m){return m[2]=="*"||jQuery.nodeName(a,m[2]);},"#":function(a,i,m){return a.getAttribute("id")==m[2];},":":{lt:function(a,i,m){return i<m[3]-0;},gt:function(a,i,m){return i>m[3]-0;},nth:function(a,i,m){return m[3]-0==i;},eq:function(a,i,m){return m[3]-0==i;},first:function(a,i){return i==0;},last:function(a,i,m,r){return i==r.length-1;},even:function(a,i){return i%2==0;},odd:function(a,i){return i%2;},"first-child":function(a){return a.parentNode.getElementsByTagName("*")[0]==a;},"last-child":function(a){return jQuery.nth(a.parentNode.lastChild,1,"previousSibling")==a;},"only-child":function(a){return!jQuery.nth(a.parentNode.lastChild,2,"previousSibling");},parent:function(a){return a.firstChild;},empty:function(a){return!a.firstChild;},contains:function(a,i,m){return(a.textContent||a.innerText||jQuery(a).text()||"").indexOf(m[3])>=0;},visible:function(a){return"hidden"!=a.type&&jQuery.css(a,"display")!="none"&&jQuery.css(a,"visibility")!="hidden";},hidden:function(a){return"hidden"==a.type||jQuery.css(a,"display")=="none"||jQuery.css(a,"visibility")=="hidden";},enabled:function(a){return!a.disabled;},disabled:function(a){return a.disabled;},checked:function(a){return a.checked;},selected:function(a){return a.selected||jQuery.attr(a,"selected");},text:function(a){return"text"==a.type;},radio:function(a){return"radio"==a.type;},checkbox:function(a){return"checkbox"==a.type;},file:function(a){return"file"==a.type;},password:function(a){return"password"==a.type;},submit:function(a){return"submit"==a.type;},image:function(a){return"image"==a.type;},reset:function(a){return"reset"==a.type;},button:function(a){return"button"==a.type||jQuery.nodeName(a,"button");},input:function(a){return/input|select|textarea|button/i.test(a.nodeName);},has:function(a,i,m){return jQuery.find(m[3],a).length;},header:function(a){return/h\d/i.test(a.nodeName);},animated:function(a){return jQuery.grep(jQuery.timers,function(fn){return a==fn.elem;}).length;}}},parse:[/^(\[) *@?([\w-]+) *([!*$^~=]*) *('?"?)(.*?)\4 *\]/,/^(:)([\w-]+)\("?'?(.*?(\(.*?\))?[^(]*?)"?'?\)/,new RegExp("^([:.#]*)("+chars+"+)")],multiFilter:function(expr,elems,not){var old,cur=[];while(expr&&expr!=old){old=expr;var f=jQuery.filter(expr,elems,not);expr=f.t.replace(/^\s*,\s*/,"");cur=not?elems=f.r:jQuery.merge(cur,f.r);}return cur;},find:function(t,context){if(typeof t!="string")return[t];if(context&&context.nodeType!=1&&context.nodeType!=9)return[];context=context||document;var ret=[context],done=[],last,nodeName;while(t&&last!=t){var r=[];last=t;t=jQuery.trim(t);var foundToken=false;var re=quickChild;var m=re.exec(t);if(m){nodeName=m[1].toUpperCase();for(var i=0;ret[i];i++)for(var c=ret[i].firstChild;c;c=c.nextSibling)if(c.nodeType==1&&(nodeName=="*"||c.nodeName.toUpperCase()==nodeName))r.push(c);ret=r;t=t.replace(re,"");if(t.indexOf(" ")==0)continue;foundToken=true;}else{re=/^([>+~])\s*(\w*)/i;if((m=re.exec(t))!=null){r=[];var merge={};nodeName=m[2].toUpperCase();m=m[1];for(var j=0,rl=ret.length;j<rl;j++){var n=m=="~"||m=="+"?ret[j].nextSibling:ret[j].firstChild;for(;n;n=n.nextSibling)if(n.nodeType==1){var id=jQuery.data(n);if(m=="~"&&merge[id])break;if(!nodeName||n.nodeName.toUpperCase()==nodeName){if(m=="~")merge[id]=true;r.push(n);}if(m=="+")break;}}ret=r;t=jQuery.trim(t.replace(re,""));foundToken=true;}}if(t&&!foundToken){if(!t.indexOf(",")){if(context==ret[0])ret.shift();done=jQuery.merge(done,ret);r=ret=[context];t=" "+t.substr(1,t.length);}else{var re2=quickID;var m=re2.exec(t);if(m){m=[0,m[2],m[3],m[1]];}else{re2=quickClass;m=re2.exec(t);}m[2]=m[2].replace(/\\/g,"");var elem=ret[ret.length-1];if(m[1]=="#"&&elem&&elem.getElementById&&!jQuery.isXMLDoc(elem)){var oid=elem.getElementById(m[2]);if((jQuery.browser.msie||jQuery.browser.opera)&&oid&&typeof oid.id=="string"&&oid.id!=m[2])oid=jQuery('[@id="'+m[2]+'"]',elem)[0];ret=r=oid&&(!m[3]||jQuery.nodeName(oid,m[3]))?[oid]:[];}else{for(var i=0;ret[i];i++){var tag=m[1]=="#"&&m[3]?m[3]:m[1]!=""||m[0]==""?"*":m[2];if(tag=="*"&&ret[i].nodeName.toLowerCase()=="object")tag="param";r=jQuery.merge(r,ret[i].getElementsByTagName(tag));}if(m[1]==".")r=jQuery.classFilter(r,m[2]);if(m[1]=="#"){var tmp=[];for(var i=0;r[i];i++)if(r[i].getAttribute("id")==m[2]){tmp=[r[i]];break;}r=tmp;}ret=r;}t=t.replace(re2,"");}}if(t){var val=jQuery.filter(t,r);ret=r=val.r;t=jQuery.trim(val.t);}}if(t)ret=[];if(ret&&context==ret[0])ret.shift();done=jQuery.merge(done,ret);return done;},classFilter:function(r,m,not){m=" "+m+" ";var tmp=[];for(var i=0;r[i];i++){var pass=(" "+r[i].className+" ").indexOf(m)>=0;if(!not&&pass||not&&!pass)tmp.push(r[i]);}return tmp;},filter:function(t,r,not){var last;while(t&&t!=last){last=t;var p=jQuery.parse,m;for(var i=0;p[i];i++){m=p[i].exec(t);if(m){t=t.substring(m[0].length);m[2]=m[2].replace(/\\/g,"");break;}}if(!m)break;if(m[1]==":"&&m[2]=="not")r=isSimple.test(m[3])?jQuery.filter(m[3],r,true).r:jQuery(r).not(m[3]);else if(m[1]==".")r=jQuery.classFilter(r,m[2],not);else if(m[1]=="["){var tmp=[],type=m[3];for(var i=0,rl=r.length;i<rl;i++){var a=r[i],z=a[jQuery.props[m[2]]||m[2]];if(z==null||/href|src|selected/.test(m[2]))z=jQuery.attr(a,m[2])||'';if((type==""&&!!z||type=="="&&z==m[5]||type=="!="&&z!=m[5]||type=="^="&&z&&!z.indexOf(m[5])||type=="$="&&z.substr(z.length-m[5].length)==m[5]||(type=="*="||type=="~=")&&z.indexOf(m[5])>=0)^not)tmp.push(a);}r=tmp;}else if(m[1]==":"&&m[2]=="nth-child"){var merge={},tmp=[],test=/(-?)(\d*)n((?:\+|-)?\d*)/.exec(m[3]=="even"&&"2n"||m[3]=="odd"&&"2n+1"||!/\D/.test(m[3])&&"0n+"+m[3]||m[3]),first=(test[1]+(test[2]||1))-0,last=test[3]-0;for(var i=0,rl=r.length;i<rl;i++){var node=r[i],parentNode=node.parentNode,id=jQuery.data(parentNode);if(!merge[id]){var c=1;for(var n=parentNode.firstChild;n;n=n.nextSibling)if(n.nodeType==1)n.nodeIndex=c++;merge[id]=true;}var add=false;if(first==0){if(node.nodeIndex==last)add=true;}else if((node.nodeIndex-last)%first==0&&(node.nodeIndex-last)/first>=0)add=true;if(add^not)tmp.push(node);}r=tmp;}else{var fn=jQuery.expr[m[1]];if(typeof fn=="object")fn=fn[m[2]];if(typeof fn=="string")fn=eval("false||function(a,i){return "+fn+";}");r=jQuery.grep(r,function(elem,i){return fn(elem,i,m,r);},not);}}return{r:r,t:t};},dir:function(elem,dir){var matched=[];var cur=elem[dir];while(cur&&cur!=document){if(cur.nodeType==1)matched.push(cur);cur=cur[dir];}return matched;},nth:function(cur,result,dir,elem){result=result||1;var num=0;for(;cur;cur=cur[dir])if(cur.nodeType==1&&++num==result)break;return cur;},sibling:function(n,elem){var r=[];for(;n;n=n.nextSibling){if(n.nodeType==1&&(!elem||n!=elem))r.push(n);}return r;}});jQuery.event={add:function(elem,types,handler,data){if(elem.nodeType==3||elem.nodeType==8)return;if(jQuery.browser.msie&&elem.setInterval!=undefined)elem=window;if(!handler.guid)handler.guid=this.guid++;if(data!=undefined){var fn=handler;handler=function(){return fn.apply(this,arguments);};handler.data=data;handler.guid=fn.guid;}var events=jQuery.data(elem,"events")||jQuery.data(elem,"events",{}),handle=jQuery.data(elem,"handle")||jQuery.data(elem,"handle",function(){var val;if(typeof jQuery=="undefined"||jQuery.event.triggered)return val;val=jQuery.event.handle.apply(arguments.callee.elem,arguments);return val;});handle.elem=elem;jQuery.each(types.split(/\s+/),function(index,type){var parts=type.split(".");type=parts[0];handler.type=parts[1];var handlers=events[type];if(!handlers){handlers=events[type]={};if(!jQuery.event.special[type]||jQuery.event.special[type].setup.call(elem)===false){if(elem.addEventListener)elem.addEventListener(type,handle,false);else if(elem.attachEvent)elem.attachEvent("on"+type,handle);}}handlers[handler.guid]=handler;jQuery.event.global[type]=true;});elem=null;},guid:1,global:{},remove:function(elem,types,handler){if(elem.nodeType==3||elem.nodeType==8)return;var events=jQuery.data(elem,"events"),ret,index;if(events){if(types==undefined||(typeof types=="string"&&types.charAt(0)=="."))for(var type in events)this.remove(elem,type+(types||""));else{if(types.type){handler=types.handler;types=types.type;}jQuery.each(types.split(/\s+/),function(index,type){var parts=type.split(".");type=parts[0];if(events[type]){if(handler)delete events[type][handler.guid];else
+for(handler in events[type])if(!parts[1]||events[type][handler].type==parts[1])delete events[type][handler];for(ret in events[type])break;if(!ret){if(!jQuery.event.special[type]||jQuery.event.special[type].teardown.call(elem)===false){if(elem.removeEventListener)elem.removeEventListener(type,jQuery.data(elem,"handle"),false);else if(elem.detachEvent)elem.detachEvent("on"+type,jQuery.data(elem,"handle"));}ret=null;delete events[type];}}});}for(ret in events)break;if(!ret){var handle=jQuery.data(elem,"handle");if(handle)handle.elem=null;jQuery.removeData(elem,"events");jQuery.removeData(elem,"handle");}}},trigger:function(type,data,elem,donative,extra){data=jQuery.makeArray(data||[]);if(type.indexOf("!")>=0){type=type.slice(0,-1);var exclusive=true;}if(!elem){if(this.global[type])jQuery("*").add([window,document]).trigger(type,data);}else{if(elem.nodeType==3||elem.nodeType==8)return undefined;var val,ret,fn=jQuery.isFunction(elem[type]||null),event=!data[0]||!data[0].preventDefault;if(event)data.unshift(this.fix({type:type,target:elem}));data[0].type=type;if(exclusive)data[0].exclusive=true;if(jQuery.isFunction(jQuery.data(elem,"handle")))val=jQuery.data(elem,"handle").apply(elem,data);if(!fn&&elem["on"+type]&&elem["on"+type].apply(elem,data)===false)val=false;if(event)data.shift();if(extra&&jQuery.isFunction(extra)){ret=extra.apply(elem,val==null?data:data.concat(val));if(ret!==undefined)val=ret;}if(fn&&donative!==false&&val!==false&&!(jQuery.nodeName(elem,'a')&&type=="click")){this.triggered=true;try{elem[type]();}catch(e){}}this.triggered=false;}return val;},handle:function(event){var val;event=jQuery.event.fix(event||window.event||{});var parts=event.type.split(".");event.type=parts[0];var handlers=jQuery.data(this,"events")&&jQuery.data(this,"events")[event.type],args=Array.prototype.slice.call(arguments,1);args.unshift(event);for(var j in handlers){var handler=handlers[j];args[0].handler=handler;args[0].data=handler.data;if(!parts[1]&&!event.exclusive||handler.type==parts[1]){var ret=handler.apply(this,args);if(val!==false)val=ret;if(ret===false){event.preventDefault();event.stopPropagation();}}}if(jQuery.browser.msie)event.target=event.preventDefault=event.stopPropagation=event.handler=event.data=null;return val;},fix:function(event){var originalEvent=event;event=jQuery.extend({},originalEvent);event.preventDefault=function(){if(originalEvent.preventDefault)originalEvent.preventDefault();originalEvent.returnValue=false;};event.stopPropagation=function(){if(originalEvent.stopPropagation)originalEvent.stopPropagation();originalEvent.cancelBubble=true;};if(!event.target)event.target=event.srcElement||document;if(event.target.nodeType==3)event.target=originalEvent.target.parentNode;if(!event.relatedTarget&&event.fromElement)event.relatedTarget=event.fromElement==event.target?event.toElement:event.fromElement;if(event.pageX==null&&event.clientX!=null){var doc=document.documentElement,body=document.body;event.pageX=event.clientX+(doc&&doc.scrollLeft||body&&body.scrollLeft||0)-(doc.clientLeft||0);event.pageY=event.clientY+(doc&&doc.scrollTop||body&&body.scrollTop||0)-(doc.clientTop||0);}if(!event.which&&((event.charCode||event.charCode===0)?event.charCode:event.keyCode))event.which=event.charCode||event.keyCode;if(!event.metaKey&&event.ctrlKey)event.metaKey=event.ctrlKey;if(!event.which&&event.button)event.which=(event.button&1?1:(event.button&2?3:(event.button&4?2:0)));return event;},special:{ready:{setup:function(){bindReady();return;},teardown:function(){return;}},mouseenter:{setup:function(){if(jQuery.browser.msie)return false;jQuery(this).bind("mouseover",jQuery.event.special.mouseenter.handler);return true;},teardown:function(){if(jQuery.browser.msie)return false;jQuery(this).unbind("mouseover",jQuery.event.special.mouseenter.handler);return true;},handler:function(event){if(withinElement(event,this))return true;arguments[0].type="mouseenter";return jQuery.event.handle.apply(this,arguments);}},mouseleave:{setup:function(){if(jQuery.browser.msie)return false;jQuery(this).bind("mouseout",jQuery.event.special.mouseleave.handler);return true;},teardown:function(){if(jQuery.browser.msie)return false;jQuery(this).unbind("mouseout",jQuery.event.special.mouseleave.handler);return true;},handler:function(event){if(withinElement(event,this))return true;arguments[0].type="mouseleave";return jQuery.event.handle.apply(this,arguments);}}}};jQuery.fn.extend({bind:function(type,data,fn){return type=="unload"?this.one(type,data,fn):this.each(function(){jQuery.event.add(this,type,fn||data,fn&&data);});},one:function(type,data,fn){return this.each(function(){jQuery.event.add(this,type,function(event){jQuery(this).unbind(event);return(fn||data).apply(this,arguments);},fn&&data);});},unbind:function(type,fn){return this.each(function(){jQuery.event.remove(this,type,fn);});},trigger:function(type,data,fn){return this.each(function(){jQuery.event.trigger(type,data,this,true,fn);});},triggerHandler:function(type,data,fn){if(this[0])return jQuery.event.trigger(type,data,this[0],false,fn);return undefined;},toggle:function(){var args=arguments;return this.click(function(event){this.lastToggle=0==this.lastToggle?1:0;event.preventDefault();return args[this.lastToggle].apply(this,arguments)||false;});},hover:function(fnOver,fnOut){return this.bind('mouseenter',fnOver).bind('mouseleave',fnOut);},ready:function(fn){bindReady();if(jQuery.isReady)fn.call(document,jQuery);else
+jQuery.readyList.push(function(){return fn.call(this,jQuery);});return this;}});jQuery.extend({isReady:false,readyList:[],ready:function(){if(!jQuery.isReady){jQuery.isReady=true;if(jQuery.readyList){jQuery.each(jQuery.readyList,function(){this.apply(document);});jQuery.readyList=null;}jQuery(document).triggerHandler("ready");}}});var readyBound=false;function bindReady(){if(readyBound)return;readyBound=true;if(document.addEventListener&&!jQuery.browser.opera)document.addEventListener("DOMContentLoaded",jQuery.ready,false);if(jQuery.browser.msie&&window==top)(function(){if(jQuery.isReady)return;try{document.documentElement.doScroll("left");}catch(error){setTimeout(arguments.callee,0);return;}jQuery.ready();})();if(jQuery.browser.opera)document.addEventListener("DOMContentLoaded",function(){if(jQuery.isReady)return;for(var i=0;i<document.styleSheets.length;i++)if(document.styleSheets[i].disabled){setTimeout(arguments.callee,0);return;}jQuery.ready();},false);if(jQuery.browser.safari){var numStyles;(function(){if(jQuery.isReady)return;if(document.readyState!="loaded"&&document.readyState!="complete"){setTimeout(arguments.callee,0);return;}if(numStyles===undefined)numStyles=jQuery("style, link[rel=stylesheet]").length;if(document.styleSheets.length!=numStyles){setTimeout(arguments.callee,0);return;}jQuery.ready();})();}jQuery.event.add(window,"load",jQuery.ready);}jQuery.each(("blur,focus,load,resize,scroll,unload,click,dblclick,"+"mousedown,mouseup,mousemove,mouseover,mouseout,change,select,"+"submit,keydown,keypress,keyup,error").split(","),function(i,name){jQuery.fn[name]=function(fn){return fn?this.bind(name,fn):this.trigger(name);};});var withinElement=function(event,elem){var parent=event.relatedTarget;while(parent&&parent!=elem)try{parent=parent.parentNode;}catch(error){parent=elem;}return parent==elem;};jQuery(window).bind("unload",function(){jQuery("*").add(document).unbind();});jQuery.fn.extend({load:function(url,params,callback){if(jQuery.isFunction(url))return this.bind("load",url);var off=url.indexOf(" ");if(off>=0){var selector=url.slice(off,url.length);url=url.slice(0,off);}callback=callback||function(){};var type="GET";if(params)if(jQuery.isFunction(params)){callback=params;params=null;}else{params=jQuery.param(params);type="POST";}var self=this;jQuery.ajax({url:url,type:type,dataType:"html",data:params,complete:function(res,status){if(status=="success"||status=="notmodified")self.html(selector?jQuery("<div/>").append(res.responseText.replace(/<script(.|\s)*?\/script>/g,"")).find(selector):res.responseText);self.each(callback,[res.responseText,status,res]);}});return this;},serialize:function(){return jQuery.param(this.serializeArray());},serializeArray:function(){return this.map(function(){return jQuery.nodeName(this,"form")?jQuery.makeArray(this.elements):this;}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password/i.test(this.type));}).map(function(i,elem){var val=jQuery(this).val();return val==null?null:val.constructor==Array?jQuery.map(val,function(val,i){return{name:elem.name,value:val};}):{name:elem.name,value:val};}).get();}});jQuery.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(i,o){jQuery.fn[o]=function(f){return this.bind(o,f);};});var jsc=(new Date).getTime();jQuery.extend({get:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data=null;}return jQuery.ajax({type:"GET",url:url,data:data,success:callback,dataType:type});},getScript:function(url,callback){return jQuery.get(url,null,callback,"script");},getJSON:function(url,data,callback){return jQuery.get(url,data,callback,"json");},post:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data={};}return jQuery.ajax({type:"POST",url:url,data:data,success:callback,dataType:type});},ajaxSetup:function(settings){jQuery.extend(jQuery.ajaxSettings,settings);},ajaxSettings:{global:true,type:"GET",timeout:0,contentType:"application/x-www-form-urlencoded",processData:true,async:true,data:null,username:null,password:null,accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(s){var jsonp,jsre=/=\?(&|$)/g,status,data;s=jQuery.extend(true,s,jQuery.extend(true,{},jQuery.ajaxSettings,s));if(s.data&&s.processData&&typeof s.data!="string")s.data=jQuery.param(s.data);if(s.dataType=="jsonp"){if(s.type.toLowerCase()=="get"){if(!s.url.match(jsre))s.url+=(s.url.match(/\?/)?"&":"?")+(s.jsonp||"callback")+"=?";}else if(!s.data||!s.data.match(jsre))s.data=(s.data?s.data+"&":"")+(s.jsonp||"callback")+"=?";s.dataType="json";}if(s.dataType=="json"&&(s.data&&s.data.match(jsre)||s.url.match(jsre))){jsonp="jsonp"+jsc++;if(s.data)s.data=(s.data+"").replace(jsre,"="+jsonp+"$1");s.url=s.url.replace(jsre,"="+jsonp+"$1");s.dataType="script";window[jsonp]=function(tmp){data=tmp;success();complete();window[jsonp]=undefined;try{delete window[jsonp];}catch(e){}if(head)head.removeChild(script);};}if(s.dataType=="script"&&s.cache==null)s.cache=false;if(s.cache===false&&s.type.toLowerCase()=="get"){var ts=(new Date()).getTime();var ret=s.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+ts+"$2");s.url=ret+((ret==s.url)?(s.url.match(/\?/)?"&":"?")+"_="+ts:"");}if(s.data&&s.type.toLowerCase()=="get"){s.url+=(s.url.match(/\?/)?"&":"?")+s.data;s.data=null;}if(s.global&&!jQuery.active++)jQuery.event.trigger("ajaxStart");if((!s.url.indexOf("http")||!s.url.indexOf("//"))&&s.dataType=="script"&&s.type.toLowerCase()=="get"){var head=document.getElementsByTagName("head")[0];var script=document.createElement("script");script.src=s.url;if(s.scriptCharset)script.charset=s.scriptCharset;if(!jsonp){var done=false;script.onload=script.onreadystatechange=function(){if(!done&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){done=true;success();complete();head.removeChild(script);}};}head.appendChild(script);return undefined;}var requestDone=false;var xml=window.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest();xml.open(s.type,s.url,s.async,s.username,s.password);try{if(s.data)xml.setRequestHeader("Content-Type",s.contentType);if(s.ifModified)xml.setRequestHeader("If-Modified-Since",jQuery.lastModified[s.url]||"Thu, 01 Jan 1970 00:00:00 GMT");xml.setRequestHeader("X-Requested-With","XMLHttpRequest");xml.setRequestHeader("Accept",s.dataType&&s.accepts[s.dataType]?s.accepts[s.dataType]+", */*":s.accepts._default);}catch(e){}if(s.beforeSend)s.beforeSend(xml);if(s.global)jQuery.event.trigger("ajaxSend",[xml,s]);var onreadystatechange=function(isTimeout){if(!requestDone&&xml&&(xml.readyState==4||isTimeout=="timeout")){requestDone=true;if(ival){clearInterval(ival);ival=null;}status=isTimeout=="timeout"&&"timeout"||!jQuery.httpSuccess(xml)&&"error"||s.ifModified&&jQuery.httpNotModified(xml,s.url)&&"notmodified"||"success";if(status=="success"){try{data=jQuery.httpData(xml,s.dataType);}catch(e){status="parsererror";}}if(status=="success"){var modRes;try{modRes=xml.getResponseHeader("Last-Modified");}catch(e){}if(s.ifModified&&modRes)jQuery.lastModified[s.url]=modRes;if(!jsonp)success();}else
+jQuery.handleError(s,xml,status);complete();if(s.async)xml=null;}};if(s.async){var ival=setInterval(onreadystatechange,13);if(s.timeout>0)setTimeout(function(){if(xml){xml.abort();if(!requestDone)onreadystatechange("timeout");}},s.timeout);}try{xml.send(s.data);}catch(e){jQuery.handleError(s,xml,null,e);}if(!s.async)onreadystatechange();function success(){if(s.success)s.success(data,status);if(s.global)jQuery.event.trigger("ajaxSuccess",[xml,s]);}function complete(){if(s.complete)s.complete(xml,status);if(s.global)jQuery.event.trigger("ajaxComplete",[xml,s]);if(s.global&&!--jQuery.active)jQuery.event.trigger("ajaxStop");}return xml;},handleError:function(s,xml,status,e){if(s.error)s.error(xml,status,e);if(s.global)jQuery.event.trigger("ajaxError",[xml,s,e]);},active:0,httpSuccess:function(r){try{return!r.status&&location.protocol=="file:"||(r.status>=200&&r.status<300)||r.status==304||r.status==1223||jQuery.browser.safari&&r.status==undefined;}catch(e){}return false;},httpNotModified:function(xml,url){try{var xmlRes=xml.getResponseHeader("Last-Modified");return xml.status==304||xmlRes==jQuery.lastModified[url]||jQuery.browser.safari&&xml.status==undefined;}catch(e){}return false;},httpData:function(r,type){var ct=r.getResponseHeader("content-type");var xml=type=="xml"||!type&&ct&&ct.indexOf("xml")>=0;var data=xml?r.responseXML:r.responseText;if(xml&&data.documentElement.tagName=="parsererror")throw"parsererror";if(type=="script")jQuery.globalEval(data);if(type=="json")data=eval("("+data+")");return data;},param:function(a){var s=[];if(a.constructor==Array||a.jquery)jQuery.each(a,function(){s.push(encodeURIComponent(this.name)+"="+encodeURIComponent(this.value));});else
+for(var j in a)if(a[j]&&a[j].constructor==Array)jQuery.each(a[j],function(){s.push(encodeURIComponent(j)+"="+encodeURIComponent(this));});else
+s.push(encodeURIComponent(j)+"="+encodeURIComponent(a[j]));return s.join("&").replace(/%20/g,"+");}});jQuery.fn.extend({show:function(speed,callback){return speed?this.animate({height:"show",width:"show",opacity:"show"},speed,callback):this.filter(":hidden").each(function(){this.style.display=this.oldblock||"";if(jQuery.css(this,"display")=="none"){var elem=jQuery("<"+this.tagName+" />").appendTo("body");this.style.display=elem.css("display");if(this.style.display=="none")this.style.display="block";elem.remove();}}).end();},hide:function(speed,callback){return speed?this.animate({height:"hide",width:"hide",opacity:"hide"},speed,callback):this.filter(":visible").each(function(){this.oldblock=this.oldblock||jQuery.css(this,"display");this.style.display="none";}).end();},_toggle:jQuery.fn.toggle,toggle:function(fn,fn2){return jQuery.isFunction(fn)&&jQuery.isFunction(fn2)?this._toggle(fn,fn2):fn?this.animate({height:"toggle",width:"toggle",opacity:"toggle"},fn,fn2):this.each(function(){jQuery(this)[jQuery(this).is(":hidden")?"show":"hide"]();});},slideDown:function(speed,callback){return this.animate({height:"show"},speed,callback);},slideUp:function(speed,callback){return this.animate({height:"hide"},speed,callback);},slideToggle:function(speed,callback){return this.animate({height:"toggle"},speed,callback);},fadeIn:function(speed,callback){return this.animate({opacity:"show"},speed,callback);},fadeOut:function(speed,callback){return this.animate({opacity:"hide"},speed,callback);},fadeTo:function(speed,to,callback){return this.animate({opacity:to},speed,callback);},animate:function(prop,speed,easing,callback){var optall=jQuery.speed(speed,easing,callback);return this[optall.queue===false?"each":"queue"](function(){if(this.nodeType!=1)return false;var opt=jQuery.extend({},optall);var hidden=jQuery(this).is(":hidden"),self=this;for(var p in prop){if(prop[p]=="hide"&&hidden||prop[p]=="show"&&!hidden)return jQuery.isFunction(opt.complete)&&opt.complete.apply(this);if(p=="height"||p=="width"){opt.display=jQuery.css(this,"display");opt.overflow=this.style.overflow;}}if(opt.overflow!=null)this.style.overflow="hidden";opt.curAnim=jQuery.extend({},prop);jQuery.each(prop,function(name,val){var e=new jQuery.fx(self,opt,name);if(/toggle|show|hide/.test(val))e[val=="toggle"?hidden?"show":"hide":val](prop);else{var parts=val.toString().match(/^([+-]=)?([\d+-.]+)(.*)$/),start=e.cur(true)||0;if(parts){var end=parseFloat(parts[2]),unit=parts[3]||"px";if(unit!="px"){self.style[name]=(end||1)+unit;start=((end||1)/e.cur(true))*start;self.style[name]=start+unit;}if(parts[1])end=((parts[1]=="-="?-1:1)*end)+start;e.custom(start,end,unit);}else
+e.custom(start,val,"");}});return true;});},queue:function(type,fn){if(jQuery.isFunction(type)||(type&&type.constructor==Array)){fn=type;type="fx";}if(!type||(typeof type=="string"&&!fn))return queue(this[0],type);return this.each(function(){if(fn.constructor==Array)queue(this,type,fn);else{queue(this,type).push(fn);if(queue(this,type).length==1)fn.apply(this);}});},stop:function(clearQueue,gotoEnd){var timers=jQuery.timers;if(clearQueue)this.queue([]);this.each(function(){for(var i=timers.length-1;i>=0;i--)if(timers[i].elem==this){if(gotoEnd)timers[i](true);timers.splice(i,1);}});if(!gotoEnd)this.dequeue();return this;}});var queue=function(elem,type,array){if(!elem)return undefined;type=type||"fx";var q=jQuery.data(elem,type+"queue");if(!q||array)q=jQuery.data(elem,type+"queue",array?jQuery.makeArray(array):[]);return q;};jQuery.fn.dequeue=function(type){type=type||"fx";return this.each(function(){var q=queue(this,type);q.shift();if(q.length)q[0].apply(this);});};jQuery.extend({speed:function(speed,easing,fn){var opt=speed&&speed.constructor==Object?speed:{complete:fn||!fn&&easing||jQuery.isFunction(speed)&&speed,duration:speed,easing:fn&&easing||easing&&easing.constructor!=Function&&easing};opt.duration=(opt.duration&&opt.duration.constructor==Number?opt.duration:{slow:600,fast:200}[opt.duration])||400;opt.old=opt.complete;opt.complete=function(){if(opt.queue!==false)jQuery(this).dequeue();if(jQuery.isFunction(opt.old))opt.old.apply(this);};return opt;},easing:{linear:function(p,n,firstNum,diff){return firstNum+diff*p;},swing:function(p,n,firstNum,diff){return((-Math.cos(p*Math.PI)/2)+0.5)*diff+firstNum;}},timers:[],timerId:null,fx:function(elem,options,prop){this.options=options;this.elem=elem;this.prop=prop;if(!options.orig)options.orig={};}});jQuery.fx.prototype={update:function(){if(this.options.step)this.options.step.apply(this.elem,[this.now,this]);(jQuery.fx.step[this.prop]||jQuery.fx.step._default)(this);if(this.prop=="height"||this.prop=="width")this.elem.style.display="block";},cur:function(force){if(this.elem[this.prop]!=null&&this.elem.style[this.prop]==null)return this.elem[this.prop];var r=parseFloat(jQuery.css(this.elem,this.prop,force));return r&&r>-10000?r:parseFloat(jQuery.curCSS(this.elem,this.prop))||0;},custom:function(from,to,unit){this.startTime=(new Date()).getTime();this.start=from;this.end=to;this.unit=unit||this.unit||"px";this.now=this.start;this.pos=this.state=0;this.update();var self=this;function t(gotoEnd){return self.step(gotoEnd);}t.elem=this.elem;jQuery.timers.push(t);if(jQuery.timerId==null){jQuery.timerId=setInterval(function(){var timers=jQuery.timers;for(var i=0;i<timers.length;i++)if(!timers[i]())timers.splice(i--,1);if(!timers.length){clearInterval(jQuery.timerId);jQuery.timerId=null;}},13);}},show:function(){this.options.orig[this.prop]=jQuery.attr(this.elem.style,this.prop);this.options.show=true;this.custom(0,this.cur());if(this.prop=="width"||this.prop=="height")this.elem.style[this.prop]="1px";jQuery(this.elem).show();},hide:function(){this.options.orig[this.prop]=jQuery.attr(this.elem.style,this.prop);this.options.hide=true;this.custom(this.cur(),0);},step:function(gotoEnd){var t=(new Date()).getTime();if(gotoEnd||t>this.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var done=true;for(var i in this.options.curAnim)if(this.options.curAnim[i]!==true)done=false;if(done){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(jQuery.css(this.elem,"display")=="none")this.elem.style.display="block";}if(this.options.hide)this.elem.style.display="none";if(this.options.hide||this.options.show)for(var p in this.options.curAnim)jQuery.attr(this.elem.style,p,this.options.orig[p]);}if(done&&jQuery.isFunction(this.options.complete))this.options.complete.apply(this.elem);return false;}else{var n=t-this.startTime;this.state=n/this.options.duration;this.pos=jQuery.easing[this.options.easing||(jQuery.easing.swing?"swing":"linear")](this.state,n,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update();}return true;}};jQuery.fx.step={scrollLeft:function(fx){fx.elem.scrollLeft=fx.now;},scrollTop:function(fx){fx.elem.scrollTop=fx.now;},opacity:function(fx){jQuery.attr(fx.elem.style,"opacity",fx.now);},_default:function(fx){fx.elem.style[fx.prop]=fx.now+fx.unit;}};jQuery.fn.offset=function(){var left=0,top=0,elem=this[0],results;if(elem)with(jQuery.browser){var parent=elem.parentNode,offsetChild=elem,offsetParent=elem.offsetParent,doc=elem.ownerDocument,safari2=safari&&parseInt(version)<522&&!/adobeair/i.test(userAgent),fixed=jQuery.css(elem,"position")=="fixed";if(elem.getBoundingClientRect){var box=elem.getBoundingClientRect();add(box.left+Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),box.top+Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));add(-doc.documentElement.clientLeft,-doc.documentElement.clientTop);}else{add(elem.offsetLeft,elem.offsetTop);while(offsetParent){add(offsetParent.offsetLeft,offsetParent.offsetTop);if(mozilla&&!/^t(able|d|h)$/i.test(offsetParent.tagName)||safari&&!safari2)border(offsetParent);if(!fixed&&jQuery.css(offsetParent,"position")=="fixed")fixed=true;offsetChild=/^body$/i.test(offsetParent.tagName)?offsetChild:offsetParent;offsetParent=offsetParent.offsetParent;}while(parent&&parent.tagName&&!/^body|html$/i.test(parent.tagName)){if(!/^inline|table.*$/i.test(jQuery.css(parent,"display")))add(-parent.scrollLeft,-parent.scrollTop);if(mozilla&&jQuery.css(parent,"overflow")!="visible")border(parent);parent=parent.parentNode;}if((safari2&&(fixed||jQuery.css(offsetChild,"position")=="absolute"))||(mozilla&&jQuery.css(offsetChild,"position")!="absolute"))add(-doc.body.offsetLeft,-doc.body.offsetTop);if(fixed)add(Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));}results={top:top,left:left};}function border(elem){add(jQuery.curCSS(elem,"borderLeftWidth",true),jQuery.curCSS(elem,"borderTopWidth",true));}function add(l,t){left+=parseInt(l)||0;top+=parseInt(t)||0;}return results;};})();
\ No newline at end of file
--- /dev/null
+<html>
+ <head>
+ <script type="text/javascript" src="jquery-1.2.3.min.js"></script>
+ <script type="text/javascript" src="weave.js"></script>
+ </head>
+ <body>
+ <form id="node-form">
+ <select id="nodes">
+ <option value="new">New</option>
+ </select>
+ <div id="node-content" style="display: none;"></div>
+ <div id="edit-wrapper">
+ <textarea id="node-content-edit"></textarea>
+ <button id='node-submit'>Save Node</button>
+ </div>
+ </form>
+ </body>
+</html>
--- /dev/null
+$(function() { $.getJSON("/all", false, function(json) {
+ var nodes = $('#nodes');
+ for (node in json) {
+ nodes.append("<option value='" + json[node] + "'>" + json[node] + "</option>");
+ }
+ nodes.change(function(){
+ if (this.value == 'new') {
+ $('#node-content').hide();
+ $('#edit-wrapper').show();
+ } else {
+ $('#node-content').show();
+ $('#edit-wrapper').hide();
+ $.get('/node', { node_id: this.value }, function(data){
+ $('#node-content').text(data);
+ });
+ }
+ });
+ $('#node-submit').click(function(){
+ $.post('/node', { node_content: $('#node-content-edit').val() }, function(data){
+ nodes.append("<option value='" + data + "'>" + data + "</option>");
+ var option = nodes.get(0).options[data];
+ option.selected = true;
+ nodes.change();
+ });
+ return false;
+ });
+});})
--- /dev/null
+USING: continuations db db.sqlite http.server io.files kernel namespaces semantic-db tangle tangle.path ;
+IN: tangle.sandbox
+
+: db-path "tangle-sandbox.db" temp-file ;
+: sandbox-db db-path sqlite-db ;
+: delete-db [ db-path delete-file ] ignore-errors ;
+
+: make-sandbox ( tangle -- )
+ [
+ init-semantic-db
+ ensure-root "foo" create-file "First Page" create-node swap has-filename
+ ] with-tangle ;
+
+: new-sandbox ( -- )
+ development-mode on
+ delete-db sandbox-db f <tangle>
+ [ make-sandbox ] [ <tangle-dispatcher> ] bi
+ main-responder set ;
--- /dev/null
+A web framework using semantic-db as a backend
--- /dev/null
+USING: accessors arrays continuations db db.sqlite io.files kernel semantic-db sequences tangle tangle.html tangle.menu tangle.page tangle.path tools.test tools.walker tuple-syntax ;
+IN: tangle.tests
+
+: db-path "tangle-test.db" temp-file ;
+: test-db db-path sqlite-db ;
+: delete-db [ db-path delete-file ] ignore-errors ;
+
+: test-tangle ( -- )
+ ensure-root "foo" create-file "bar" create-file "pluck_eggs" create-file
+ "How to Pluck Eggs" create-node swap has-filename
+ "Main Menu" ensure-menu "home" create-node swap subitem-of ;
+
+test-db [
+ init-semantic-db test-tangle
+ [ "pluck_eggs" ] [ { "foo" "bar" "pluck_eggs" } path>node [ node-content ] when* ] unit-test
+ [ "How to Pluck Eggs" ] [ { "foo" "bar" "pluck_eggs" } path>node [ has-filename-subjects first node-content ] when* ] unit-test
+ [ { "foo" "bar" "pluck_eggs" } ] [ { "foo" "bar" "pluck_eggs" } path>node node>path >array ] unit-test
+ [ f ] [ TUPLE{ node id: 666 content: "some content" } parent-directory ] unit-test
+ [ f ] [ TUPLE{ node id: 666 content: "some content" } node>path ] unit-test
+ [ "Main Menu" ] [ "Main Menu" ensure-menu node-content ] unit-test
+ [ t ] [ "Main Menu" ensure-menu "Main Menu" ensure-menu node= ] unit-test
+ [ "Main Menu" { "home" } ] [ "Main Menu" load-menu dup node>> node-content swap children>> [ node>> node-content ] map >array ] unit-test
+ [ { "home" } ] [ "Main Menu" load-menu menu>ulist items>> [ node>> node-content ] map >array ] unit-test
+ [ f ] [ TUPLE{ node id: 666 content: "node text" } node>path ] unit-test
+ [ "node text" ] [ TUPLE{ node id: 666 content: "node text" } >html ] unit-test
+] with-db delete-db
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
+IN: tangle
+
+GENERIC: render* ( content templater -- output )
+GENERIC: render ( content templater -- )
+
+TUPLE: echo-template ;
+C: <echo-template> echo-template
+
+M: echo-template render* drop ;
+! METHOD: render* { string echo-template } drop ;
+M: object render render* write ;
+
+TUPLE: tangle db seq templater ;
+C: <tangle> tangle
+
+: with-tangle ( tangle quot -- )
+ [ [ db>> ] [ seq>> ] bi ] dip with-db ;
+
+: <text-response> ( text -- response )
+ "text/plain" <content> swap >>body ;
+
+: node-response ( id -- response )
+ load-node [ node-content <text-response> ] [ <404> ] if* ;
+
+: display-node ( params -- response )
+ [
+ "node_id" swap at* [
+ string>number node-response
+ ] [
+ drop <400>
+ ] if
+ ] [
+ <400>
+ ] if* ;
+
+: submit-node ( params -- response )
+ [
+ "node_content" swap at* [
+ create-node id>> number>string <text-response>
+ ] [
+ drop <400>
+ ] if
+ ] [
+ <400>
+ ] if* ;
+
+: <node-responder> ( -- responder )
+ <action> [ params get display-node ] >>display
+ [ params get submit-node ] >>submit ;
+
+TUPLE: path-responder ;
+C: <path-responder> path-responder
+
+M: path-responder call-responder* ( path responder -- response )
+ drop path>file [ node-content <text-response> ] [ <404> ] if* ;
+
+: <json-response> ( obj -- response )
+ "application/json" <content> swap >json >>body ;
+
+TUPLE: tangle-dispatcher < dispatcher tangle ;
+
+: <tangle-dispatcher> ( tangle -- dispatcher )
+ tangle-dispatcher new-dispatcher swap >>tangle
+ <path-responder> >>default
+ "resource:extra/tangle/resources" <static> "resources" add-responder
+ <node-responder> "node" add-responder
+ <action> [ all-node-ids <json-response> ] >>display "all" add-responder ;
+
+M: tangle-dispatcher call-responder* ( path dispatcher -- response )
+ dup tangle>> [
+ find-responder call-responder
+ ] with-tangle ;
-USING: combinators io io.files io.streams.duplex
-io.streams.string kernel math math.parser continuations
-namespaces pack prettyprint sequences strings system
-hexdump io.encodings.binary inspector accessors ;
+USING: combinators io io.files io.streams.string kernel math
+math.parser continuations namespaces pack prettyprint sequences
+strings system hexdump io.encodings.binary inspector accessors ;
IN: tar
: zero-checksum 256 ;
] if* ;
: read-data-blocks ( tar-header out -- )
- >r stdio get r> <duplex-stream> [
- (read-data-blocks)
- ] with-stream* ;
+ [ (read-data-blocks) ] with-output-stream* ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
1000000 2008 3 t <w4> <minnesota> net
dollars/cents
] unit-test
+
+
+[ 30 97 ] [
+ 24000 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
+] unit-test
+
+[ 173 66 ] [
+ 78250 2008 2 f <w4> <minnesota> withholding biweekly dollars/cents
+] unit-test
+
+
+[ 138 69 ] [
+ 24000 2008 2 f <w4> <federal> withholding biweekly dollars/cents
+] unit-test
+
+[ 754 72 ] [
+ 78250 2008 2 f <w4> <federal> withholding biweekly dollars/cents
+] unit-test
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
inspector layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.streams.duplex io.files io.backend
+debugger io.streams.c io.files io.backend
quotations io.launcher words.private tools.deploy.config
bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
+stdout+ >>stderr
+closed+ >>stdin
+low-priority+ >>priority
- utf8 <process-stream*>
- >r copy-lines r> wait-for-process zero? [
- "Deployment failed" throw
- ] unless ;
+ utf8 <process-reader*>
+ copy-lines
+ wait-for-process zero? [ "Deployment failed" throw ] unless ;
: make-boot-image ( -- )
#! If stage1 image doesn't exist, create one.
dup empty? [
"-i=" my-boot-image-name append ,
] [
- dup 1 head* ?make-staging-image
+ dup but-last ?make-staging-image
"-resource-path=" "" resource-path append ,
- "-i=" over 1 head* staging-image-name append ,
+ "-i=" over but-last staging-image-name append ,
"-run=tools.deploy.restage" ,
] if
continuations:error-continuation
continuations:error-thread
continuations:restarts
- error-hook
+ listener:error-hook
init:init-hooks
inspector:inspector-hook
io.thread:io-thread
libc.private:mallocs
source-files:source-files
- stderr
- stdio
+ input-stream
+ output-stream
+ error-stream
} %
deploy-threads? [
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
- classes:class<-cache
+ classes:class<=-cache
classes:classes-intersect-cache
classes:update-map
command-line:main-vocab-hook
HELP: counters.
{ $values { "assoc" "an association list mapping words to integers" } }
-{ $description "Prints an association list of call counts to the " { $link stdio } " stream." } ;
+{ $description "Prints an association list of call counts to " { $link output-stream } "." } ;
HELP: profile
{ $values { "quot" quotation } }
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." } ;
+{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ;
io ;
IN: tools.test.ui
-! We can't print to stdio here because that might be a pane
+! We can't print to output-stream here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
! by code adding children to the pane...
: with-grafted-gadget ( gadget quot -- )
dup ".factor" tail? [ parent-directory ] when ;\r
\r
: chop-vocab-root ( path -- path' )\r
- "resource:" prepend-path (normalize-path)\r
+ "resource:" prepend-path normalize-path\r
dup vocab-roots get\r
- [ (normalize-path) ] map\r
+ [ normalize-path ] map\r
[ head? ] with find nip\r
?head drop ;\r
\r
reset-cache\r
monitor-loop ;\r
\r
-: add-monitor-for-path ( path -- ) \r
- normalize-path dup exists? [ t my-mailbox (monitor) ] when drop ;\r
- \r
+: add-monitor-for-path ( path -- )\r
+ dup exists? [ t my-mailbox (monitor) ] when drop ;\r
+\r
: monitor-thread ( -- )\r
[\r
[\r
vocab-roots get prune [ add-monitor-for-path ] each\r
- \r
+\r
H{ } clone changed-vocabs set-global\r
vocabs [ changed-vocab ] each\r
- \r
+\r
monitor-loop\r
] with-monitors\r
] ignore-errors ;\r
USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs\r
sequences namespaces math.parser arrays hashtables assocs\r
memoize inspector sorting splitting combinators source-files\r
-io debugger continuations compiler.errors init io.crc32 \r
-sets ;\r
+io debugger continuations compiler.errors init\r
+checksums checksums.crc32 sets ;\r
IN: tools.vocabs\r
\r
: vocab-tests-file ( vocab -- path )\r
dup source-files get at [\r
dup source-file-path\r
dup exists? [\r
- utf8 file-lines lines-crc32\r
+ utf8 file-lines crc32 checksum-lines\r
swap source-file-checksum = not\r
] [\r
2drop f\r
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 }
+ T{ avl-node f "key1" f f T{ avl-node f "key2" f f 1 } 2 }
[ single-rotate ] go-left
[ node-left dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance
] unit-test
[ "key1" 0 "key2" 0 ] [
- T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
+ T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 1 } 2 }
[ select-rotate ] go-left
[ node-left dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance
] unit-test
[ "key1" 0 "key2" 0 ] [
- T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 }
+ T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
[ single-rotate ] go-right
[ node-right dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance
] unit-test
[ "key1" 0 "key2" 0 ] [
- T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 }
+ T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -2 }
[ select-rotate ] go-right
[ node-right dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance
] unit-test
[ "key1" -1 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } 1 } }
- -1 } }
- 2 } [ double-rotate ] go-left
+[ T{ avl-node f "key1" f f
+ T{ avl-node f "key2" f
+ T{ avl-node f "key3" f f f 1 } f -1 } 2 }
+ [ double-rotate ] go-left
[ node-left dup node-key swap avl-node-balance ] keep
[ node-right dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance ] unit-test
[ "key1" 0 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } 0 } }
- -1 } }
- 2 } [ double-rotate ] go-left
+[ T{ avl-node f "key1" f f
+ T{ avl-node f "key2" f
+ T{ avl-node f "key3" f f f 0 } f -1 } 2 }
+ [ double-rotate ] go-left
[ node-left dup node-key swap avl-node-balance ] keep
[ node-right dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance ] unit-test
[ "key1" 0 "key2" 1 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f f
- T{ avl-node T{ node f "key2" f
- T{ avl-node T{ node f "key3" } -1 } }
- -1 } }
- 2 } [ double-rotate ] go-left
+[ T{ avl-node f "key1" f f
+ T{ avl-node f "key2" f
+ T{ avl-node f "key3" f f f -1 } f -1 } 2 }
+ [ double-rotate ] go-left
[ node-left dup node-key swap avl-node-balance ] keep
[ node-right dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance ] unit-test
[ "key1" 1 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } -1 } }
- 1 } }
- -2 } [ double-rotate ] go-right
+[ T{ avl-node f "key1" f
+ T{ avl-node f "key2" f f
+ T{ avl-node f "key3" f f f -1 } 1 } f -2 }
+ [ double-rotate ] go-right
[ node-right dup node-key swap avl-node-balance ] keep
[ node-left dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance ] unit-test
[ "key1" 0 "key2" 0 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } 0 } }
- 1 } }
- -2 } [ double-rotate ] go-right
+[ T{ avl-node f "key1" f
+ T{ avl-node f "key2" f f
+ T{ avl-node f "key3" f f f 0 } 1 } f -2 }
+ [ double-rotate ] go-right
[ node-right dup node-key swap avl-node-balance ] keep
[ node-left dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance ] unit-test
[ "key1" 0 "key2" -1 "key3" 0 ]
-[ T{ avl-node T{ node f "key1" f
- T{ avl-node T{ node f "key2" f f
- T{ avl-node T{ node f "key3" } 1 } }
- 1 } }
- -2 } [ double-rotate ] go-right
+[ T{ avl-node f "key1" f
+ T{ avl-node f "key2" f f
+ T{ avl-node f "key3" f f f 1 } 1 } f -2 }
+ [ double-rotate ] go-right
[ node-right dup node-key swap avl-node-balance ] keep
[ node-left dup node-key swap avl-node-balance ] keep
dup node-key swap avl-node-balance ] unit-test
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel generic math math.functions math.parser
-namespaces io prettyprint.backend sequences trees assocs parser
-math.order ;
+USING: combinators kernel generic math math.functions
+math.parser namespaces io prettyprint.backend sequences trees
+assocs parser accessors math.order ;
IN: trees.avl
-TUPLE: avl ;
-
-INSTANCE: avl tree-mixin
+TUPLE: avl < tree ;
: <avl> ( -- tree )
- avl construct-tree ;
+ avl new-tree ;
-TUPLE: avl-node balance ;
+TUPLE: avl-node < node balance ;
: <avl-node> ( key value -- node )
- swap <node> 0 avl-node boa tuck set-delegate ;
+ avl-node new-node
+ 0 >>balance ;
-: change-balance ( node amount -- )
- over avl-node-balance + swap set-avl-node-balance ;
+: increase-balance ( node amount -- )
+ swap [ + ] change-balance drop ;
: rotate ( node -- node )
- dup node+link dup node-link pick set-node+link tuck set-node-link ;
+ dup node+link dup node-link pick set-node+link
+ tuck set-node-link ;
: single-rotate ( node -- node )
- 0 over set-avl-node-balance 0 over node+link set-avl-node-balance rotate ;
+ 0 over (>>balance) 0 over node+link
+ (>>balance) rotate ;
: pick-balances ( a node -- balance balance )
- avl-node-balance {
+ balance>> {
{ [ dup zero? ] [ 2drop 0 0 ] }
{ [ over = ] [ neg 0 ] }
[ 0 swap ]
: double-rotate ( node -- node )
[
node+link [
- node-link current-side get neg over pick-balances rot 0 swap set-avl-node-balance
- ] keep set-avl-node-balance
- ] keep tuck set-avl-node-balance
- dup node+link [ rotate ] with-other-side over set-node+link rotate ;
+ node-link current-side get neg
+ over pick-balances rot 0 swap (>>balance)
+ ] keep (>>balance)
+ ] keep swap >>balance
+ dup node+link [ rotate ] with-other-side
+ over set-node+link rotate ;
: select-rotate ( node -- node )
- dup node+link avl-node-balance current-side get = [ double-rotate ] [ single-rotate ] if ;
+ dup node+link balance>> current-side get =
+ [ double-rotate ] [ single-rotate ] if ;
: balance-insert ( node -- node taller? )
dup avl-node-balance {
{ [ dup zero? ] [ drop f ] }
- { [ dup abs 2 = ] [ sgn neg [ select-rotate ] with-side f ] }
+ { [ dup abs 2 = ]
+ [ sgn neg [ select-rotate ] with-side f ] }
{ [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
} cond ;
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
+ [ dup current-side get increase-balance balance-insert ]
+ [ f ] if
] with-side ;
: (avl-set) ( value key node -- node taller? )
] [ avl-insert ] if ;
: avl-set ( value key node -- node taller? )
- [ (avl-set) ] [ <avl-node> t ] if* ;
+ [ (avl-set) ] [
swap <avl-node> t ] if* ;
M: avl set-at ( value key node -- node )
- [ avl-set drop ] change-root ;
+ [ avl-set drop ] change-root drop ;
: delete-select-rotate ( node -- node shorter? )
dup node+link avl-node-balance zero? [
} cond ;
: balance-delete ( node -- node shorter? )
- current-side get over avl-node-balance {
+ current-side get over balance>> {
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
- { [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
- [ dupd neg change-balance rebalance-delete ]
+ { [ dupd = ] [ drop 0 >>balance t ] }
+ [ dupd neg increase-balance rebalance-delete ]
} cond ;
: avl-replace-with-extremity ( to-replace node -- node shorter? )
] if ;
M: avl delete-at ( key node -- )
- [ avl-delete 2drop ] change-root ;
+ [ avl-delete 2drop ] change-root drop ;
M: avl new-assoc 2drop <avl> ;
: >avl ( assoc -- avl )
- T{ avl T{ tree f f 0 } } assoc-clone-like ;
+ T{ avl f f 0 } assoc-clone-like ;
M: avl assoc-like
drop dup avl? [ >avl ] unless ;
prettyprint.backend trees generic math.order ;
IN: trees.splay
-TUPLE: splay ;
+TUPLE: splay < tree ;
: <splay> ( -- tree )
- \ splay construct-tree ;
-
-INSTANCE: splay tree-mixin
+ \ splay new-tree ;
: rotate-right ( node -- node )
dup node-left
2drop <splay> ;
: >splay ( assoc -- tree )
- T{ splay T{ tree f f 0 } } assoc-clone-like ;
+ T{ splay f f 0 } assoc-clone-like ;
: SPLAY{
\ } [ >splay ] parse-literal ; parsing
parser prettyprint.backend math.order accessors ;
IN: trees
-MIXIN: tree-mixin
-
TUPLE: tree root count ;
+: new-tree ( class -- tree )
+ new
+ f >>root
+ 0 >>count ; inline
+
: <tree> ( -- tree )
- f 0 tree boa ;
+ tree new-tree ;
-: construct-tree ( class -- tree )
- new <tree> over set-delegate ; inline
+INSTANCE: tree assoc
-INSTANCE: tree tree-mixin
+TUPLE: node key value left right ;
-INSTANCE: tree-mixin assoc
+: new-node ( key value class -- node )
+ new swap >>value swap >>key ;
-TUPLE: node key value left right ;
: <node> ( key value -- node )
- f f node boa ;
+ node new-node ;
SYMBOL: current-side
: go-left ( quot -- ) left swap with-side ; inline
: go-right ( quot -- ) right swap with-side ; inline
-: change-root ( tree quot -- )
- swap [ root>> swap call ] keep set-tree-root ; inline
-
: leaf? ( node -- ? )
[ left>> ] [ right>> ] bi or not ;
] if ;
M: tree set-at ( value key tree -- )
- [ [ node-set ] [ swap <node> ] if* ] change-root ;
+ [ [ node-set ] [ swap <node> ] if* ] change-root drop ;
: valid-node? ( node -- ? )
[
[ >r right>> r> find-node ]
} cond ; inline
-M: tree-mixin assoc-find ( tree quot -- key value ? )
+M: tree assoc-find ( tree quot -- key value ? )
>r root>> r> find-node ;
-M: tree-mixin clear-assoc
+M: tree clear-assoc
0 >>count
f >>root drop ;
] if ;
M: tree delete-at
- [ delete-bst-node ] change-root ;
+ [ delete-bst-node ] change-root drop ;
M: tree new-assoc
2drop <tree> ;
: >tree ( assoc -- tree )
T{ tree f f 0 } assoc-clone-like ;
-M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
+M: tree assoc-like drop dup tree? [ >tree ] unless ;
: TREE{
\ } [ >tree ] parse-literal ; parsing
-
+
M: tree pprint-delims drop \ TREE{ \ } ;
-
-M: tree-mixin assoc-size count>> ;
-M: tree-mixin clone dup assoc-clone-like ;
-M: tree-mixin >pprint-sequence >alist ;
-M: tree-mixin pprint-narrow? drop t ;
+M: tree assoc-size count>> ;
+M: tree >pprint-sequence >alist ;
+M: tree pprint-narrow? drop t ;
: parse-slot-writer ( tuple -- slot# )
scan dup "}" = [ 2drop f ] [
- 1 head* swap object-slots slot-named slot-spec-offset
+ but-last swap object-slots slot-named slot-spec-offset
] if ;
: parse-slots ( accum tuple -- accum tuple )
dup mock-gadget-ungraft-called 1+
swap set-mock-gadget-ungraft-called ;
-! We can't print to stdio here because that might be a pane
+! We can't print to output-stream here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
! by code adding children to the pane...
[
HELP: gadget.
{ $values { "gadget" gadget } }
-{ $description "Writes a gadget followed by a newline to the " { $link stdio } " stream." }
+{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
{ $notes "Not all streams support this operation." } ;
HELP: ?nl
HELP: with-pane
{ $values { "pane" pane } { "quot" quotation } }
-{ $description "Clears the pane and calls the quotation in a new scope where " { $link stdio } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
+{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
HELP: make-pane
{ $values { "quot" quotation } { "gadget" "a new " { $link gadget } } }
-{ $description "Calls the quotation in a new scope where " { $link stdio } " is rebound to a " { $link pane-stream } " writing to a new pane. The output area of the new pane is output on the stack after the quotation returns. The pane itself is not output." } ;
+{ $description "Calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to a new pane. The output area of the new pane is output on the stack after the quotation returns. The pane itself is not output." } ;
HELP: <scrolling-pane>
{ $values { "pane" "a new " { $link pane } } }
[ ] [ #children "num-children" set ] unit-test
[ ] [
- "pane" get <pane-stream> [ 10000 [ . ] each ] with-stream*
+ "pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
] unit-test
[ t ] [ #children "num-children" get = ] unit-test
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
-io.streams.duplex sorting splitting io.streams.nested assocs
+sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations ;
IN: ui.gadgets.panes
M: pane-stream write-gadget
pane-stream-pane pane-current add-gadget ;
-M: duplex-stream write-gadget
- duplex-stream-out write-gadget ;
-
: print-gadget ( gadget stream -- )
tuck write-gadget stream-nl ;
: gadget. ( gadget -- )
- stdio get print-gadget ;
+ output-stream get print-gadget ;
: ?nl ( stream -- )
dup pane-stream-pane pane-current gadget-children empty?
: with-pane ( pane quot -- )
over scroll>top
over pane-clear >r <pane-stream> r>
- over >r with-stream* r> ?nl ; inline
+ over >r with-output-stream* r> ?nl ; inline
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture )
- tuple>array 1 head* >tuple ;
+ tuple>array but-last >tuple ;
! Modifiers
SYMBOLS: C+ A+ M+ S+ ;
] if ;
: drag-gesture ( -- )
- hand-buttons get-global first <drag> button-gesture ;
+ hand-buttons get-global
+ dup empty? [ drop ] [ first <drag> button-gesture ] if ;
SYMBOL: drag-timer
IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser ;
+tools.test kernel calendar parser accessors ;
-[
- \ <interactor> must-infer
+\ <interactor> must-infer
+[
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+ [ ] [ "interactor" get register-self ] unit-test
+
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
[ ] [ <promise> "promise" set ] unit-test
[
+ self "interactor" get (>>thread)
"interactor" get stream-read-quot "promise" get fulfill
] "Interactor test" spawn drop
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
] with-interactive-vocabs
+
+! Hang
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
+
+[ ] [ 1000 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
- hashtables io io.styles kernel math
-math.vectors models namespaces parser prettyprint quotations
-sequences strings threads listener
-classes.tuple ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar concurrency.flags ui.tools.workspace
-accessors math.order ;
+hashtables io io.styles kernel math math.order math.vectors
+models namespaces parser prettyprint quotations sequences
+strings threads listener classes.tuple ui.commands ui.gadgets
+ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
+ui.gestures definitions calendar concurrency.flags
+concurrency.mailboxes ui.tools.workspace accessors ;
IN: ui.tools.interactor
-TUPLE: interactor history output flag thread help ;
+! If waiting is t, we're waiting for user input, and invoking
+! evaluate-input resumes the thread.
+TUPLE: interactor output history flag mailbox thread waiting help ;
+
+: register-self ( interactor -- )
+ <mailbox> >>mailbox
+ self >>thread
+ drop ;
: interactor-continuation ( interactor -- continuation )
- interactor-thread box-value
- thread-continuation box-value ;
+ thread>> continuation>> value>> ;
: interactor-busy? ( interactor -- ? )
- interactor-thread box-full? not ;
+ #! We're busy if there's no thread to resume.
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ bi and not ;
: interactor-use ( interactor -- seq )
dup interactor-busy? [ drop f ] [
use swap
- interactor-continuation continuation-name
+ interactor-continuation name>>
assoc-stack
] if ;
-: init-caret-help ( interactor -- )
- 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 ;
+: <help-model> ( interactor -- model )
+ editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
- tuck set-interactor-output
- dup init-interactor-history
- dup init-interactor-state
- dup init-caret-help ;
+ V{ } clone >>history
+ <flag> >>flag
+ dup <help-model> >>help
+ swap >>output ;
M: interactor graft*
- dup delegate graft*
- dup interactor-help add-connection ;
+ [ delegate graft* ] [ dup help>> add-connection ] bi ;
+
+M: interactor ungraft*
+ [ dup help>> remove-connection ] [ delegate ungraft ] bi ;
: word-at-loc ( loc interactor -- word )
over [
] if ;
M: interactor model-changed
- 2dup interactor-help eq? [
+ 2dup help>> eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
[ H{ { font-style bold } } format ] with-nesting ;
: interactor-input. ( string interactor -- )
- interactor-output [
+ output>> [
dup string? [ dup write-input nl ] [ short. ] if
- ] with-stream* ;
+ ] with-output-stream* ;
: add-interactor-history ( str interactor -- )
over empty? [ 2drop ] [ interactor-history push-new ] if ;
: interactor-continue ( obj interactor -- )
- interactor-thread box> resume-with ;
+ mailbox>> mailbox-put ;
: clear-input ( interactor -- ) gadget-model clear-doc ;
] unless drop ;
: interactor-yield ( interactor -- obj )
- [
- [ interactor-thread >box ] keep
- interactor-flag raise-flag
- ] curry "input" suspend ;
+ dup thread>> self eq? [
+ {
+ [ t >>waiting drop ]
+ [ flag>> raise-flag ]
+ [ mailbox>> mailbox-get ]
+ [ f >>waiting drop ]
+ } cleave
+ ] [ drop f ] if ;
M: interactor stream-readln
- [ interactor-yield ] keep interactor-finish
+ [ interactor-yield ] [ interactor-finish ] bi
dup [ first ] when ;
: interactor-call ( quot interactor -- )
} cond ;
M: interactor pref-dim*
- 0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
+ [ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
+ vmax ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic ;
+threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
[ "dup" ] [
\ dup word-completion-string
] unit-test
-
+
[ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test
[ ] [
"i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
] unit-test
-
+
[ t ] [
"i" get gadget-model doc-end
"i" get editor-caret* =
] unit-test
+
+ ! Race condition discovered by SimonRC
+ [ ] [
+ [
+ "listener" get input>>
+ [ stream-read-quot drop ]
+ [ stream-read-quot drop ] bi
+ ] "OH, HAI" spawn drop
+ ] unit-test
+
+ [ ] [ "listener" get clear-output ] unit-test
+
+ [ ] [ "listener" get restart-listener ] unit-test
+
+ [ ] [ 1000 sleep ] unit-test
+
+ [ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
-ui.tools.workspace help.markup io io.streams.duplex io.styles
+ui.tools.workspace help.markup io io.styles
kernel models namespaces parser quotations sequences ui.commands
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 boxes concurrency.flags
-math arrays generic accessors combinators ;
+math arrays generic accessors combinators assocs ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
<scrolling-pane> g-> set-listener-gadget-output
<scroller> "Output" <labelled-gadget> 1 track, ;
-: listener-stream ( listener -- stream )
- dup listener-gadget-input
- swap listener-gadget-output <pane-stream>
- <duplex-stream> ;
+: listener-streams ( listener -- input output )
+ [ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget )
-
listener-gadget-output <pane-stream> <interactor> ;
+
output>> <pane-stream> <interactor> ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
"cookbook" ($link) "." print nl ;
M: listener-gadget focusable-child*
- listener-gadget-input ;
+ input>> ;
M: listener-gadget call-tool* ( input listener -- )
- >r input-string r> listener-gadget-input set-editor-string ;
+ >r string>> r> input>> set-editor-string ;
M: listener-gadget tool-scroller
- listener-gadget-output find-scroller ;
+ output>> find-scroller ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
- listener-gadget-input interactor-flag wait-for-flag ;
+ input>> flag>> wait-for-flag ;
: workspace-busy? ( workspace -- ? )
- workspace-listener listener-gadget-input interactor-busy? ;
+ listener>> input>> interactor-busy? ;
: listener-input ( string -- )
- get-workspace
- workspace-listener
- listener-gadget-input set-editor-string ;
+ get-workspace listener>> input>> set-editor-string ;
: (call-listener) ( quot listener -- )
- listener-gadget-input interactor-call ;
+ input>> interactor-call ;
: call-listener ( quot -- )
- [ workspace-busy? not ] get-workspace* workspace-listener
+ [ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry
"Listener call" spawn drop ;
: eval-listener ( string -- )
get-workspace
- workspace-listener
- listener-gadget-input [ set-editor-string ] keep
+ listener>> input>> [ set-editor-string ] keep
evaluate-input ;
: listener-run-files ( seq -- )
] if ;
: com-end ( listener -- )
- listener-gadget-input interactor-eof ;
+ input>> interactor-eof ;
: clear-output ( listener -- )
- listener-gadget-output pane-clear ;
+ output>> pane-clear ;
\ clear-output H{ { +listener+ t } } define-command
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
- >r word-vocabulary vocab-words r>
- {
- { [ dup not ] [ 2drop ] }
- { [ 2dup memq? ] [ 2drop ] }
- [ push ]
- } cond ;
+ over word-vocabulary [
+ 2dup assoc-stack pick = [ 2drop ] [
+ >r word-vocabulary vocab-words r> push
+ ] if
+ ] [ 2drop ] if ;
: insert-word ( word -- )
get-workspace workspace-listener input>>
stack-display new
g workspace-listener swap [
dup <toolbar> f track,
- listener-gadget-stack [ stack. ]
+ stack>> [ [ stack. ] curry try ]
t "Data stack" <labelled-pane> 1 track,
] { 0 1 } build-track ;
swap show-tool inspect-object ;
: listener-thread ( listener -- )
- dup listener-stream [
- dup [ ui-listener-hook ] curry listener-hook set
- dup [ ui-error-hook ] curry error-hook set
- [ ui-inspector-hook ] curry inspector-hook set
+ dup listener-streams [
+ [ [ ui-listener-hook ] curry listener-hook set ]
+ [ [ ui-error-hook ] curry error-hook set ]
+ [ [ ui-inspector-hook ] curry inspector-hook set ] tri
welcome.
listener
- ] with-stream* ;
+ ] with-streams* ;
: start-listener-thread ( listener -- )
- [ listener-thread ] curry "Listener" spawn drop ;
+ [
+ [ input>> register-self ] [ listener-thread ] bi
+ ] curry "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
- dup com-end dup clear-output
- dup start-listener-thread
- wait-for-listener ;
+ {
+ [ com-end ]
+ [ clear-output ]
+ [ start-listener-thread ]
+ [ wait-for-listener ]
+ } cleave ;
: init-listener ( listener -- )
f <model> swap set-listener-gadget-stack ;
[ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft*
- dup delegate graft*
- dup listener-gadget-input interactor-thread ?box 2drop
- restart-listener ;
+ [ delegate graft* ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- dup com-end
- delegate ungraft* ;
+ [ com-end ] [ delegate ungraft* ] bi ;
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-math.ranges unicode.normalize
+math.ranges unicode.normalize unicode.syntax.backend
unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
IN: unicode.breaks
concat [ dup ] H{ } map>assoc ;
: other-extend-lines ( -- lines )
- "extra/unicode/PropList.txt" resource-path ascii file-lines ;
+ "resource:extra/unicode/PropList.txt" ascii file-lines ;
VALUE: other-extend
: string-reverse ( str -- rts )
>graphemes reverse concat ;
-: unclip-last-slice ( seq -- beginning last )
- dup 1 head-slice* swap peek ;
-
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
[ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
USING: assocs math kernel sequences io.files hashtables
quotations splitting arrays math.parser hash2 math.order
byte-arrays words namespaces words compiler.units parser
-io.encodings.ascii ;
+io.encodings.ascii unicode.syntax.backend ;
IN: unicode.data
-<<
-: VALUE:
- CREATE-WORD { f } clone [ first ] curry define ; parsing
-
-: set-value ( value word -- )
- word-def first set-first ;
->>
-
! Convenience functions
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
ascii file-lines [ ";" split ] map ;
: load-data ( -- data )
- "extra/unicode/UnicodeData.txt" resource-path data ;
+ "resource:extra/unicode/UnicodeData.txt" data ;
: (process-data) ( index data -- newdata )
[ [ nth ] keep first swap 2array ] with map
! Special casing data
: load-special-casing ( -- special-casing )
- "extra/unicode/SpecialCasing.txt" resource-path data
+ "resource:extra/unicode/SpecialCasing.txt" data
[ length 5 = ] filter
[ [ set-code-point ] each ] H{ } make-assoc ;
--- /dev/null
+# Scripts-5.1.0.txt
+# Date: 2008-03-20, 17:55:33 GMT [MD]
+#
+# Unicode Character Database
+# Copyright (c) 1991-2008 Unicode, Inc.
+# For terms of use, see http://www.unicode.org/terms_of_use.html
+# For documentation, see UCD.html
+
+# ================================================
+
+# Property: Script
+
+# All code points not explicitly listed for Script
+# have the value Unknown (Zzzz).
+
+# @missing: 0000..10FFFF; Unknown
+
+# ================================================
+
+0000..001F ; Common # Cc [32] <control-0000>..<control-001F>
+0020 ; Common # Zs SPACE
+0021..0023 ; Common # Po [3] EXCLAMATION MARK..NUMBER SIGN
+0024 ; Common # Sc DOLLAR SIGN
+0025..0027 ; Common # Po [3] PERCENT SIGN..APOSTROPHE
+0028 ; Common # Ps LEFT PARENTHESIS
+0029 ; Common # Pe RIGHT PARENTHESIS
+002A ; Common # Po ASTERISK
+002B ; Common # Sm PLUS SIGN
+002C ; Common # Po COMMA
+002D ; Common # Pd HYPHEN-MINUS
+002E..002F ; Common # Po [2] FULL STOP..SOLIDUS
+0030..0039 ; Common # Nd [10] DIGIT ZERO..DIGIT NINE
+003A..003B ; Common # Po [2] COLON..SEMICOLON
+003C..003E ; Common # Sm [3] LESS-THAN SIGN..GREATER-THAN SIGN
+003F..0040 ; Common # Po [2] QUESTION MARK..COMMERCIAL AT
+005B ; Common # Ps LEFT SQUARE BRACKET
+005C ; Common # Po REVERSE SOLIDUS
+005D ; Common # Pe RIGHT SQUARE BRACKET
+005E ; Common # Sk CIRCUMFLEX ACCENT
+005F ; Common # Pc LOW LINE
+0060 ; Common # Sk GRAVE ACCENT
+007B ; Common # Ps LEFT CURLY BRACKET
+007C ; Common # Sm VERTICAL LINE
+007D ; Common # Pe RIGHT CURLY BRACKET
+007E ; Common # Sm TILDE
+007F..009F ; Common # Cc [33] <control-007F>..<control-009F>
+00A0 ; Common # Zs NO-BREAK SPACE
+00A1 ; Common # Po INVERTED EXCLAMATION MARK
+00A2..00A5 ; Common # Sc [4] CENT SIGN..YEN SIGN
+00A6..00A7 ; Common # So [2] BROKEN BAR..SECTION SIGN
+00A8 ; Common # Sk DIAERESIS
+00A9 ; Common # So COPYRIGHT SIGN
+00AB ; Common # Pi LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+00AC ; Common # Sm NOT SIGN
+00AD ; Common # Cf SOFT HYPHEN
+00AE ; Common # So REGISTERED SIGN
+00AF ; Common # Sk MACRON
+00B0 ; Common # So DEGREE SIGN
+00B1 ; Common # Sm PLUS-MINUS SIGN
+00B2..00B3 ; Common # No [2] SUPERSCRIPT TWO..SUPERSCRIPT THREE
+00B4 ; Common # Sk ACUTE ACCENT
+00B5 ; Common # L& MICRO SIGN
+00B6 ; Common # So PILCROW SIGN
+00B7 ; Common # Po MIDDLE DOT
+00B8 ; Common # Sk CEDILLA
+00B9 ; Common # No SUPERSCRIPT ONE
+00BB ; Common # Pf RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+00BC..00BE ; Common # No [3] VULGAR FRACTION ONE QUARTER..VULGAR FRACTION THREE QUARTERS
+00BF ; Common # Po INVERTED QUESTION MARK
+00D7 ; Common # Sm MULTIPLICATION SIGN
+00F7 ; Common # Sm DIVISION SIGN
+02B9..02C1 ; Common # Lm [9] MODIFIER LETTER PRIME..MODIFIER LETTER REVERSED GLOTTAL STOP
+02C2..02C5 ; Common # Sk [4] MODIFIER LETTER LEFT ARROWHEAD..MODIFIER LETTER DOWN ARROWHEAD
+02C6..02D1 ; Common # Lm [12] MODIFIER LETTER CIRCUMFLEX ACCENT..MODIFIER LETTER HALF TRIANGULAR COLON
+02D2..02DF ; Common # Sk [14] MODIFIER LETTER CENTRED RIGHT HALF RING..MODIFIER LETTER CROSS ACCENT
+02E5..02EB ; Common # Sk [7] MODIFIER LETTER EXTRA-HIGH TONE BAR..MODIFIER LETTER YANG DEPARTING TONE MARK
+02EC ; Common # Lm MODIFIER LETTER VOICING
+02ED ; Common # Sk MODIFIER LETTER UNASPIRATED
+02EE ; Common # Lm MODIFIER LETTER DOUBLE APOSTROPHE
+02EF..02FF ; Common # Sk [17] MODIFIER LETTER LOW DOWN ARROWHEAD..MODIFIER LETTER LOW LEFT ARROW
+0374 ; Common # Lm GREEK NUMERAL SIGN
+037E ; Common # Po GREEK QUESTION MARK
+0385 ; Common # Sk GREEK DIALYTIKA TONOS
+0387 ; Common # Po GREEK ANO TELEIA
+0589 ; Common # Po ARMENIAN FULL STOP
+0600..0603 ; Common # Cf [4] ARABIC NUMBER SIGN..ARABIC SIGN SAFHA
+060C ; Common # Po ARABIC COMMA
+061B ; Common # Po ARABIC SEMICOLON
+061F ; Common # Po ARABIC QUESTION MARK
+0640 ; Common # Lm ARABIC TATWEEL
+0660..0669 ; Common # Nd [10] ARABIC-INDIC DIGIT ZERO..ARABIC-INDIC DIGIT NINE
+06DD ; Common # Cf ARABIC END OF AYAH
+0964..0965 ; Common # Po [2] DEVANAGARI DANDA..DEVANAGARI DOUBLE DANDA
+0970 ; Common # Po DEVANAGARI ABBREVIATION SIGN
+0CF1..0CF2 ; Common # So [2] KANNADA SIGN JIHVAMULIYA..KANNADA SIGN UPADHMANIYA
+0E3F ; Common # Sc THAI CURRENCY SYMBOL BAHT
+10FB ; Common # Po GEORGIAN PARAGRAPH SEPARATOR
+16EB..16ED ; Common # Po [3] RUNIC SINGLE PUNCTUATION..RUNIC CROSS PUNCTUATION
+1735..1736 ; Common # Po [2] PHILIPPINE SINGLE PUNCTUATION..PHILIPPINE DOUBLE PUNCTUATION
+1802..1803 ; Common # Po [2] MONGOLIAN COMMA..MONGOLIAN FULL STOP
+1805 ; Common # Po MONGOLIAN FOUR DOTS
+2000..200A ; Common # Zs [11] EN QUAD..HAIR SPACE
+200B ; Common # Cf ZERO WIDTH SPACE
+200E..200F ; Common # Cf [2] LEFT-TO-RIGHT MARK..RIGHT-TO-LEFT MARK
+2010..2015 ; Common # Pd [6] HYPHEN..HORIZONTAL BAR
+2016..2017 ; Common # Po [2] DOUBLE VERTICAL LINE..DOUBLE LOW LINE
+2018 ; Common # Pi LEFT SINGLE QUOTATION MARK
+2019 ; Common # Pf RIGHT SINGLE QUOTATION MARK
+201A ; Common # Ps SINGLE LOW-9 QUOTATION MARK
+201B..201C ; Common # Pi [2] SINGLE HIGH-REVERSED-9 QUOTATION MARK..LEFT DOUBLE QUOTATION MARK
+201D ; Common # Pf RIGHT DOUBLE QUOTATION MARK
+201E ; Common # Ps DOUBLE LOW-9 QUOTATION MARK
+201F ; Common # Pi DOUBLE HIGH-REVERSED-9 QUOTATION MARK
+2020..2027 ; Common # Po [8] DAGGER..HYPHENATION POINT
+2028 ; Common # Zl LINE SEPARATOR
+2029 ; Common # Zp PARAGRAPH SEPARATOR
+202A..202E ; Common # Cf [5] LEFT-TO-RIGHT EMBEDDING..RIGHT-TO-LEFT OVERRIDE
+202F ; Common # Zs NARROW NO-BREAK SPACE
+2030..2038 ; Common # Po [9] PER MILLE SIGN..CARET
+2039 ; Common # Pi SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+203A ; Common # Pf SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+203B..203E ; Common # Po [4] REFERENCE MARK..OVERLINE
+203F..2040 ; Common # Pc [2] UNDERTIE..CHARACTER TIE
+2041..2043 ; Common # Po [3] CARET INSERTION POINT..HYPHEN BULLET
+2044 ; Common # Sm FRACTION SLASH
+2045 ; Common # Ps LEFT SQUARE BRACKET WITH QUILL
+2046 ; Common # Pe RIGHT SQUARE BRACKET WITH QUILL
+2047..2051 ; Common # Po [11] DOUBLE QUESTION MARK..TWO ASTERISKS ALIGNED VERTICALLY
+2052 ; Common # Sm COMMERCIAL MINUS SIGN
+2053 ; Common # Po SWUNG DASH
+2054 ; Common # Pc INVERTED UNDERTIE
+2055..205E ; Common # Po [10] FLOWER PUNCTUATION MARK..VERTICAL FOUR DOTS
+205F ; Common # Zs MEDIUM MATHEMATICAL SPACE
+2060..2064 ; Common # Cf [5] WORD JOINER..INVISIBLE PLUS
+206A..206F ; Common # Cf [6] INHIBIT SYMMETRIC SWAPPING..NOMINAL DIGIT SHAPES
+2070 ; Common # No SUPERSCRIPT ZERO
+2074..2079 ; Common # No [6] SUPERSCRIPT FOUR..SUPERSCRIPT NINE
+207A..207C ; Common # Sm [3] SUPERSCRIPT PLUS SIGN..SUPERSCRIPT EQUALS SIGN
+207D ; Common # Ps SUPERSCRIPT LEFT PARENTHESIS
+207E ; Common # Pe SUPERSCRIPT RIGHT PARENTHESIS
+2080..2089 ; Common # No [10] SUBSCRIPT ZERO..SUBSCRIPT NINE
+208A..208C ; Common # Sm [3] SUBSCRIPT PLUS SIGN..SUBSCRIPT EQUALS SIGN
+208D ; Common # Ps SUBSCRIPT LEFT PARENTHESIS
+208E ; Common # Pe SUBSCRIPT RIGHT PARENTHESIS
+20A0..20B5 ; Common # Sc [22] EURO-CURRENCY SIGN..CEDI SIGN
+2100..2101 ; Common # So [2] ACCOUNT OF..ADDRESSED TO THE SUBJECT
+2102 ; Common # L& DOUBLE-STRUCK CAPITAL C
+2103..2106 ; Common # So [4] DEGREE CELSIUS..CADA UNA
+2107 ; Common # L& EULER CONSTANT
+2108..2109 ; Common # So [2] SCRUPLE..DEGREE FAHRENHEIT
+210A..2113 ; Common # L& [10] SCRIPT SMALL G..SCRIPT SMALL L
+2114 ; Common # So L B BAR SYMBOL
+2115 ; Common # L& DOUBLE-STRUCK CAPITAL N
+2116..2118 ; Common # So [3] NUMERO SIGN..SCRIPT CAPITAL P
+2119..211D ; Common # L& [5] DOUBLE-STRUCK CAPITAL P..DOUBLE-STRUCK CAPITAL R
+211E..2123 ; Common # So [6] PRESCRIPTION TAKE..VERSICLE
+2124 ; Common # L& DOUBLE-STRUCK CAPITAL Z
+2125 ; Common # So OUNCE SIGN
+2127 ; Common # So INVERTED OHM SIGN
+2128 ; Common # L& BLACK-LETTER CAPITAL Z
+2129 ; Common # So TURNED GREEK SMALL LETTER IOTA
+212C..212D ; Common # L& [2] SCRIPT CAPITAL B..BLACK-LETTER CAPITAL C
+212E ; Common # So ESTIMATED SYMBOL
+212F..2131 ; Common # L& [3] SCRIPT SMALL E..SCRIPT CAPITAL F
+2133..2134 ; Common # L& [2] SCRIPT CAPITAL M..SCRIPT SMALL O
+2135..2138 ; Common # Lo [4] ALEF SYMBOL..DALET SYMBOL
+2139 ; Common # L& INFORMATION SOURCE
+213A..213B ; Common # So [2] ROTATED CAPITAL Q..FACSIMILE SIGN
+213C..213F ; Common # L& [4] DOUBLE-STRUCK SMALL PI..DOUBLE-STRUCK CAPITAL PI
+2140..2144 ; Common # Sm [5] DOUBLE-STRUCK N-ARY SUMMATION..TURNED SANS-SERIF CAPITAL Y
+2145..2149 ; Common # L& [5] DOUBLE-STRUCK ITALIC CAPITAL D..DOUBLE-STRUCK ITALIC SMALL J
+214A ; Common # So PROPERTY LINE
+214B ; Common # Sm TURNED AMPERSAND
+214C..214D ; Common # So [2] PER SIGN..AKTIESELSKAB
+214F ; Common # So SYMBOL FOR SAMARITAN SOURCE
+2153..215F ; Common # No [13] VULGAR FRACTION ONE THIRD..FRACTION NUMERATOR ONE
+2190..2194 ; Common # Sm [5] LEFTWARDS ARROW..LEFT RIGHT ARROW
+2195..2199 ; Common # So [5] UP DOWN ARROW..SOUTH WEST ARROW
+219A..219B ; Common # Sm [2] LEFTWARDS ARROW WITH STROKE..RIGHTWARDS ARROW WITH STROKE
+219C..219F ; Common # So [4] LEFTWARDS WAVE ARROW..UPWARDS TWO HEADED ARROW
+21A0 ; Common # Sm RIGHTWARDS TWO HEADED ARROW
+21A1..21A2 ; Common # So [2] DOWNWARDS TWO HEADED ARROW..LEFTWARDS ARROW WITH TAIL
+21A3 ; Common # Sm RIGHTWARDS ARROW WITH TAIL
+21A4..21A5 ; Common # So [2] LEFTWARDS ARROW FROM BAR..UPWARDS ARROW FROM BAR
+21A6 ; Common # Sm RIGHTWARDS ARROW FROM BAR
+21A7..21AD ; Common # So [7] DOWNWARDS ARROW FROM BAR..LEFT RIGHT WAVE ARROW
+21AE ; Common # Sm LEFT RIGHT ARROW WITH STROKE
+21AF..21CD ; Common # So [31] DOWNWARDS ZIGZAG ARROW..LEFTWARDS DOUBLE ARROW WITH STROKE
+21CE..21CF ; Common # Sm [2] LEFT RIGHT DOUBLE ARROW WITH STROKE..RIGHTWARDS DOUBLE ARROW WITH STROKE
+21D0..21D1 ; Common # So [2] LEFTWARDS DOUBLE ARROW..UPWARDS DOUBLE ARROW
+21D2 ; Common # Sm RIGHTWARDS DOUBLE ARROW
+21D3 ; Common # So DOWNWARDS DOUBLE ARROW
+21D4 ; Common # Sm LEFT RIGHT DOUBLE ARROW
+21D5..21F3 ; Common # So [31] UP DOWN DOUBLE ARROW..UP DOWN WHITE ARROW
+21F4..22FF ; Common # Sm [268] RIGHT ARROW WITH SMALL CIRCLE..Z NOTATION BAG MEMBERSHIP
+2300..2307 ; Common # So [8] DIAMETER SIGN..WAVY LINE
+2308..230B ; Common # Sm [4] LEFT CEILING..RIGHT FLOOR
+230C..231F ; Common # So [20] BOTTOM RIGHT CROP..BOTTOM RIGHT CORNER
+2320..2321 ; Common # Sm [2] TOP HALF INTEGRAL..BOTTOM HALF INTEGRAL
+2322..2328 ; Common # So [7] FROWN..KEYBOARD
+2329 ; Common # Ps LEFT-POINTING ANGLE BRACKET
+232A ; Common # Pe RIGHT-POINTING ANGLE BRACKET
+232B..237B ; Common # So [81] ERASE TO THE LEFT..NOT CHECK MARK
+237C ; Common # Sm RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW
+237D..239A ; Common # So [30] SHOULDERED OPEN BOX..CLEAR SCREEN SYMBOL
+239B..23B3 ; Common # Sm [25] LEFT PARENTHESIS UPPER HOOK..SUMMATION BOTTOM
+23B4..23DB ; Common # So [40] TOP SQUARE BRACKET..FUSE
+23DC..23E1 ; Common # Sm [6] TOP PARENTHESIS..BOTTOM TORTOISE SHELL BRACKET
+23E2..23E7 ; Common # So [6] WHITE TRAPEZIUM..ELECTRICAL INTERSECTION
+2400..2426 ; Common # So [39] SYMBOL FOR NULL..SYMBOL FOR SUBSTITUTE FORM TWO
+2440..244A ; Common # So [11] OCR HOOK..OCR DOUBLE BACKSLASH
+2460..249B ; Common # No [60] CIRCLED DIGIT ONE..NUMBER TWENTY FULL STOP
+249C..24E9 ; Common # So [78] PARENTHESIZED LATIN SMALL LETTER A..CIRCLED LATIN SMALL LETTER Z
+24EA..24FF ; Common # No [22] CIRCLED DIGIT ZERO..NEGATIVE CIRCLED DIGIT ZERO
+2500..25B6 ; Common # So [183] BOX DRAWINGS LIGHT HORIZONTAL..BLACK RIGHT-POINTING TRIANGLE
+25B7 ; Common # Sm WHITE RIGHT-POINTING TRIANGLE
+25B8..25C0 ; Common # So [9] BLACK RIGHT-POINTING SMALL TRIANGLE..BLACK LEFT-POINTING TRIANGLE
+25C1 ; Common # Sm WHITE LEFT-POINTING TRIANGLE
+25C2..25F7 ; Common # So [54] BLACK LEFT-POINTING SMALL TRIANGLE..WHITE CIRCLE WITH UPPER RIGHT QUADRANT
+25F8..25FF ; Common # Sm [8] UPPER LEFT TRIANGLE..LOWER RIGHT TRIANGLE
+2600..266E ; Common # So [111] BLACK SUN WITH RAYS..MUSIC NATURAL SIGN
+266F ; Common # Sm MUSIC SHARP SIGN
+2670..269D ; Common # So [46] WEST SYRIAC CROSS..OUTLINED WHITE STAR
+26A0..26BC ; Common # So [29] WARNING SIGN..SESQUIQUADRATE
+26C0..26C3 ; Common # So [4] WHITE DRAUGHTS MAN..BLACK DRAUGHTS KING
+2701..2704 ; Common # So [4] UPPER BLADE SCISSORS..WHITE SCISSORS
+2706..2709 ; Common # So [4] TELEPHONE LOCATION SIGN..ENVELOPE
+270C..2727 ; Common # So [28] VICTORY HAND..WHITE FOUR POINTED STAR
+2729..274B ; Common # So [35] STRESS OUTLINED WHITE STAR..HEAVY EIGHT TEARDROP-SPOKED PROPELLER ASTERISK
+274D ; Common # So SHADOWED WHITE CIRCLE
+274F..2752 ; Common # So [4] LOWER RIGHT DROP-SHADOWED WHITE SQUARE..UPPER RIGHT SHADOWED WHITE SQUARE
+2756 ; Common # So BLACK DIAMOND MINUS WHITE X
+2758..275E ; Common # So [7] LIGHT VERTICAL BAR..HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT
+2761..2767 ; Common # So [7] CURVED STEM PARAGRAPH SIGN ORNAMENT..ROTATED FLORAL HEART BULLET
+2768 ; Common # Ps MEDIUM LEFT PARENTHESIS ORNAMENT
+2769 ; Common # Pe MEDIUM RIGHT PARENTHESIS ORNAMENT
+276A ; Common # Ps MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT
+276B ; Common # Pe MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT
+276C ; Common # Ps MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT
+276D ; Common # Pe MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT
+276E ; Common # Ps HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT
+276F ; Common # Pe HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT
+2770 ; Common # Ps HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT
+2771 ; Common # Pe HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT
+2772 ; Common # Ps LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT
+2773 ; Common # Pe LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT
+2774 ; Common # Ps MEDIUM LEFT CURLY BRACKET ORNAMENT
+2775 ; Common # Pe MEDIUM RIGHT CURLY BRACKET ORNAMENT
+2776..2793 ; Common # No [30] DINGBAT NEGATIVE CIRCLED DIGIT ONE..DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN
+2794 ; Common # So HEAVY WIDE-HEADED RIGHTWARDS ARROW
+2798..27AF ; Common # So [24] HEAVY SOUTH EAST ARROW..NOTCHED LOWER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW
+27B1..27BE ; Common # So [14] NOTCHED UPPER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW..OPEN-OUTLINED RIGHTWARDS ARROW
+27C0..27C4 ; Common # Sm [5] THREE DIMENSIONAL ANGLE..OPEN SUPERSET
+27C5 ; Common # Ps LEFT S-SHAPED BAG DELIMITER
+27C6 ; Common # Pe RIGHT S-SHAPED BAG DELIMITER
+27C7..27CA ; Common # Sm [4] OR WITH DOT INSIDE..VERTICAL BAR WITH HORIZONTAL STROKE
+27CC ; Common # Sm LONG DIVISION
+27D0..27E5 ; Common # Sm [22] WHITE DIAMOND WITH CENTRED DOT..WHITE SQUARE WITH RIGHTWARDS TICK
+27E6 ; Common # Ps MATHEMATICAL LEFT WHITE SQUARE BRACKET
+27E7 ; Common # Pe MATHEMATICAL RIGHT WHITE SQUARE BRACKET
+27E8 ; Common # Ps MATHEMATICAL LEFT ANGLE BRACKET
+27E9 ; Common # Pe MATHEMATICAL RIGHT ANGLE BRACKET
+27EA ; Common # Ps MATHEMATICAL LEFT DOUBLE ANGLE BRACKET
+27EB ; Common # Pe MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET
+27EC ; Common # Ps MATHEMATICAL LEFT WHITE TORTOISE SHELL BRACKET
+27ED ; Common # Pe MATHEMATICAL RIGHT WHITE TORTOISE SHELL BRACKET
+27EE ; Common # Ps MATHEMATICAL LEFT FLATTENED PARENTHESIS
+27EF ; Common # Pe MATHEMATICAL RIGHT FLATTENED PARENTHESIS
+27F0..27FF ; Common # Sm [16] UPWARDS QUADRUPLE ARROW..LONG RIGHTWARDS SQUIGGLE ARROW
+2900..2982 ; Common # Sm [131] RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE..Z NOTATION TYPE COLON
+2983 ; Common # Ps LEFT WHITE CURLY BRACKET
+2984 ; Common # Pe RIGHT WHITE CURLY BRACKET
+2985 ; Common # Ps LEFT WHITE PARENTHESIS
+2986 ; Common # Pe RIGHT WHITE PARENTHESIS
+2987 ; Common # Ps Z NOTATION LEFT IMAGE BRACKET
+2988 ; Common # Pe Z NOTATION RIGHT IMAGE BRACKET
+2989 ; Common # Ps Z NOTATION LEFT BINDING BRACKET
+298A ; Common # Pe Z NOTATION RIGHT BINDING BRACKET
+298B ; Common # Ps LEFT SQUARE BRACKET WITH UNDERBAR
+298C ; Common # Pe RIGHT SQUARE BRACKET WITH UNDERBAR
+298D ; Common # Ps LEFT SQUARE BRACKET WITH TICK IN TOP CORNER
+298E ; Common # Pe RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER
+298F ; Common # Ps LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER
+2990 ; Common # Pe RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER
+2991 ; Common # Ps LEFT ANGLE BRACKET WITH DOT
+2992 ; Common # Pe RIGHT ANGLE BRACKET WITH DOT
+2993 ; Common # Ps LEFT ARC LESS-THAN BRACKET
+2994 ; Common # Pe RIGHT ARC GREATER-THAN BRACKET
+2995 ; Common # Ps DOUBLE LEFT ARC GREATER-THAN BRACKET
+2996 ; Common # Pe DOUBLE RIGHT ARC LESS-THAN BRACKET
+2997 ; Common # Ps LEFT BLACK TORTOISE SHELL BRACKET
+2998 ; Common # Pe RIGHT BLACK TORTOISE SHELL BRACKET
+2999..29D7 ; Common # Sm [63] DOTTED FENCE..BLACK HOURGLASS
+29D8 ; Common # Ps LEFT WIGGLY FENCE
+29D9 ; Common # Pe RIGHT WIGGLY FENCE
+29DA ; Common # Ps LEFT DOUBLE WIGGLY FENCE
+29DB ; Common # Pe RIGHT DOUBLE WIGGLY FENCE
+29DC..29FB ; Common # Sm [32] INCOMPLETE INFINITY..TRIPLE PLUS
+29FC ; Common # Ps LEFT-POINTING CURVED ANGLE BRACKET
+29FD ; Common # Pe RIGHT-POINTING CURVED ANGLE BRACKET
+29FE..2AFF ; Common # Sm [258] TINY..N-ARY WHITE VERTICAL BAR
+2B00..2B2F ; Common # So [48] NORTH EAST WHITE ARROW..WHITE VERTICAL ELLIPSE
+2B30..2B44 ; Common # Sm [21] LEFT ARROW WITH SMALL CIRCLE..RIGHTWARDS ARROW THROUGH SUPERSET
+2B45..2B46 ; Common # So [2] LEFTWARDS QUADRUPLE ARROW..RIGHTWARDS QUADRUPLE ARROW
+2B47..2B4C ; Common # Sm [6] REVERSE TILDE OPERATOR ABOVE RIGHTWARDS ARROW..RIGHTWARDS ARROW ABOVE REVERSE TILDE OPERATOR
+2B50..2B54 ; Common # So [5] WHITE MEDIUM STAR..WHITE RIGHT-POINTING PENTAGON
+2E00..2E01 ; Common # Po [2] RIGHT ANGLE SUBSTITUTION MARKER..RIGHT ANGLE DOTTED SUBSTITUTION MARKER
+2E02 ; Common # Pi LEFT SUBSTITUTION BRACKET
+2E03 ; Common # Pf RIGHT SUBSTITUTION BRACKET
+2E04 ; Common # Pi LEFT DOTTED SUBSTITUTION BRACKET
+2E05 ; Common # Pf RIGHT DOTTED SUBSTITUTION BRACKET
+2E06..2E08 ; Common # Po [3] RAISED INTERPOLATION MARKER..DOTTED TRANSPOSITION MARKER
+2E09 ; Common # Pi LEFT TRANSPOSITION BRACKET
+2E0A ; Common # Pf RIGHT TRANSPOSITION BRACKET
+2E0B ; Common # Po RAISED SQUARE
+2E0C ; Common # Pi LEFT RAISED OMISSION BRACKET
+2E0D ; Common # Pf RIGHT RAISED OMISSION BRACKET
+2E0E..2E16 ; Common # Po [9] EDITORIAL CORONIS..DOTTED RIGHT-POINTING ANGLE
+2E17 ; Common # Pd DOUBLE OBLIQUE HYPHEN
+2E18..2E19 ; Common # Po [2] INVERTED INTERROBANG..PALM BRANCH
+2E1A ; Common # Pd HYPHEN WITH DIAERESIS
+2E1B ; Common # Po TILDE WITH RING ABOVE
+2E1C ; Common # Pi LEFT LOW PARAPHRASE BRACKET
+2E1D ; Common # Pf RIGHT LOW PARAPHRASE BRACKET
+2E1E..2E1F ; Common # Po [2] TILDE WITH DOT ABOVE..TILDE WITH DOT BELOW
+2E20 ; Common # Pi LEFT VERTICAL BAR WITH QUILL
+2E21 ; Common # Pf RIGHT VERTICAL BAR WITH QUILL
+2E22 ; Common # Ps TOP LEFT HALF BRACKET
+2E23 ; Common # Pe TOP RIGHT HALF BRACKET
+2E24 ; Common # Ps BOTTOM LEFT HALF BRACKET
+2E25 ; Common # Pe BOTTOM RIGHT HALF BRACKET
+2E26 ; Common # Ps LEFT SIDEWAYS U BRACKET
+2E27 ; Common # Pe RIGHT SIDEWAYS U BRACKET
+2E28 ; Common # Ps LEFT DOUBLE PARENTHESIS
+2E29 ; Common # Pe RIGHT DOUBLE PARENTHESIS
+2E2A..2E2E ; Common # Po [5] TWO DOTS OVER ONE DOT PUNCTUATION..REVERSED QUESTION MARK
+2E2F ; Common # Lm VERTICAL TILDE
+2E30 ; Common # Po RING POINT
+2FF0..2FFB ; Common # So [12] IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT..IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID
+3000 ; Common # Zs IDEOGRAPHIC SPACE
+3001..3003 ; Common # Po [3] IDEOGRAPHIC COMMA..DITTO MARK
+3004 ; Common # So JAPANESE INDUSTRIAL STANDARD SYMBOL
+3006 ; Common # Lo IDEOGRAPHIC CLOSING MARK
+3008 ; Common # Ps LEFT ANGLE BRACKET
+3009 ; Common # Pe RIGHT ANGLE BRACKET
+300A ; Common # Ps LEFT DOUBLE ANGLE BRACKET
+300B ; Common # Pe RIGHT DOUBLE ANGLE BRACKET
+300C ; Common # Ps LEFT CORNER BRACKET
+300D ; Common # Pe RIGHT CORNER BRACKET
+300E ; Common # Ps LEFT WHITE CORNER BRACKET
+300F ; Common # Pe RIGHT WHITE CORNER BRACKET
+3010 ; Common # Ps LEFT BLACK LENTICULAR BRACKET
+3011 ; Common # Pe RIGHT BLACK LENTICULAR BRACKET
+3012..3013 ; Common # So [2] POSTAL MARK..GETA MARK
+3014 ; Common # Ps LEFT TORTOISE SHELL BRACKET
+3015 ; Common # Pe RIGHT TORTOISE SHELL BRACKET
+3016 ; Common # Ps LEFT WHITE LENTICULAR BRACKET
+3017 ; Common # Pe RIGHT WHITE LENTICULAR BRACKET
+3018 ; Common # Ps LEFT WHITE TORTOISE SHELL BRACKET
+3019 ; Common # Pe RIGHT WHITE TORTOISE SHELL BRACKET
+301A ; Common # Ps LEFT WHITE SQUARE BRACKET
+301B ; Common # Pe RIGHT WHITE SQUARE BRACKET
+301C ; Common # Pd WAVE DASH
+301D ; Common # Ps REVERSED DOUBLE PRIME QUOTATION MARK
+301E..301F ; Common # Pe [2] DOUBLE PRIME QUOTATION MARK..LOW DOUBLE PRIME QUOTATION MARK
+3020 ; Common # So POSTAL MARK FACE
+3030 ; Common # Pd WAVY DASH
+3031..3035 ; Common # Lm [5] VERTICAL KANA REPEAT MARK..VERTICAL KANA REPEAT MARK LOWER HALF
+3036..3037 ; Common # So [2] CIRCLED POSTAL MARK..IDEOGRAPHIC TELEGRAPH LINE FEED SEPARATOR SYMBOL
+303C ; Common # Lo MASU MARK
+303D ; Common # Po PART ALTERNATION MARK
+303E..303F ; Common # So [2] IDEOGRAPHIC VARIATION INDICATOR..IDEOGRAPHIC HALF FILL SPACE
+309B..309C ; Common # Sk [2] KATAKANA-HIRAGANA VOICED SOUND MARK..KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
+30A0 ; Common # Pd KATAKANA-HIRAGANA DOUBLE HYPHEN
+30FB ; Common # Po KATAKANA MIDDLE DOT
+30FC ; Common # Lm KATAKANA-HIRAGANA PROLONGED SOUND MARK
+3190..3191 ; Common # So [2] IDEOGRAPHIC ANNOTATION LINKING MARK..IDEOGRAPHIC ANNOTATION REVERSE MARK
+3192..3195 ; Common # No [4] IDEOGRAPHIC ANNOTATION ONE MARK..IDEOGRAPHIC ANNOTATION FOUR MARK
+3196..319F ; Common # So [10] IDEOGRAPHIC ANNOTATION TOP MARK..IDEOGRAPHIC ANNOTATION MAN MARK
+31C0..31E3 ; Common # So [36] CJK STROKE T..CJK STROKE Q
+3220..3229 ; Common # No [10] PARENTHESIZED IDEOGRAPH ONE..PARENTHESIZED IDEOGRAPH TEN
+322A..3243 ; Common # So [26] PARENTHESIZED IDEOGRAPH MOON..PARENTHESIZED IDEOGRAPH REACH
+3250 ; Common # So PARTNERSHIP SIGN
+3251..325F ; Common # No [15] CIRCLED NUMBER TWENTY ONE..CIRCLED NUMBER THIRTY FIVE
+327F ; Common # So KOREAN STANDARD SYMBOL
+3280..3289 ; Common # No [10] CIRCLED IDEOGRAPH ONE..CIRCLED IDEOGRAPH TEN
+328A..32B0 ; Common # So [39] CIRCLED IDEOGRAPH MOON..CIRCLED IDEOGRAPH NIGHT
+32B1..32BF ; Common # No [15] CIRCLED NUMBER THIRTY SIX..CIRCLED NUMBER FIFTY
+32C0..32CF ; Common # So [16] IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY..LIMITED LIABILITY SIGN
+3358..33FF ; Common # So [168] IDEOGRAPHIC TELEGRAPH SYMBOL FOR HOUR ZERO..SQUARE GAL
+4DC0..4DFF ; Common # So [64] HEXAGRAM FOR THE CREATIVE HEAVEN..HEXAGRAM FOR BEFORE COMPLETION
+A700..A716 ; Common # Sk [23] MODIFIER LETTER CHINESE TONE YIN PING..MODIFIER LETTER EXTRA-LOW LEFT-STEM TONE BAR
+A717..A71F ; Common # Lm [9] MODIFIER LETTER DOT VERTICAL BAR..MODIFIER LETTER LOW INVERTED EXCLAMATION MARK
+A720..A721 ; Common # Sk [2] MODIFIER LETTER STRESS AND HIGH TONE..MODIFIER LETTER STRESS AND LOW TONE
+A788 ; Common # Lm MODIFIER LETTER LOW CIRCUMFLEX ACCENT
+A789..A78A ; Common # Sk [2] MODIFIER LETTER COLON..MODIFIER LETTER SHORT EQUALS SIGN
+FD3E ; Common # Ps ORNATE LEFT PARENTHESIS
+FD3F ; Common # Pe ORNATE RIGHT PARENTHESIS
+FDFD ; Common # So ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM
+FE10..FE16 ; Common # Po [7] PRESENTATION FORM FOR VERTICAL COMMA..PRESENTATION FORM FOR VERTICAL QUESTION MARK
+FE17 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT WHITE LENTICULAR BRACKET
+FE18 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT WHITE LENTICULAR BRAKCET
+FE19 ; Common # Po PRESENTATION FORM FOR VERTICAL HORIZONTAL ELLIPSIS
+FE30 ; Common # Po PRESENTATION FORM FOR VERTICAL TWO DOT LEADER
+FE31..FE32 ; Common # Pd [2] PRESENTATION FORM FOR VERTICAL EM DASH..PRESENTATION FORM FOR VERTICAL EN DASH
+FE33..FE34 ; Common # Pc [2] PRESENTATION FORM FOR VERTICAL LOW LINE..PRESENTATION FORM FOR VERTICAL WAVY LOW LINE
+FE35 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS
+FE36 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS
+FE37 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET
+FE38 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET
+FE39 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET
+FE3A ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET
+FE3B ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET
+FE3C ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET
+FE3D ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET
+FE3E ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET
+FE3F ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET
+FE40 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET
+FE41 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET
+FE42 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET
+FE43 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET
+FE44 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET
+FE45..FE46 ; Common # Po [2] SESAME DOT..WHITE SESAME DOT
+FE47 ; Common # Ps PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET
+FE48 ; Common # Pe PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET
+FE49..FE4C ; Common # Po [4] DASHED OVERLINE..DOUBLE WAVY OVERLINE
+FE4D..FE4F ; Common # Pc [3] DASHED LOW LINE..WAVY LOW LINE
+FE50..FE52 ; Common # Po [3] SMALL COMMA..SMALL FULL STOP
+FE54..FE57 ; Common # Po [4] SMALL SEMICOLON..SMALL EXCLAMATION MARK
+FE58 ; Common # Pd SMALL EM DASH
+FE59 ; Common # Ps SMALL LEFT PARENTHESIS
+FE5A ; Common # Pe SMALL RIGHT PARENTHESIS
+FE5B ; Common # Ps SMALL LEFT CURLY BRACKET
+FE5C ; Common # Pe SMALL RIGHT CURLY BRACKET
+FE5D ; Common # Ps SMALL LEFT TORTOISE SHELL BRACKET
+FE5E ; Common # Pe SMALL RIGHT TORTOISE SHELL BRACKET
+FE5F..FE61 ; Common # Po [3] SMALL NUMBER SIGN..SMALL ASTERISK
+FE62 ; Common # Sm SMALL PLUS SIGN
+FE63 ; Common # Pd SMALL HYPHEN-MINUS
+FE64..FE66 ; Common # Sm [3] SMALL LESS-THAN SIGN..SMALL EQUALS SIGN
+FE68 ; Common # Po SMALL REVERSE SOLIDUS
+FE69 ; Common # Sc SMALL DOLLAR SIGN
+FE6A..FE6B ; Common # Po [2] SMALL PERCENT SIGN..SMALL COMMERCIAL AT
+FEFF ; Common # Cf ZERO WIDTH NO-BREAK SPACE
+FF01..FF03 ; Common # Po [3] FULLWIDTH EXCLAMATION MARK..FULLWIDTH NUMBER SIGN
+FF04 ; Common # Sc FULLWIDTH DOLLAR SIGN
+FF05..FF07 ; Common # Po [3] FULLWIDTH PERCENT SIGN..FULLWIDTH APOSTROPHE
+FF08 ; Common # Ps FULLWIDTH LEFT PARENTHESIS
+FF09 ; Common # Pe FULLWIDTH RIGHT PARENTHESIS
+FF0A ; Common # Po FULLWIDTH ASTERISK
+FF0B ; Common # Sm FULLWIDTH PLUS SIGN
+FF0C ; Common # Po FULLWIDTH COMMA
+FF0D ; Common # Pd FULLWIDTH HYPHEN-MINUS
+FF0E..FF0F ; Common # Po [2] FULLWIDTH FULL STOP..FULLWIDTH SOLIDUS
+FF10..FF19 ; Common # Nd [10] FULLWIDTH DIGIT ZERO..FULLWIDTH DIGIT NINE
+FF1A..FF1B ; Common # Po [2] FULLWIDTH COLON..FULLWIDTH SEMICOLON
+FF1C..FF1E ; Common # Sm [3] FULLWIDTH LESS-THAN SIGN..FULLWIDTH GREATER-THAN SIGN
+FF1F..FF20 ; Common # Po [2] FULLWIDTH QUESTION MARK..FULLWIDTH COMMERCIAL AT
+FF3B ; Common # Ps FULLWIDTH LEFT SQUARE BRACKET
+FF3C ; Common # Po FULLWIDTH REVERSE SOLIDUS
+FF3D ; Common # Pe FULLWIDTH RIGHT SQUARE BRACKET
+FF3E ; Common # Sk FULLWIDTH CIRCUMFLEX ACCENT
+FF3F ; Common # Pc FULLWIDTH LOW LINE
+FF40 ; Common # Sk FULLWIDTH GRAVE ACCENT
+FF5B ; Common # Ps FULLWIDTH LEFT CURLY BRACKET
+FF5C ; Common # Sm FULLWIDTH VERTICAL LINE
+FF5D ; Common # Pe FULLWIDTH RIGHT CURLY BRACKET
+FF5E ; Common # Sm FULLWIDTH TILDE
+FF5F ; Common # Ps FULLWIDTH LEFT WHITE PARENTHESIS
+FF60 ; Common # Pe FULLWIDTH RIGHT WHITE PARENTHESIS
+FF61 ; Common # Po HALFWIDTH IDEOGRAPHIC FULL STOP
+FF62 ; Common # Ps HALFWIDTH LEFT CORNER BRACKET
+FF63 ; Common # Pe HALFWIDTH RIGHT CORNER BRACKET
+FF64..FF65 ; Common # Po [2] HALFWIDTH IDEOGRAPHIC COMMA..HALFWIDTH KATAKANA MIDDLE DOT
+FF70 ; Common # Lm HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK
+FF9E..FF9F ; Common # Lm [2] HALFWIDTH KATAKANA VOICED SOUND MARK..HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK
+FFE0..FFE1 ; Common # Sc [2] FULLWIDTH CENT SIGN..FULLWIDTH POUND SIGN
+FFE2 ; Common # Sm FULLWIDTH NOT SIGN
+FFE3 ; Common # Sk FULLWIDTH MACRON
+FFE4 ; Common # So FULLWIDTH BROKEN BAR
+FFE5..FFE6 ; Common # Sc [2] FULLWIDTH YEN SIGN..FULLWIDTH WON SIGN
+FFE8 ; Common # So HALFWIDTH FORMS LIGHT VERTICAL
+FFE9..FFEC ; Common # Sm [4] HALFWIDTH LEFTWARDS ARROW..HALFWIDTH DOWNWARDS ARROW
+FFED..FFEE ; Common # So [2] HALFWIDTH BLACK SQUARE..HALFWIDTH WHITE CIRCLE
+FFF9..FFFB ; Common # Cf [3] INTERLINEAR ANNOTATION ANCHOR..INTERLINEAR ANNOTATION TERMINATOR
+FFFC..FFFD ; Common # So [2] OBJECT REPLACEMENT CHARACTER..REPLACEMENT CHARACTER
+10100..10101 ; Common # Po [2] AEGEAN WORD SEPARATOR LINE..AEGEAN WORD SEPARATOR DOT
+10102 ; Common # So AEGEAN CHECK MARK
+10107..10133 ; Common # No [45] AEGEAN NUMBER ONE..AEGEAN NUMBER NINETY THOUSAND
+10137..1013F ; Common # So [9] AEGEAN WEIGHT BASE UNIT..AEGEAN MEASURE THIRD SUBUNIT
+10190..1019B ; Common # So [12] ROMAN SEXTANS SIGN..ROMAN CENTURIAL SIGN
+101D0..101FC ; Common # So [45] PHAISTOS DISC SIGN PEDESTRIAN..PHAISTOS DISC SIGN WAVY BAND
+1D000..1D0F5 ; Common # So [246] BYZANTINE MUSICAL SYMBOL PSILI..BYZANTINE MUSICAL SYMBOL GORGON NEO KATO
+1D100..1D126 ; Common # So [39] MUSICAL SYMBOL SINGLE BARLINE..MUSICAL SYMBOL DRUM CLEF-2
+1D129..1D164 ; Common # So [60] MUSICAL SYMBOL MULTIPLE MEASURE REST..MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE
+1D165..1D166 ; Common # Mc [2] MUSICAL SYMBOL COMBINING STEM..MUSICAL SYMBOL COMBINING SPRECHGESANG STEM
+1D16A..1D16C ; Common # So [3] MUSICAL SYMBOL FINGERED TREMOLO-1..MUSICAL SYMBOL FINGERED TREMOLO-3
+1D16D..1D172 ; Common # Mc [6] MUSICAL SYMBOL COMBINING AUGMENTATION DOT..MUSICAL SYMBOL COMBINING FLAG-5
+1D173..1D17A ; Common # Cf [8] MUSICAL SYMBOL BEGIN BEAM..MUSICAL SYMBOL END PHRASE
+1D183..1D184 ; Common # So [2] MUSICAL SYMBOL ARPEGGIATO UP..MUSICAL SYMBOL ARPEGGIATO DOWN
+1D18C..1D1A9 ; Common # So [30] MUSICAL SYMBOL RINFORZANDO..MUSICAL SYMBOL DEGREE SLASH
+1D1AE..1D1DD ; Common # So [48] MUSICAL SYMBOL PEDAL MARK..MUSICAL SYMBOL PES SUBPUNCTIS
+1D300..1D356 ; Common # So [87] MONOGRAM FOR EARTH..TETRAGRAM FOR FOSTERING
+1D360..1D371 ; Common # No [18] COUNTING ROD UNIT DIGIT ONE..COUNTING ROD TENS DIGIT NINE
+1D400..1D454 ; Common # L& [85] MATHEMATICAL BOLD CAPITAL A..MATHEMATICAL ITALIC SMALL G
+1D456..1D49C ; Common # L& [71] MATHEMATICAL ITALIC SMALL I..MATHEMATICAL SCRIPT CAPITAL A
+1D49E..1D49F ; Common # L& [2] MATHEMATICAL SCRIPT CAPITAL C..MATHEMATICAL SCRIPT CAPITAL D
+1D4A2 ; Common # L& MATHEMATICAL SCRIPT CAPITAL G
+1D4A5..1D4A6 ; Common # L& [2] MATHEMATICAL SCRIPT CAPITAL J..MATHEMATICAL SCRIPT CAPITAL K
+1D4A9..1D4AC ; Common # L& [4] MATHEMATICAL SCRIPT CAPITAL N..MATHEMATICAL SCRIPT CAPITAL Q
+1D4AE..1D4B9 ; Common # L& [12] MATHEMATICAL SCRIPT CAPITAL S..MATHEMATICAL SCRIPT SMALL D
+1D4BB ; Common # L& MATHEMATICAL SCRIPT SMALL F
+1D4BD..1D4C3 ; Common # L& [7] MATHEMATICAL SCRIPT SMALL H..MATHEMATICAL SCRIPT SMALL N
+1D4C5..1D505 ; Common # L& [65] MATHEMATICAL SCRIPT SMALL P..MATHEMATICAL FRAKTUR CAPITAL B
+1D507..1D50A ; Common # L& [4] MATHEMATICAL FRAKTUR CAPITAL D..MATHEMATICAL FRAKTUR CAPITAL G
+1D50D..1D514 ; Common # L& [8] MATHEMATICAL FRAKTUR CAPITAL J..MATHEMATICAL FRAKTUR CAPITAL Q
+1D516..1D51C ; Common # L& [7] MATHEMATICAL FRAKTUR CAPITAL S..MATHEMATICAL FRAKTUR CAPITAL Y
+1D51E..1D539 ; Common # L& [28] MATHEMATICAL FRAKTUR SMALL A..MATHEMATICAL DOUBLE-STRUCK CAPITAL B
+1D53B..1D53E ; Common # L& [4] MATHEMATICAL DOUBLE-STRUCK CAPITAL D..MATHEMATICAL DOUBLE-STRUCK CAPITAL G
+1D540..1D544 ; Common # L& [5] MATHEMATICAL DOUBLE-STRUCK CAPITAL I..MATHEMATICAL DOUBLE-STRUCK CAPITAL M
+1D546 ; Common # L& MATHEMATICAL DOUBLE-STRUCK CAPITAL O
+1D54A..1D550 ; Common # L& [7] MATHEMATICAL DOUBLE-STRUCK CAPITAL S..MATHEMATICAL DOUBLE-STRUCK CAPITAL Y
+1D552..1D6A5 ; Common # L& [340] MATHEMATICAL DOUBLE-STRUCK SMALL A..MATHEMATICAL ITALIC SMALL DOTLESS J
+1D6A8..1D6C0 ; Common # L& [25] MATHEMATICAL BOLD CAPITAL ALPHA..MATHEMATICAL BOLD CAPITAL OMEGA
+1D6C1 ; Common # Sm MATHEMATICAL BOLD NABLA
+1D6C2..1D6DA ; Common # L& [25] MATHEMATICAL BOLD SMALL ALPHA..MATHEMATICAL BOLD SMALL OMEGA
+1D6DB ; Common # Sm MATHEMATICAL BOLD PARTIAL DIFFERENTIAL
+1D6DC..1D6FA ; Common # L& [31] MATHEMATICAL BOLD EPSILON SYMBOL..MATHEMATICAL ITALIC CAPITAL OMEGA
+1D6FB ; Common # Sm MATHEMATICAL ITALIC NABLA
+1D6FC..1D714 ; Common # L& [25] MATHEMATICAL ITALIC SMALL ALPHA..MATHEMATICAL ITALIC SMALL OMEGA
+1D715 ; Common # Sm MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL
+1D716..1D734 ; Common # L& [31] MATHEMATICAL ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD ITALIC CAPITAL OMEGA
+1D735 ; Common # Sm MATHEMATICAL BOLD ITALIC NABLA
+1D736..1D74E ; Common # L& [25] MATHEMATICAL BOLD ITALIC SMALL ALPHA..MATHEMATICAL BOLD ITALIC SMALL OMEGA
+1D74F ; Common # Sm MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL
+1D750..1D76E ; Common # L& [31] MATHEMATICAL BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA
+1D76F ; Common # Sm MATHEMATICAL SANS-SERIF BOLD NABLA
+1D770..1D788 ; Common # L& [25] MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA
+1D789 ; Common # Sm MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL
+1D78A..1D7A8 ; Common # L& [31] MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL..MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA
+1D7A9 ; Common # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA
+1D7AA..1D7C2 ; Common # L& [25] MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA..MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA
+1D7C3 ; Common # Sm MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL
+1D7C4..1D7CB ; Common # L& [8] MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL..MATHEMATICAL BOLD SMALL DIGAMMA
+1D7CE..1D7FF ; Common # Nd [50] MATHEMATICAL BOLD DIGIT ZERO..MATHEMATICAL MONOSPACE DIGIT NINE
+1F000..1F02B ; Common # So [44] MAHJONG TILE EAST WIND..MAHJONG TILE BACK
+1F030..1F093 ; Common # So [100] DOMINO TILE HORIZONTAL BACK..DOMINO TILE VERTICAL-06-06
+E0001 ; Common # Cf LANGUAGE TAG
+E0020..E007F ; Common # Cf [96] TAG SPACE..CANCEL TAG
+
+# Total code points: 5178
+
+# ================================================
+
+0041..005A ; Latin # L& [26] LATIN CAPITAL LETTER A..LATIN CAPITAL LETTER Z
+0061..007A ; Latin # L& [26] LATIN SMALL LETTER A..LATIN SMALL LETTER Z
+00AA ; Latin # L& FEMININE ORDINAL INDICATOR
+00BA ; Latin # L& MASCULINE ORDINAL INDICATOR
+00C0..00D6 ; Latin # L& [23] LATIN CAPITAL LETTER A WITH GRAVE..LATIN CAPITAL LETTER O WITH DIAERESIS
+00D8..00F6 ; Latin # L& [31] LATIN CAPITAL LETTER O WITH STROKE..LATIN SMALL LETTER O WITH DIAERESIS
+00F8..01BA ; Latin # L& [195] LATIN SMALL LETTER O WITH STROKE..LATIN SMALL LETTER EZH WITH TAIL
+01BB ; Latin # Lo LATIN LETTER TWO WITH STROKE
+01BC..01BF ; Latin # L& [4] LATIN CAPITAL LETTER TONE FIVE..LATIN LETTER WYNN
+01C0..01C3 ; Latin # Lo [4] LATIN LETTER DENTAL CLICK..LATIN LETTER RETROFLEX CLICK
+01C4..0293 ; Latin # L& [208] LATIN CAPITAL LETTER DZ WITH CARON..LATIN SMALL LETTER EZH WITH CURL
+0294 ; Latin # Lo LATIN LETTER GLOTTAL STOP
+0295..02AF ; Latin # L& [27] LATIN LETTER PHARYNGEAL VOICED FRICATIVE..LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL
+02B0..02B8 ; Latin # Lm [9] MODIFIER LETTER SMALL H..MODIFIER LETTER SMALL Y
+02E0..02E4 ; Latin # Lm [5] MODIFIER LETTER SMALL GAMMA..MODIFIER LETTER SMALL REVERSED GLOTTAL STOP
+1D00..1D25 ; Latin # L& [38] LATIN LETTER SMALL CAPITAL A..LATIN LETTER AIN
+1D2C..1D5C ; Latin # Lm [49] MODIFIER LETTER CAPITAL A..MODIFIER LETTER SMALL AIN
+1D62..1D65 ; Latin # L& [4] LATIN SUBSCRIPT SMALL LETTER I..LATIN SUBSCRIPT SMALL LETTER V
+1D6B..1D77 ; Latin # L& [13] LATIN SMALL LETTER UE..LATIN SMALL LETTER TURNED G
+1D79..1D9A ; Latin # L& [34] LATIN SMALL LETTER INSULAR G..LATIN SMALL LETTER EZH WITH RETROFLEX HOOK
+1D9B..1DBE ; Latin # Lm [36] MODIFIER LETTER SMALL TURNED ALPHA..MODIFIER LETTER SMALL EZH
+1E00..1EFF ; Latin # L& [256] LATIN CAPITAL LETTER A WITH RING BELOW..LATIN SMALL LETTER Y WITH LOOP
+2071 ; Latin # L& SUPERSCRIPT LATIN SMALL LETTER I
+207F ; Latin # L& SUPERSCRIPT LATIN SMALL LETTER N
+2090..2094 ; Latin # Lm [5] LATIN SUBSCRIPT SMALL LETTER A..LATIN SUBSCRIPT SMALL LETTER SCHWA
+212A..212B ; Latin # L& [2] KELVIN SIGN..ANGSTROM SIGN
+2132 ; Latin # L& TURNED CAPITAL F
+214E ; Latin # L& TURNED SMALL F
+2160..2182 ; Latin # Nl [35] ROMAN NUMERAL ONE..ROMAN NUMERAL TEN THOUSAND
+2183..2184 ; Latin # L& [2] ROMAN NUMERAL REVERSED ONE HUNDRED..LATIN SMALL LETTER REVERSED C
+2185..2188 ; Latin # Nl [4] ROMAN NUMERAL SIX LATE FORM..ROMAN NUMERAL ONE HUNDRED THOUSAND
+2C60..2C6F ; Latin # L& [16] LATIN CAPITAL LETTER L WITH DOUBLE BAR..LATIN CAPITAL LETTER TURNED A
+2C71..2C7C ; Latin # L& [12] LATIN SMALL LETTER V WITH RIGHT HOOK..LATIN SUBSCRIPT SMALL LETTER J
+2C7D ; Latin # Lm MODIFIER LETTER CAPITAL V
+A722..A76F ; Latin # L& [78] LATIN CAPITAL LETTER EGYPTOLOGICAL ALEF..LATIN SMALL LETTER CON
+A770 ; Latin # Lm MODIFIER LETTER US
+A771..A787 ; Latin # L& [23] LATIN SMALL LETTER DUM..LATIN SMALL LETTER INSULAR T
+A78B..A78C ; Latin # L& [2] LATIN CAPITAL LETTER SALTILLO..LATIN SMALL LETTER SALTILLO
+A7FB..A7FF ; Latin # Lo [5] LATIN EPIGRAPHIC LETTER REVERSED F..LATIN EPIGRAPHIC LETTER ARCHAIC M
+FB00..FB06 ; Latin # L& [7] LATIN SMALL LIGATURE FF..LATIN SMALL LIGATURE ST
+FF21..FF3A ; Latin # L& [26] FULLWIDTH LATIN CAPITAL LETTER A..FULLWIDTH LATIN CAPITAL LETTER Z
+FF41..FF5A ; Latin # L& [26] FULLWIDTH LATIN SMALL LETTER A..FULLWIDTH LATIN SMALL LETTER Z
+
+# Total code points: 1241
+
+# ================================================
+
+0370..0373 ; Greek # L& [4] GREEK CAPITAL LETTER HETA..GREEK SMALL LETTER ARCHAIC SAMPI
+0375 ; Greek # Sk GREEK LOWER NUMERAL SIGN
+0376..0377 ; Greek # L& [2] GREEK CAPITAL LETTER PAMPHYLIAN DIGAMMA..GREEK SMALL LETTER PAMPHYLIAN DIGAMMA
+037A ; Greek # Lm GREEK YPOGEGRAMMENI
+037B..037D ; Greek # L& [3] GREEK SMALL REVERSED LUNATE SIGMA SYMBOL..GREEK SMALL REVERSED DOTTED LUNATE SIGMA SYMBOL
+0384 ; Greek # Sk GREEK TONOS
+0386 ; Greek # L& GREEK CAPITAL LETTER ALPHA WITH TONOS
+0388..038A ; Greek # L& [3] GREEK CAPITAL LETTER EPSILON WITH TONOS..GREEK CAPITAL LETTER IOTA WITH TONOS
+038C ; Greek # L& GREEK CAPITAL LETTER OMICRON WITH TONOS
+038E..03A1 ; Greek # L& [20] GREEK CAPITAL LETTER UPSILON WITH TONOS..GREEK CAPITAL LETTER RHO
+03A3..03E1 ; Greek # L& [63] GREEK CAPITAL LETTER SIGMA..GREEK SMALL LETTER SAMPI
+03F0..03F5 ; Greek # L& [6] GREEK KAPPA SYMBOL..GREEK LUNATE EPSILON SYMBOL
+03F6 ; Greek # Sm GREEK REVERSED LUNATE EPSILON SYMBOL
+03F7..03FF ; Greek # L& [9] GREEK CAPITAL LETTER SHO..GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL
+1D26..1D2A ; Greek # L& [5] GREEK LETTER SMALL CAPITAL GAMMA..GREEK LETTER SMALL CAPITAL PSI
+1D5D..1D61 ; Greek # Lm [5] MODIFIER LETTER SMALL BETA..MODIFIER LETTER SMALL CHI
+1D66..1D6A ; Greek # L& [5] GREEK SUBSCRIPT SMALL LETTER BETA..GREEK SUBSCRIPT SMALL LETTER CHI
+1DBF ; Greek # Lm MODIFIER LETTER SMALL THETA
+1F00..1F15 ; Greek # L& [22] GREEK SMALL LETTER ALPHA WITH PSILI..GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA
+1F18..1F1D ; Greek # L& [6] GREEK CAPITAL LETTER EPSILON WITH PSILI..GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA
+1F20..1F45 ; Greek # L& [38] GREEK SMALL LETTER ETA WITH PSILI..GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA
+1F48..1F4D ; Greek # L& [6] GREEK CAPITAL LETTER OMICRON WITH PSILI..GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA
+1F50..1F57 ; Greek # L& [8] GREEK SMALL LETTER UPSILON WITH PSILI..GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI
+1F59 ; Greek # L& GREEK CAPITAL LETTER UPSILON WITH DASIA
+1F5B ; Greek # L& GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA
+1F5D ; Greek # L& GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA
+1F5F..1F7D ; Greek # L& [31] GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI..GREEK SMALL LETTER OMEGA WITH OXIA
+1F80..1FB4 ; Greek # L& [53] GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI..GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI
+1FB6..1FBC ; Greek # L& [7] GREEK SMALL LETTER ALPHA WITH PERISPOMENI..GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
+1FBD ; Greek # Sk GREEK KORONIS
+1FBE ; Greek # L& GREEK PROSGEGRAMMENI
+1FBF..1FC1 ; Greek # Sk [3] GREEK PSILI..GREEK DIALYTIKA AND PERISPOMENI
+1FC2..1FC4 ; Greek # L& [3] GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI..GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI
+1FC6..1FCC ; Greek # L& [7] GREEK SMALL LETTER ETA WITH PERISPOMENI..GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
+1FCD..1FCF ; Greek # Sk [3] GREEK PSILI AND VARIA..GREEK PSILI AND PERISPOMENI
+1FD0..1FD3 ; Greek # L& [4] GREEK SMALL LETTER IOTA WITH VRACHY..GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA
+1FD6..1FDB ; Greek # L& [6] GREEK SMALL LETTER IOTA WITH PERISPOMENI..GREEK CAPITAL LETTER IOTA WITH OXIA
+1FDD..1FDF ; Greek # Sk [3] GREEK DASIA AND VARIA..GREEK DASIA AND PERISPOMENI
+1FE0..1FEC ; Greek # L& [13] GREEK SMALL LETTER UPSILON WITH VRACHY..GREEK CAPITAL LETTER RHO WITH DASIA
+1FED..1FEF ; Greek # Sk [3] GREEK DIALYTIKA AND VARIA..GREEK VARIA
+1FF2..1FF4 ; Greek # L& [3] GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI..GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI
+1FF6..1FFC ; Greek # L& [7] GREEK SMALL LETTER OMEGA WITH PERISPOMENI..GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
+1FFD..1FFE ; Greek # Sk [2] GREEK OXIA..GREEK DASIA
+2126 ; Greek # L& OHM SIGN
+10140..10174 ; Greek # Nl [53] GREEK ACROPHONIC ATTIC ONE QUARTER..GREEK ACROPHONIC STRATIAN FIFTY MNAS
+10175..10178 ; Greek # No [4] GREEK ONE HALF SIGN..GREEK THREE QUARTERS SIGN
+10179..10189 ; Greek # So [17] GREEK YEAR SIGN..GREEK TRYBLION BASE SIGN
+1018A ; Greek # No GREEK ZERO SIGN
+1D200..1D241 ; Greek # So [66] GREEK VOCAL NOTATION SYMBOL-1..GREEK INSTRUMENTAL NOTATION SYMBOL-54
+1D242..1D244 ; Greek # Mn [3] COMBINING GREEK MUSICAL TRISEME..COMBINING GREEK MUSICAL PENTASEME
+1D245 ; Greek # So GREEK MUSICAL LEIMMA
+
+# Total code points: 511
+
+# ================================================
+
+0400..0481 ; Cyrillic # L& [130] CYRILLIC CAPITAL LETTER IE WITH GRAVE..CYRILLIC SMALL LETTER KOPPA
+0482 ; Cyrillic # So CYRILLIC THOUSANDS SIGN
+0483..0487 ; Cyrillic # Mn [5] COMBINING CYRILLIC TITLO..COMBINING CYRILLIC POKRYTIE
+0488..0489 ; Cyrillic # Me [2] COMBINING CYRILLIC HUNDRED THOUSANDS SIGN..COMBINING CYRILLIC MILLIONS SIGN
+048A..0523 ; Cyrillic # L& [154] CYRILLIC CAPITAL LETTER SHORT I WITH TAIL..CYRILLIC SMALL LETTER EN WITH MIDDLE HOOK
+1D2B ; Cyrillic # L& CYRILLIC LETTER SMALL CAPITAL EL
+1D78 ; Cyrillic # Lm MODIFIER LETTER CYRILLIC EN
+2DE0..2DFF ; Cyrillic # Mn [32] COMBINING CYRILLIC LETTER BE..COMBINING CYRILLIC LETTER IOTIFIED BIG YUS
+A640..A65F ; Cyrillic # L& [32] CYRILLIC CAPITAL LETTER ZEMLYA..CYRILLIC SMALL LETTER YN
+A662..A66D ; Cyrillic # L& [12] CYRILLIC CAPITAL LETTER SOFT DE..CYRILLIC SMALL LETTER DOUBLE MONOCULAR O
+A66E ; Cyrillic # Lo CYRILLIC LETTER MULTIOCULAR O
+A66F ; Cyrillic # Mn COMBINING CYRILLIC VZMET
+A670..A672 ; Cyrillic # Me [3] COMBINING CYRILLIC TEN MILLIONS SIGN..COMBINING CYRILLIC THOUSAND MILLIONS SIGN
+A673 ; Cyrillic # Po SLAVONIC ASTERISK
+A67C..A67D ; Cyrillic # Mn [2] COMBINING CYRILLIC KAVYKA..COMBINING CYRILLIC PAYEROK
+A67E ; Cyrillic # Po CYRILLIC KAVYKA
+A67F ; Cyrillic # Lm CYRILLIC PAYEROK
+A680..A697 ; Cyrillic # L& [24] CYRILLIC CAPITAL LETTER DWE..CYRILLIC SMALL LETTER SHWE
+
+# Total code points: 404
+
+# ================================================
+
+0531..0556 ; Armenian # L& [38] ARMENIAN CAPITAL LETTER AYB..ARMENIAN CAPITAL LETTER FEH
+0559 ; Armenian # Lm ARMENIAN MODIFIER LETTER LEFT HALF RING
+055A..055F ; Armenian # Po [6] ARMENIAN APOSTROPHE..ARMENIAN ABBREVIATION MARK
+0561..0587 ; Armenian # L& [39] ARMENIAN SMALL LETTER AYB..ARMENIAN SMALL LIGATURE ECH YIWN
+058A ; Armenian # Pd ARMENIAN HYPHEN
+FB13..FB17 ; Armenian # L& [5] ARMENIAN SMALL LIGATURE MEN NOW..ARMENIAN SMALL LIGATURE MEN XEH
+
+# Total code points: 90
+
+# ================================================
+
+0591..05BD ; Hebrew # Mn [45] HEBREW ACCENT ETNAHTA..HEBREW POINT METEG
+05BE ; Hebrew # Pd HEBREW PUNCTUATION MAQAF
+05BF ; Hebrew # Mn HEBREW POINT RAFE
+05C0 ; Hebrew # Po HEBREW PUNCTUATION PASEQ
+05C1..05C2 ; Hebrew # Mn [2] HEBREW POINT SHIN DOT..HEBREW POINT SIN DOT
+05C3 ; Hebrew # Po HEBREW PUNCTUATION SOF PASUQ
+05C4..05C5 ; Hebrew # Mn [2] HEBREW MARK UPPER DOT..HEBREW MARK LOWER DOT
+05C6 ; Hebrew # Po HEBREW PUNCTUATION NUN HAFUKHA
+05C7 ; Hebrew # Mn HEBREW POINT QAMATS QATAN
+05D0..05EA ; Hebrew # Lo [27] HEBREW LETTER ALEF..HEBREW LETTER TAV
+05F0..05F2 ; Hebrew # Lo [3] HEBREW LIGATURE YIDDISH DOUBLE VAV..HEBREW LIGATURE YIDDISH DOUBLE YOD
+05F3..05F4 ; Hebrew # Po [2] HEBREW PUNCTUATION GERESH..HEBREW PUNCTUATION GERSHAYIM
+FB1D ; Hebrew # Lo HEBREW LETTER YOD WITH HIRIQ
+FB1E ; Hebrew # Mn HEBREW POINT JUDEO-SPANISH VARIKA
+FB1F..FB28 ; Hebrew # Lo [10] HEBREW LIGATURE YIDDISH YOD YOD PATAH..HEBREW LETTER WIDE TAV
+FB29 ; Hebrew # Sm HEBREW LETTER ALTERNATIVE PLUS SIGN
+FB2A..FB36 ; Hebrew # Lo [13] HEBREW LETTER SHIN WITH SHIN DOT..HEBREW LETTER ZAYIN WITH DAGESH
+FB38..FB3C ; Hebrew # Lo [5] HEBREW LETTER TET WITH DAGESH..HEBREW LETTER LAMED WITH DAGESH
+FB3E ; Hebrew # Lo HEBREW LETTER MEM WITH DAGESH
+FB40..FB41 ; Hebrew # Lo [2] HEBREW LETTER NUN WITH DAGESH..HEBREW LETTER SAMEKH WITH DAGESH
+FB43..FB44 ; Hebrew # Lo [2] HEBREW LETTER FINAL PE WITH DAGESH..HEBREW LETTER PE WITH DAGESH
+FB46..FB4F ; Hebrew # Lo [10] HEBREW LETTER TSADI WITH DAGESH..HEBREW LIGATURE ALEF LAMED
+
+# Total code points: 133
+
+# ================================================
+
+0606..0608 ; Arabic # Sm [3] ARABIC-INDIC CUBE ROOT..ARABIC RAY
+0609..060A ; Arabic # Po [2] ARABIC-INDIC PER MILLE SIGN..ARABIC-INDIC PER TEN THOUSAND SIGN
+060B ; Arabic # Sc AFGHANI SIGN
+060D ; Arabic # Po ARABIC DATE SEPARATOR
+060E..060F ; Arabic # So [2] ARABIC POETIC VERSE SIGN..ARABIC SIGN MISRA
+0610..061A ; Arabic # Mn [11] ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM..ARABIC SMALL KASRA
+061E ; Arabic # Po ARABIC TRIPLE DOT PUNCTUATION MARK
+0621..063F ; Arabic # Lo [31] ARABIC LETTER HAMZA..ARABIC LETTER FARSI YEH WITH THREE DOTS ABOVE
+0641..064A ; Arabic # Lo [10] ARABIC LETTER FEH..ARABIC LETTER YEH
+0656..065E ; Arabic # Mn [9] ARABIC SUBSCRIPT ALEF..ARABIC FATHA WITH TWO DOTS
+066A..066D ; Arabic # Po [4] ARABIC PERCENT SIGN..ARABIC FIVE POINTED STAR
+066E..066F ; Arabic # Lo [2] ARABIC LETTER DOTLESS BEH..ARABIC LETTER DOTLESS QAF
+0671..06D3 ; Arabic # Lo [99] ARABIC LETTER ALEF WASLA..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE
+06D4 ; Arabic # Po ARABIC FULL STOP
+06D5 ; Arabic # Lo ARABIC LETTER AE
+06D6..06DC ; Arabic # Mn [7] ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA..ARABIC SMALL HIGH SEEN
+06DE ; Arabic # Me ARABIC START OF RUB EL HIZB
+06DF..06E4 ; Arabic # Mn [6] ARABIC SMALL HIGH ROUNDED ZERO..ARABIC SMALL HIGH MADDA
+06E5..06E6 ; Arabic # Lm [2] ARABIC SMALL WAW..ARABIC SMALL YEH
+06E7..06E8 ; Arabic # Mn [2] ARABIC SMALL HIGH YEH..ARABIC SMALL HIGH NOON
+06E9 ; Arabic # So ARABIC PLACE OF SAJDAH
+06EA..06ED ; Arabic # Mn [4] ARABIC EMPTY CENTRE LOW STOP..ARABIC SMALL LOW MEEM
+06EE..06EF ; Arabic # Lo [2] ARABIC LETTER DAL WITH INVERTED V..ARABIC LETTER REH WITH INVERTED V
+06F0..06F9 ; Arabic # Nd [10] EXTENDED ARABIC-INDIC DIGIT ZERO..EXTENDED ARABIC-INDIC DIGIT NINE
+06FA..06FC ; Arabic # Lo [3] ARABIC LETTER SHEEN WITH DOT BELOW..ARABIC LETTER GHAIN WITH DOT BELOW
+06FD..06FE ; Arabic # So [2] ARABIC SIGN SINDHI AMPERSAND..ARABIC SIGN SINDHI POSTPOSITION MEN
+06FF ; Arabic # Lo ARABIC LETTER HEH WITH INVERTED V
+0750..077F ; Arabic # Lo [48] ARABIC LETTER BEH WITH THREE DOTS HORIZONTALLY BELOW..ARABIC LETTER KAF WITH TWO DOTS ABOVE
+FB50..FBB1 ; Arabic # Lo [98] ARABIC LETTER ALEF WASLA ISOLATED FORM..ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM
+FBD3..FD3D ; Arabic # Lo [363] ARABIC LETTER NG ISOLATED FORM..ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM
+FD50..FD8F ; Arabic # Lo [64] ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM..ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM
+FD92..FDC7 ; Arabic # Lo [54] ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM..ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM
+FDF0..FDFB ; Arabic # Lo [12] ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM..ARABIC LIGATURE JALLAJALALOUHOU
+FDFC ; Arabic # Sc RIAL SIGN
+FE70..FE74 ; Arabic # Lo [5] ARABIC FATHATAN ISOLATED FORM..ARABIC KASRATAN ISOLATED FORM
+FE76..FEFC ; Arabic # Lo [135] ARABIC FATHA ISOLATED FORM..ARABIC LIGATURE LAM WITH ALEF FINAL FORM
+
+# Total code points: 999
+
+# ================================================
+
+0700..070D ; Syriac # Po [14] SYRIAC END OF PARAGRAPH..SYRIAC HARKLEAN ASTERISCUS
+070F ; Syriac # Cf SYRIAC ABBREVIATION MARK
+0710 ; Syriac # Lo SYRIAC LETTER ALAPH
+0711 ; Syriac # Mn SYRIAC LETTER SUPERSCRIPT ALAPH
+0712..072F ; Syriac # Lo [30] SYRIAC LETTER BETH..SYRIAC LETTER PERSIAN DHALATH
+0730..074A ; Syriac # Mn [27] SYRIAC PTHAHA ABOVE..SYRIAC BARREKH
+074D..074F ; Syriac # Lo [3] SYRIAC LETTER SOGDIAN ZHAIN..SYRIAC LETTER SOGDIAN FE
+
+# Total code points: 77
+
+# ================================================
+
+0780..07A5 ; Thaana # Lo [38] THAANA LETTER HAA..THAANA LETTER WAAVU
+07A6..07B0 ; Thaana # Mn [11] THAANA ABAFILI..THAANA SUKUN
+07B1 ; Thaana # Lo THAANA LETTER NAA
+
+# Total code points: 50
+
+# ================================================
+
+0901..0902 ; Devanagari # Mn [2] DEVANAGARI SIGN CANDRABINDU..DEVANAGARI SIGN ANUSVARA
+0903 ; Devanagari # Mc DEVANAGARI SIGN VISARGA
+0904..0939 ; Devanagari # Lo [54] DEVANAGARI LETTER SHORT A..DEVANAGARI LETTER HA
+093C ; Devanagari # Mn DEVANAGARI SIGN NUKTA
+093D ; Devanagari # Lo DEVANAGARI SIGN AVAGRAHA
+093E..0940 ; Devanagari # Mc [3] DEVANAGARI VOWEL SIGN AA..DEVANAGARI VOWEL SIGN II
+0941..0948 ; Devanagari # Mn [8] DEVANAGARI VOWEL SIGN U..DEVANAGARI VOWEL SIGN AI
+0949..094C ; Devanagari # Mc [4] DEVANAGARI VOWEL SIGN CANDRA O..DEVANAGARI VOWEL SIGN AU
+094D ; Devanagari # Mn DEVANAGARI SIGN VIRAMA
+0950 ; Devanagari # Lo DEVANAGARI OM
+0953..0954 ; Devanagari # Mn [2] DEVANAGARI GRAVE ACCENT..DEVANAGARI ACUTE ACCENT
+0958..0961 ; Devanagari # Lo [10] DEVANAGARI LETTER QA..DEVANAGARI LETTER VOCALIC LL
+0962..0963 ; Devanagari # Mn [2] DEVANAGARI VOWEL SIGN VOCALIC L..DEVANAGARI VOWEL SIGN VOCALIC LL
+0966..096F ; Devanagari # Nd [10] DEVANAGARI DIGIT ZERO..DEVANAGARI DIGIT NINE
+0971 ; Devanagari # Lm DEVANAGARI SIGN HIGH SPACING DOT
+0972 ; Devanagari # Lo DEVANAGARI LETTER CANDRA A
+097B..097F ; Devanagari # Lo [5] DEVANAGARI LETTER GGA..DEVANAGARI LETTER BBA
+
+# Total code points: 107
+
+# ================================================
+
+0981 ; Bengali # Mn BENGALI SIGN CANDRABINDU
+0982..0983 ; Bengali # Mc [2] BENGALI SIGN ANUSVARA..BENGALI SIGN VISARGA
+0985..098C ; Bengali # Lo [8] BENGALI LETTER A..BENGALI LETTER VOCALIC L
+098F..0990 ; Bengali # Lo [2] BENGALI LETTER E..BENGALI LETTER AI
+0993..09A8 ; Bengali # Lo [22] BENGALI LETTER O..BENGALI LETTER NA
+09AA..09B0 ; Bengali # Lo [7] BENGALI LETTER PA..BENGALI LETTER RA
+09B2 ; Bengali # Lo BENGALI LETTER LA
+09B6..09B9 ; Bengali # Lo [4] BENGALI LETTER SHA..BENGALI LETTER HA
+09BC ; Bengali # Mn BENGALI SIGN NUKTA
+09BD ; Bengali # Lo BENGALI SIGN AVAGRAHA
+09BE..09C0 ; Bengali # Mc [3] BENGALI VOWEL SIGN AA..BENGALI VOWEL SIGN II
+09C1..09C4 ; Bengali # Mn [4] BENGALI VOWEL SIGN U..BENGALI VOWEL SIGN VOCALIC RR
+09C7..09C8 ; Bengali # Mc [2] BENGALI VOWEL SIGN E..BENGALI VOWEL SIGN AI
+09CB..09CC ; Bengali # Mc [2] BENGALI VOWEL SIGN O..BENGALI VOWEL SIGN AU
+09CD ; Bengali # Mn BENGALI SIGN VIRAMA
+09CE ; Bengali # Lo BENGALI LETTER KHANDA TA
+09D7 ; Bengali # Mc BENGALI AU LENGTH MARK
+09DC..09DD ; Bengali # Lo [2] BENGALI LETTER RRA..BENGALI LETTER RHA
+09DF..09E1 ; Bengali # Lo [3] BENGALI LETTER YYA..BENGALI LETTER VOCALIC LL
+09E2..09E3 ; Bengali # Mn [2] BENGALI VOWEL SIGN VOCALIC L..BENGALI VOWEL SIGN VOCALIC LL
+09E6..09EF ; Bengali # Nd [10] BENGALI DIGIT ZERO..BENGALI DIGIT NINE
+09F0..09F1 ; Bengali # Lo [2] BENGALI LETTER RA WITH MIDDLE DIAGONAL..BENGALI LETTER RA WITH LOWER DIAGONAL
+09F2..09F3 ; Bengali # Sc [2] BENGALI RUPEE MARK..BENGALI RUPEE SIGN
+09F4..09F9 ; Bengali # No [6] BENGALI CURRENCY NUMERATOR ONE..BENGALI CURRENCY DENOMINATOR SIXTEEN
+09FA ; Bengali # So BENGALI ISSHAR
+
+# Total code points: 91
+
+# ================================================
+
+0A01..0A02 ; Gurmukhi # Mn [2] GURMUKHI SIGN ADAK BINDI..GURMUKHI SIGN BINDI
+0A03 ; Gurmukhi # Mc GURMUKHI SIGN VISARGA
+0A05..0A0A ; Gurmukhi # Lo [6] GURMUKHI LETTER A..GURMUKHI LETTER UU
+0A0F..0A10 ; Gurmukhi # Lo [2] GURMUKHI LETTER EE..GURMUKHI LETTER AI
+0A13..0A28 ; Gurmukhi # Lo [22] GURMUKHI LETTER OO..GURMUKHI LETTER NA
+0A2A..0A30 ; Gurmukhi # Lo [7] GURMUKHI LETTER PA..GURMUKHI LETTER RA
+0A32..0A33 ; Gurmukhi # Lo [2] GURMUKHI LETTER LA..GURMUKHI LETTER LLA
+0A35..0A36 ; Gurmukhi # Lo [2] GURMUKHI LETTER VA..GURMUKHI LETTER SHA
+0A38..0A39 ; Gurmukhi # Lo [2] GURMUKHI LETTER SA..GURMUKHI LETTER HA
+0A3C ; Gurmukhi # Mn GURMUKHI SIGN NUKTA
+0A3E..0A40 ; Gurmukhi # Mc [3] GURMUKHI VOWEL SIGN AA..GURMUKHI VOWEL SIGN II
+0A41..0A42 ; Gurmukhi # Mn [2] GURMUKHI VOWEL SIGN U..GURMUKHI VOWEL SIGN UU
+0A47..0A48 ; Gurmukhi # Mn [2] GURMUKHI VOWEL SIGN EE..GURMUKHI VOWEL SIGN AI
+0A4B..0A4D ; Gurmukhi # Mn [3] GURMUKHI VOWEL SIGN OO..GURMUKHI SIGN VIRAMA
+0A51 ; Gurmukhi # Mn GURMUKHI SIGN UDAAT
+0A59..0A5C ; Gurmukhi # Lo [4] GURMUKHI LETTER KHHA..GURMUKHI LETTER RRA
+0A5E ; Gurmukhi # Lo GURMUKHI LETTER FA
+0A66..0A6F ; Gurmukhi # Nd [10] GURMUKHI DIGIT ZERO..GURMUKHI DIGIT NINE
+0A70..0A71 ; Gurmukhi # Mn [2] GURMUKHI TIPPI..GURMUKHI ADDAK
+0A72..0A74 ; Gurmukhi # Lo [3] GURMUKHI IRI..GURMUKHI EK ONKAR
+0A75 ; Gurmukhi # Mn GURMUKHI SIGN YAKASH
+
+# Total code points: 79
+
+# ================================================
+
+0A81..0A82 ; Gujarati # Mn [2] GUJARATI SIGN CANDRABINDU..GUJARATI SIGN ANUSVARA
+0A83 ; Gujarati # Mc GUJARATI SIGN VISARGA
+0A85..0A8D ; Gujarati # Lo [9] GUJARATI LETTER A..GUJARATI VOWEL CANDRA E
+0A8F..0A91 ; Gujarati # Lo [3] GUJARATI LETTER E..GUJARATI VOWEL CANDRA O
+0A93..0AA8 ; Gujarati # Lo [22] GUJARATI LETTER O..GUJARATI LETTER NA
+0AAA..0AB0 ; Gujarati # Lo [7] GUJARATI LETTER PA..GUJARATI LETTER RA
+0AB2..0AB3 ; Gujarati # Lo [2] GUJARATI LETTER LA..GUJARATI LETTER LLA
+0AB5..0AB9 ; Gujarati # Lo [5] GUJARATI LETTER VA..GUJARATI LETTER HA
+0ABC ; Gujarati # Mn GUJARATI SIGN NUKTA
+0ABD ; Gujarati # Lo GUJARATI SIGN AVAGRAHA
+0ABE..0AC0 ; Gujarati # Mc [3] GUJARATI VOWEL SIGN AA..GUJARATI VOWEL SIGN II
+0AC1..0AC5 ; Gujarati # Mn [5] GUJARATI VOWEL SIGN U..GUJARATI VOWEL SIGN CANDRA E
+0AC7..0AC8 ; Gujarati # Mn [2] GUJARATI VOWEL SIGN E..GUJARATI VOWEL SIGN AI
+0AC9 ; Gujarati # Mc GUJARATI VOWEL SIGN CANDRA O
+0ACB..0ACC ; Gujarati # Mc [2] GUJARATI VOWEL SIGN O..GUJARATI VOWEL SIGN AU
+0ACD ; Gujarati # Mn GUJARATI SIGN VIRAMA
+0AD0 ; Gujarati # Lo GUJARATI OM
+0AE0..0AE1 ; Gujarati # Lo [2] GUJARATI LETTER VOCALIC RR..GUJARATI LETTER VOCALIC LL
+0AE2..0AE3 ; Gujarati # Mn [2] GUJARATI VOWEL SIGN VOCALIC L..GUJARATI VOWEL SIGN VOCALIC LL
+0AE6..0AEF ; Gujarati # Nd [10] GUJARATI DIGIT ZERO..GUJARATI DIGIT NINE
+0AF1 ; Gujarati # Sc GUJARATI RUPEE SIGN
+
+# Total code points: 83
+
+# ================================================
+
+0B01 ; Oriya # Mn ORIYA SIGN CANDRABINDU
+0B02..0B03 ; Oriya # Mc [2] ORIYA SIGN ANUSVARA..ORIYA SIGN VISARGA
+0B05..0B0C ; Oriya # Lo [8] ORIYA LETTER A..ORIYA LETTER VOCALIC L
+0B0F..0B10 ; Oriya # Lo [2] ORIYA LETTER E..ORIYA LETTER AI
+0B13..0B28 ; Oriya # Lo [22] ORIYA LETTER O..ORIYA LETTER NA
+0B2A..0B30 ; Oriya # Lo [7] ORIYA LETTER PA..ORIYA LETTER RA
+0B32..0B33 ; Oriya # Lo [2] ORIYA LETTER LA..ORIYA LETTER LLA
+0B35..0B39 ; Oriya # Lo [5] ORIYA LETTER VA..ORIYA LETTER HA
+0B3C ; Oriya # Mn ORIYA SIGN NUKTA
+0B3D ; Oriya # Lo ORIYA SIGN AVAGRAHA
+0B3E ; Oriya # Mc ORIYA VOWEL SIGN AA
+0B3F ; Oriya # Mn ORIYA VOWEL SIGN I
+0B40 ; Oriya # Mc ORIYA VOWEL SIGN II
+0B41..0B44 ; Oriya # Mn [4] ORIYA VOWEL SIGN U..ORIYA VOWEL SIGN VOCALIC RR
+0B47..0B48 ; Oriya # Mc [2] ORIYA VOWEL SIGN E..ORIYA VOWEL SIGN AI
+0B4B..0B4C ; Oriya # Mc [2] ORIYA VOWEL SIGN O..ORIYA VOWEL SIGN AU
+0B4D ; Oriya # Mn ORIYA SIGN VIRAMA
+0B56 ; Oriya # Mn ORIYA AI LENGTH MARK
+0B57 ; Oriya # Mc ORIYA AU LENGTH MARK
+0B5C..0B5D ; Oriya # Lo [2] ORIYA LETTER RRA..ORIYA LETTER RHA
+0B5F..0B61 ; Oriya # Lo [3] ORIYA LETTER YYA..ORIYA LETTER VOCALIC LL
+0B62..0B63 ; Oriya # Mn [2] ORIYA VOWEL SIGN VOCALIC L..ORIYA VOWEL SIGN VOCALIC LL
+0B66..0B6F ; Oriya # Nd [10] ORIYA DIGIT ZERO..ORIYA DIGIT NINE
+0B70 ; Oriya # So ORIYA ISSHAR
+0B71 ; Oriya # Lo ORIYA LETTER WA
+
+# Total code points: 84
+
+# ================================================
+
+0B82 ; Tamil # Mn TAMIL SIGN ANUSVARA
+0B83 ; Tamil # Lo TAMIL SIGN VISARGA
+0B85..0B8A ; Tamil # Lo [6] TAMIL LETTER A..TAMIL LETTER UU
+0B8E..0B90 ; Tamil # Lo [3] TAMIL LETTER E..TAMIL LETTER AI
+0B92..0B95 ; Tamil # Lo [4] TAMIL LETTER O..TAMIL LETTER KA
+0B99..0B9A ; Tamil # Lo [2] TAMIL LETTER NGA..TAMIL LETTER CA
+0B9C ; Tamil # Lo TAMIL LETTER JA
+0B9E..0B9F ; Tamil # Lo [2] TAMIL LETTER NYA..TAMIL LETTER TTA
+0BA3..0BA4 ; Tamil # Lo [2] TAMIL LETTER NNA..TAMIL LETTER TA
+0BA8..0BAA ; Tamil # Lo [3] TAMIL LETTER NA..TAMIL LETTER PA
+0BAE..0BB9 ; Tamil # Lo [12] TAMIL LETTER MA..TAMIL LETTER HA
+0BBE..0BBF ; Tamil # Mc [2] TAMIL VOWEL SIGN AA..TAMIL VOWEL SIGN I
+0BC0 ; Tamil # Mn TAMIL VOWEL SIGN II
+0BC1..0BC2 ; Tamil # Mc [2] TAMIL VOWEL SIGN U..TAMIL VOWEL SIGN UU
+0BC6..0BC8 ; Tamil # Mc [3] TAMIL VOWEL SIGN E..TAMIL VOWEL SIGN AI
+0BCA..0BCC ; Tamil # Mc [3] TAMIL VOWEL SIGN O..TAMIL VOWEL SIGN AU
+0BCD ; Tamil # Mn TAMIL SIGN VIRAMA
+0BD0 ; Tamil # Lo TAMIL OM
+0BD7 ; Tamil # Mc TAMIL AU LENGTH MARK
+0BE6..0BEF ; Tamil # Nd [10] TAMIL DIGIT ZERO..TAMIL DIGIT NINE
+0BF0..0BF2 ; Tamil # No [3] TAMIL NUMBER TEN..TAMIL NUMBER ONE THOUSAND
+0BF3..0BF8 ; Tamil # So [6] TAMIL DAY SIGN..TAMIL AS ABOVE SIGN
+0BF9 ; Tamil # Sc TAMIL RUPEE SIGN
+0BFA ; Tamil # So TAMIL NUMBER SIGN
+
+# Total code points: 72
+
+# ================================================
+
+0C01..0C03 ; Telugu # Mc [3] TELUGU SIGN CANDRABINDU..TELUGU SIGN VISARGA
+0C05..0C0C ; Telugu # Lo [8] TELUGU LETTER A..TELUGU LETTER VOCALIC L
+0C0E..0C10 ; Telugu # Lo [3] TELUGU LETTER E..TELUGU LETTER AI
+0C12..0C28 ; Telugu # Lo [23] TELUGU LETTER O..TELUGU LETTER NA
+0C2A..0C33 ; Telugu # Lo [10] TELUGU LETTER PA..TELUGU LETTER LLA
+0C35..0C39 ; Telugu # Lo [5] TELUGU LETTER VA..TELUGU LETTER HA
+0C3D ; Telugu # Lo TELUGU SIGN AVAGRAHA
+0C3E..0C40 ; Telugu # Mn [3] TELUGU VOWEL SIGN AA..TELUGU VOWEL SIGN II
+0C41..0C44 ; Telugu # Mc [4] TELUGU VOWEL SIGN U..TELUGU VOWEL SIGN VOCALIC RR
+0C46..0C48 ; Telugu # Mn [3] TELUGU VOWEL SIGN E..TELUGU VOWEL SIGN AI
+0C4A..0C4D ; Telugu # Mn [4] TELUGU VOWEL SIGN O..TELUGU SIGN VIRAMA
+0C55..0C56 ; Telugu # Mn [2] TELUGU LENGTH MARK..TELUGU AI LENGTH MARK
+0C58..0C59 ; Telugu # Lo [2] TELUGU LETTER TSA..TELUGU LETTER DZA
+0C60..0C61 ; Telugu # Lo [2] TELUGU LETTER VOCALIC RR..TELUGU LETTER VOCALIC LL
+0C62..0C63 ; Telugu # Mn [2] TELUGU VOWEL SIGN VOCALIC L..TELUGU VOWEL SIGN VOCALIC LL
+0C66..0C6F ; Telugu # Nd [10] TELUGU DIGIT ZERO..TELUGU DIGIT NINE
+0C78..0C7E ; Telugu # No [7] TELUGU FRACTION DIGIT ZERO FOR ODD POWERS OF FOUR..TELUGU FRACTION DIGIT THREE FOR EVEN POWERS OF FOUR
+0C7F ; Telugu # So TELUGU SIGN TUUMU
+
+# Total code points: 93
+
+# ================================================
+
+0C82..0C83 ; Kannada # Mc [2] KANNADA SIGN ANUSVARA..KANNADA SIGN VISARGA
+0C85..0C8C ; Kannada # Lo [8] KANNADA LETTER A..KANNADA LETTER VOCALIC L
+0C8E..0C90 ; Kannada # Lo [3] KANNADA LETTER E..KANNADA LETTER AI
+0C92..0CA8 ; Kannada # Lo [23] KANNADA LETTER O..KANNADA LETTER NA
+0CAA..0CB3 ; Kannada # Lo [10] KANNADA LETTER PA..KANNADA LETTER LLA
+0CB5..0CB9 ; Kannada # Lo [5] KANNADA LETTER VA..KANNADA LETTER HA
+0CBC ; Kannada # Mn KANNADA SIGN NUKTA
+0CBD ; Kannada # Lo KANNADA SIGN AVAGRAHA
+0CBE ; Kannada # Mc KANNADA VOWEL SIGN AA
+0CBF ; Kannada # Mn KANNADA VOWEL SIGN I
+0CC0..0CC4 ; Kannada # Mc [5] KANNADA VOWEL SIGN II..KANNADA VOWEL SIGN VOCALIC RR
+0CC6 ; Kannada # Mn KANNADA VOWEL SIGN E
+0CC7..0CC8 ; Kannada # Mc [2] KANNADA VOWEL SIGN EE..KANNADA VOWEL SIGN AI
+0CCA..0CCB ; Kannada # Mc [2] KANNADA VOWEL SIGN O..KANNADA VOWEL SIGN OO
+0CCC..0CCD ; Kannada # Mn [2] KANNADA VOWEL SIGN AU..KANNADA SIGN VIRAMA
+0CD5..0CD6 ; Kannada # Mc [2] KANNADA LENGTH MARK..KANNADA AI LENGTH MARK
+0CDE ; Kannada # Lo KANNADA LETTER FA
+0CE0..0CE1 ; Kannada # Lo [2] KANNADA LETTER VOCALIC RR..KANNADA LETTER VOCALIC LL
+0CE2..0CE3 ; Kannada # Mn [2] KANNADA VOWEL SIGN VOCALIC L..KANNADA VOWEL SIGN VOCALIC LL
+0CE6..0CEF ; Kannada # Nd [10] KANNADA DIGIT ZERO..KANNADA DIGIT NINE
+
+# Total code points: 84
+
+# ================================================
+
+0D02..0D03 ; Malayalam # Mc [2] MALAYALAM SIGN ANUSVARA..MALAYALAM SIGN VISARGA
+0D05..0D0C ; Malayalam # Lo [8] MALAYALAM LETTER A..MALAYALAM LETTER VOCALIC L
+0D0E..0D10 ; Malayalam # Lo [3] MALAYALAM LETTER E..MALAYALAM LETTER AI
+0D12..0D28 ; Malayalam # Lo [23] MALAYALAM LETTER O..MALAYALAM LETTER NA
+0D2A..0D39 ; Malayalam # Lo [16] MALAYALAM LETTER PA..MALAYALAM LETTER HA
+0D3D ; Malayalam # Lo MALAYALAM SIGN AVAGRAHA
+0D3E..0D40 ; Malayalam # Mc [3] MALAYALAM VOWEL SIGN AA..MALAYALAM VOWEL SIGN II
+0D41..0D44 ; Malayalam # Mn [4] MALAYALAM VOWEL SIGN U..MALAYALAM VOWEL SIGN VOCALIC RR
+0D46..0D48 ; Malayalam # Mc [3] MALAYALAM VOWEL SIGN E..MALAYALAM VOWEL SIGN AI
+0D4A..0D4C ; Malayalam # Mc [3] MALAYALAM VOWEL SIGN O..MALAYALAM VOWEL SIGN AU
+0D4D ; Malayalam # Mn MALAYALAM SIGN VIRAMA
+0D57 ; Malayalam # Mc MALAYALAM AU LENGTH MARK
+0D60..0D61 ; Malayalam # Lo [2] MALAYALAM LETTER VOCALIC RR..MALAYALAM LETTER VOCALIC LL
+0D62..0D63 ; Malayalam # Mn [2] MALAYALAM VOWEL SIGN VOCALIC L..MALAYALAM VOWEL SIGN VOCALIC LL
+0D66..0D6F ; Malayalam # Nd [10] MALAYALAM DIGIT ZERO..MALAYALAM DIGIT NINE
+0D70..0D75 ; Malayalam # No [6] MALAYALAM NUMBER TEN..MALAYALAM FRACTION THREE QUARTERS
+0D79 ; Malayalam # So MALAYALAM DATE MARK
+0D7A..0D7F ; Malayalam # Lo [6] MALAYALAM LETTER CHILLU NN..MALAYALAM LETTER CHILLU K
+
+# Total code points: 95
+
+# ================================================
+
+0D82..0D83 ; Sinhala # Mc [2] SINHALA SIGN ANUSVARAYA..SINHALA SIGN VISARGAYA
+0D85..0D96 ; Sinhala # Lo [18] SINHALA LETTER AYANNA..SINHALA LETTER AUYANNA
+0D9A..0DB1 ; Sinhala # Lo [24] SINHALA LETTER ALPAPRAANA KAYANNA..SINHALA LETTER DANTAJA NAYANNA
+0DB3..0DBB ; Sinhala # Lo [9] SINHALA LETTER SANYAKA DAYANNA..SINHALA LETTER RAYANNA
+0DBD ; Sinhala # Lo SINHALA LETTER DANTAJA LAYANNA
+0DC0..0DC6 ; Sinhala # Lo [7] SINHALA LETTER VAYANNA..SINHALA LETTER FAYANNA
+0DCA ; Sinhala # Mn SINHALA SIGN AL-LAKUNA
+0DCF..0DD1 ; Sinhala # Mc [3] SINHALA VOWEL SIGN AELA-PILLA..SINHALA VOWEL SIGN DIGA AEDA-PILLA
+0DD2..0DD4 ; Sinhala # Mn [3] SINHALA VOWEL SIGN KETTI IS-PILLA..SINHALA VOWEL SIGN KETTI PAA-PILLA
+0DD6 ; Sinhala # Mn SINHALA VOWEL SIGN DIGA PAA-PILLA
+0DD8..0DDF ; Sinhala # Mc [8] SINHALA VOWEL SIGN GAETTA-PILLA..SINHALA VOWEL SIGN GAYANUKITTA
+0DF2..0DF3 ; Sinhala # Mc [2] SINHALA VOWEL SIGN DIGA GAETTA-PILLA..SINHALA VOWEL SIGN DIGA GAYANUKITTA
+0DF4 ; Sinhala # Po SINHALA PUNCTUATION KUNDDALIYA
+
+# Total code points: 80
+
+# ================================================
+
+0E01..0E30 ; Thai # Lo [48] THAI CHARACTER KO KAI..THAI CHARACTER SARA A
+0E31 ; Thai # Mn THAI CHARACTER MAI HAN-AKAT
+0E32..0E33 ; Thai # Lo [2] THAI CHARACTER SARA AA..THAI CHARACTER SARA AM
+0E34..0E3A ; Thai # Mn [7] THAI CHARACTER SARA I..THAI CHARACTER PHINTHU
+0E40..0E45 ; Thai # Lo [6] THAI CHARACTER SARA E..THAI CHARACTER LAKKHANGYAO
+0E46 ; Thai # Lm THAI CHARACTER MAIYAMOK
+0E47..0E4E ; Thai # Mn [8] THAI CHARACTER MAITAIKHU..THAI CHARACTER YAMAKKAN
+0E4F ; Thai # Po THAI CHARACTER FONGMAN
+0E50..0E59 ; Thai # Nd [10] THAI DIGIT ZERO..THAI DIGIT NINE
+0E5A..0E5B ; Thai # Po [2] THAI CHARACTER ANGKHANKHU..THAI CHARACTER KHOMUT
+
+# Total code points: 86
+
+# ================================================
+
+0E81..0E82 ; Lao # Lo [2] LAO LETTER KO..LAO LETTER KHO SUNG
+0E84 ; Lao # Lo LAO LETTER KHO TAM
+0E87..0E88 ; Lao # Lo [2] LAO LETTER NGO..LAO LETTER CO
+0E8A ; Lao # Lo LAO LETTER SO TAM
+0E8D ; Lao # Lo LAO LETTER NYO
+0E94..0E97 ; Lao # Lo [4] LAO LETTER DO..LAO LETTER THO TAM
+0E99..0E9F ; Lao # Lo [7] LAO LETTER NO..LAO LETTER FO SUNG
+0EA1..0EA3 ; Lao # Lo [3] LAO LETTER MO..LAO LETTER LO LING
+0EA5 ; Lao # Lo LAO LETTER LO LOOT
+0EA7 ; Lao # Lo LAO LETTER WO
+0EAA..0EAB ; Lao # Lo [2] LAO LETTER SO SUNG..LAO LETTER HO SUNG
+0EAD..0EB0 ; Lao # Lo [4] LAO LETTER O..LAO VOWEL SIGN A
+0EB1 ; Lao # Mn LAO VOWEL SIGN MAI KAN
+0EB2..0EB3 ; Lao # Lo [2] LAO VOWEL SIGN AA..LAO VOWEL SIGN AM
+0EB4..0EB9 ; Lao # Mn [6] LAO VOWEL SIGN I..LAO VOWEL SIGN UU
+0EBB..0EBC ; Lao # Mn [2] LAO VOWEL SIGN MAI KON..LAO SEMIVOWEL SIGN LO
+0EBD ; Lao # Lo LAO SEMIVOWEL SIGN NYO
+0EC0..0EC4 ; Lao # Lo [5] LAO VOWEL SIGN E..LAO VOWEL SIGN AI
+0EC6 ; Lao # Lm LAO KO LA
+0EC8..0ECD ; Lao # Mn [6] LAO TONE MAI EK..LAO NIGGAHITA
+0ED0..0ED9 ; Lao # Nd [10] LAO DIGIT ZERO..LAO DIGIT NINE
+0EDC..0EDD ; Lao # Lo [2] LAO HO NO..LAO HO MO
+
+# Total code points: 65
+
+# ================================================
+
+0F00 ; Tibetan # Lo TIBETAN SYLLABLE OM
+0F01..0F03 ; Tibetan # So [3] TIBETAN MARK GTER YIG MGO TRUNCATED A..TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA
+0F04..0F12 ; Tibetan # Po [15] TIBETAN MARK INITIAL YIG MGO MDUN MA..TIBETAN MARK RGYA GRAM SHAD
+0F13..0F17 ; Tibetan # So [5] TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN..TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS
+0F18..0F19 ; Tibetan # Mn [2] TIBETAN ASTROLOGICAL SIGN -KHYUD PA..TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS
+0F1A..0F1F ; Tibetan # So [6] TIBETAN SIGN RDEL DKAR GCIG..TIBETAN SIGN RDEL DKAR RDEL NAG
+0F20..0F29 ; Tibetan # Nd [10] TIBETAN DIGIT ZERO..TIBETAN DIGIT NINE
+0F2A..0F33 ; Tibetan # No [10] TIBETAN DIGIT HALF ONE..TIBETAN DIGIT HALF ZERO
+0F34 ; Tibetan # So TIBETAN MARK BSDUS RTAGS
+0F35 ; Tibetan # Mn TIBETAN MARK NGAS BZUNG NYI ZLA
+0F36 ; Tibetan # So TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN
+0F37 ; Tibetan # Mn TIBETAN MARK NGAS BZUNG SGOR RTAGS
+0F38 ; Tibetan # So TIBETAN MARK CHE MGO
+0F39 ; Tibetan # Mn TIBETAN MARK TSA -PHRU
+0F3A ; Tibetan # Ps TIBETAN MARK GUG RTAGS GYON
+0F3B ; Tibetan # Pe TIBETAN MARK GUG RTAGS GYAS
+0F3C ; Tibetan # Ps TIBETAN MARK ANG KHANG GYON
+0F3D ; Tibetan # Pe TIBETAN MARK ANG KHANG GYAS
+0F3E..0F3F ; Tibetan # Mc [2] TIBETAN SIGN YAR TSHES..TIBETAN SIGN MAR TSHES
+0F40..0F47 ; Tibetan # Lo [8] TIBETAN LETTER KA..TIBETAN LETTER JA
+0F49..0F6C ; Tibetan # Lo [36] TIBETAN LETTER NYA..TIBETAN LETTER RRA
+0F71..0F7E ; Tibetan # Mn [14] TIBETAN VOWEL SIGN AA..TIBETAN SIGN RJES SU NGA RO
+0F7F ; Tibetan # Mc TIBETAN SIGN RNAM BCAD
+0F80..0F84 ; Tibetan # Mn [5] TIBETAN VOWEL SIGN REVERSED I..TIBETAN MARK HALANTA
+0F85 ; Tibetan # Po TIBETAN MARK PALUTA
+0F86..0F87 ; Tibetan # Mn [2] TIBETAN SIGN LCI RTAGS..TIBETAN SIGN YANG RTAGS
+0F88..0F8B ; Tibetan # Lo [4] TIBETAN SIGN LCE TSA CAN..TIBETAN SIGN GRU MED RGYINGS
+0F90..0F97 ; Tibetan # Mn [8] TIBETAN SUBJOINED LETTER KA..TIBETAN SUBJOINED LETTER JA
+0F99..0FBC ; Tibetan # Mn [36] TIBETAN SUBJOINED LETTER NYA..TIBETAN SUBJOINED LETTER FIXED-FORM RA
+0FBE..0FC5 ; Tibetan # So [8] TIBETAN KU RU KHA..TIBETAN SYMBOL RDO RJE
+0FC6 ; Tibetan # Mn TIBETAN SYMBOL PADMA GDAN
+0FC7..0FCC ; Tibetan # So [6] TIBETAN SYMBOL RDO RJE RGYA GRAM..TIBETAN SYMBOL NOR BU BZHI -KHYIL
+0FCE..0FCF ; Tibetan # So [2] TIBETAN SIGN RDEL NAG RDEL DKAR..TIBETAN SIGN RDEL NAG GSUM
+0FD0..0FD4 ; Tibetan # Po [5] TIBETAN MARK BSKA- SHOG GI MGO RGYAN..TIBETAN MARK CLOSING BRDA RNYING YIG MGO SGAB MA
+
+# Total code points: 201
+
+# ================================================
+
+1000..102A ; Myanmar # Lo [43] MYANMAR LETTER KA..MYANMAR LETTER AU
+102B..102C ; Myanmar # Mc [2] MYANMAR VOWEL SIGN TALL AA..MYANMAR VOWEL SIGN AA
+102D..1030 ; Myanmar # Mn [4] MYANMAR VOWEL SIGN I..MYANMAR VOWEL SIGN UU
+1031 ; Myanmar # Mc MYANMAR VOWEL SIGN E
+1032..1037 ; Myanmar # Mn [6] MYANMAR VOWEL SIGN AI..MYANMAR SIGN DOT BELOW
+1038 ; Myanmar # Mc MYANMAR SIGN VISARGA
+1039..103A ; Myanmar # Mn [2] MYANMAR SIGN VIRAMA..MYANMAR SIGN ASAT
+103B..103C ; Myanmar # Mc [2] MYANMAR CONSONANT SIGN MEDIAL YA..MYANMAR CONSONANT SIGN MEDIAL RA
+103D..103E ; Myanmar # Mn [2] MYANMAR CONSONANT SIGN MEDIAL WA..MYANMAR CONSONANT SIGN MEDIAL HA
+103F ; Myanmar # Lo MYANMAR LETTER GREAT SA
+1040..1049 ; Myanmar # Nd [10] MYANMAR DIGIT ZERO..MYANMAR DIGIT NINE
+104A..104F ; Myanmar # Po [6] MYANMAR SIGN LITTLE SECTION..MYANMAR SYMBOL GENITIVE
+1050..1055 ; Myanmar # Lo [6] MYANMAR LETTER SHA..MYANMAR LETTER VOCALIC LL
+1056..1057 ; Myanmar # Mc [2] MYANMAR VOWEL SIGN VOCALIC R..MYANMAR VOWEL SIGN VOCALIC RR
+1058..1059 ; Myanmar # Mn [2] MYANMAR VOWEL SIGN VOCALIC L..MYANMAR VOWEL SIGN VOCALIC LL
+105A..105D ; Myanmar # Lo [4] MYANMAR LETTER MON NGA..MYANMAR LETTER MON BBE
+105E..1060 ; Myanmar # Mn [3] MYANMAR CONSONANT SIGN MON MEDIAL NA..MYANMAR CONSONANT SIGN MON MEDIAL LA
+1061 ; Myanmar # Lo MYANMAR LETTER SGAW KAREN SHA
+1062..1064 ; Myanmar # Mc [3] MYANMAR VOWEL SIGN SGAW KAREN EU..MYANMAR TONE MARK SGAW KAREN KE PHO
+1065..1066 ; Myanmar # Lo [2] MYANMAR LETTER WESTERN PWO KAREN THA..MYANMAR LETTER WESTERN PWO KAREN PWA
+1067..106D ; Myanmar # Mc [7] MYANMAR VOWEL SIGN WESTERN PWO KAREN EU..MYANMAR SIGN WESTERN PWO KAREN TONE-5
+106E..1070 ; Myanmar # Lo [3] MYANMAR LETTER EASTERN PWO KAREN NNA..MYANMAR LETTER EASTERN PWO KAREN GHWA
+1071..1074 ; Myanmar # Mn [4] MYANMAR VOWEL SIGN GEBA KAREN I..MYANMAR VOWEL SIGN KAYAH EE
+1075..1081 ; Myanmar # Lo [13] MYANMAR LETTER SHAN KA..MYANMAR LETTER SHAN HA
+1082 ; Myanmar # Mn MYANMAR CONSONANT SIGN SHAN MEDIAL WA
+1083..1084 ; Myanmar # Mc [2] MYANMAR VOWEL SIGN SHAN AA..MYANMAR VOWEL SIGN SHAN E
+1085..1086 ; Myanmar # Mn [2] MYANMAR VOWEL SIGN SHAN E ABOVE..MYANMAR VOWEL SIGN SHAN FINAL Y
+1087..108C ; Myanmar # Mc [6] MYANMAR SIGN SHAN TONE-2..MYANMAR SIGN SHAN COUNCIL TONE-3
+108D ; Myanmar # Mn MYANMAR SIGN SHAN COUNCIL EMPHATIC TONE
+108E ; Myanmar # Lo MYANMAR LETTER RUMAI PALAUNG FA
+108F ; Myanmar # Mc MYANMAR SIGN RUMAI PALAUNG TONE-5
+1090..1099 ; Myanmar # Nd [10] MYANMAR SHAN DIGIT ZERO..MYANMAR SHAN DIGIT NINE
+109E..109F ; Myanmar # So [2] MYANMAR SYMBOL SHAN ONE..MYANMAR SYMBOL SHAN EXCLAMATION
+
+# Total code points: 156
+
+# ================================================
+
+10A0..10C5 ; Georgian # L& [38] GEORGIAN CAPITAL LETTER AN..GEORGIAN CAPITAL LETTER HOE
+10D0..10FA ; Georgian # Lo [43] GEORGIAN LETTER AN..GEORGIAN LETTER AIN
+10FC ; Georgian # Lm MODIFIER LETTER GEORGIAN NAR
+2D00..2D25 ; Georgian # L& [38] GEORGIAN SMALL LETTER AN..GEORGIAN SMALL LETTER HOE
+
+# Total code points: 120
+
+# ================================================
+
+1100..1159 ; Hangul # Lo [90] HANGUL CHOSEONG KIYEOK..HANGUL CHOSEONG YEORINHIEUH
+115F..11A2 ; Hangul # Lo [68] HANGUL CHOSEONG FILLER..HANGUL JUNGSEONG SSANGARAEA
+11A8..11F9 ; Hangul # Lo [82] HANGUL JONGSEONG KIYEOK..HANGUL JONGSEONG YEORINHIEUH
+3131..318E ; Hangul # Lo [94] HANGUL LETTER KIYEOK..HANGUL LETTER ARAEAE
+3200..321E ; Hangul # So [31] PARENTHESIZED HANGUL KIYEOK..PARENTHESIZED KOREAN CHARACTER O HU
+3260..327E ; Hangul # So [31] CIRCLED HANGUL KIYEOK..CIRCLED HANGUL IEUNG U
+AC00..D7A3 ; Hangul # Lo [11172] HANGUL SYLLABLE GA..HANGUL SYLLABLE HIH
+FFA0..FFBE ; Hangul # Lo [31] HALFWIDTH HANGUL FILLER..HALFWIDTH HANGUL LETTER HIEUH
+FFC2..FFC7 ; Hangul # Lo [6] HALFWIDTH HANGUL LETTER A..HALFWIDTH HANGUL LETTER E
+FFCA..FFCF ; Hangul # Lo [6] HALFWIDTH HANGUL LETTER YEO..HALFWIDTH HANGUL LETTER OE
+FFD2..FFD7 ; Hangul # Lo [6] HALFWIDTH HANGUL LETTER YO..HALFWIDTH HANGUL LETTER YU
+FFDA..FFDC ; Hangul # Lo [3] HALFWIDTH HANGUL LETTER EU..HALFWIDTH HANGUL LETTER I
+
+# Total code points: 11620
+
+# ================================================
+
+1200..1248 ; Ethiopic # Lo [73] ETHIOPIC SYLLABLE HA..ETHIOPIC SYLLABLE QWA
+124A..124D ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE QWI..ETHIOPIC SYLLABLE QWE
+1250..1256 ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE QHA..ETHIOPIC SYLLABLE QHO
+1258 ; Ethiopic # Lo ETHIOPIC SYLLABLE QHWA
+125A..125D ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE QHWI..ETHIOPIC SYLLABLE QHWE
+1260..1288 ; Ethiopic # Lo [41] ETHIOPIC SYLLABLE BA..ETHIOPIC SYLLABLE XWA
+128A..128D ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE XWI..ETHIOPIC SYLLABLE XWE
+1290..12B0 ; Ethiopic # Lo [33] ETHIOPIC SYLLABLE NA..ETHIOPIC SYLLABLE KWA
+12B2..12B5 ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE KWI..ETHIOPIC SYLLABLE KWE
+12B8..12BE ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE KXA..ETHIOPIC SYLLABLE KXO
+12C0 ; Ethiopic # Lo ETHIOPIC SYLLABLE KXWA
+12C2..12C5 ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE KXWI..ETHIOPIC SYLLABLE KXWE
+12C8..12D6 ; Ethiopic # Lo [15] ETHIOPIC SYLLABLE WA..ETHIOPIC SYLLABLE PHARYNGEAL O
+12D8..1310 ; Ethiopic # Lo [57] ETHIOPIC SYLLABLE ZA..ETHIOPIC SYLLABLE GWA
+1312..1315 ; Ethiopic # Lo [4] ETHIOPIC SYLLABLE GWI..ETHIOPIC SYLLABLE GWE
+1318..135A ; Ethiopic # Lo [67] ETHIOPIC SYLLABLE GGA..ETHIOPIC SYLLABLE FYA
+135F ; Ethiopic # Mn ETHIOPIC COMBINING GEMINATION MARK
+1360 ; Ethiopic # So ETHIOPIC SECTION MARK
+1361..1368 ; Ethiopic # Po [8] ETHIOPIC WORDSPACE..ETHIOPIC PARAGRAPH SEPARATOR
+1369..137C ; Ethiopic # No [20] ETHIOPIC DIGIT ONE..ETHIOPIC NUMBER TEN THOUSAND
+1380..138F ; Ethiopic # Lo [16] ETHIOPIC SYLLABLE SEBATBEIT MWA..ETHIOPIC SYLLABLE PWE
+1390..1399 ; Ethiopic # So [10] ETHIOPIC TONAL MARK YIZET..ETHIOPIC TONAL MARK KURT
+2D80..2D96 ; Ethiopic # Lo [23] ETHIOPIC SYLLABLE LOA..ETHIOPIC SYLLABLE GGWE
+2DA0..2DA6 ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE SSA..ETHIOPIC SYLLABLE SSO
+2DA8..2DAE ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE CCA..ETHIOPIC SYLLABLE CCO
+2DB0..2DB6 ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE ZZA..ETHIOPIC SYLLABLE ZZO
+2DB8..2DBE ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE CCHA..ETHIOPIC SYLLABLE CCHO
+2DC0..2DC6 ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE QYA..ETHIOPIC SYLLABLE QYO
+2DC8..2DCE ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE KYA..ETHIOPIC SYLLABLE KYO
+2DD0..2DD6 ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE XYA..ETHIOPIC SYLLABLE XYO
+2DD8..2DDE ; Ethiopic # Lo [7] ETHIOPIC SYLLABLE GYA..ETHIOPIC SYLLABLE GYO
+
+# Total code points: 461
+
+# ================================================
+
+13A0..13F4 ; Cherokee # Lo [85] CHEROKEE LETTER A..CHEROKEE LETTER YV
+
+# Total code points: 85
+
+# ================================================
+
+1401..166C ; Canadian_Aboriginal # Lo [620] CANADIAN SYLLABICS E..CANADIAN SYLLABICS CARRIER TTSA
+166D..166E ; Canadian_Aboriginal # Po [2] CANADIAN SYLLABICS CHI SIGN..CANADIAN SYLLABICS FULL STOP
+166F..1676 ; Canadian_Aboriginal # Lo [8] CANADIAN SYLLABICS QAI..CANADIAN SYLLABICS NNGAA
+
+# Total code points: 630
+
+# ================================================
+
+1680 ; Ogham # Zs OGHAM SPACE MARK
+1681..169A ; Ogham # Lo [26] OGHAM LETTER BEITH..OGHAM LETTER PEITH
+169B ; Ogham # Ps OGHAM FEATHER MARK
+169C ; Ogham # Pe OGHAM REVERSED FEATHER MARK
+
+# Total code points: 29
+
+# ================================================
+
+16A0..16EA ; Runic # Lo [75] RUNIC LETTER FEHU FEOH FE F..RUNIC LETTER X
+16EE..16F0 ; Runic # Nl [3] RUNIC ARLAUG SYMBOL..RUNIC BELGTHOR SYMBOL
+
+# Total code points: 78
+
+# ================================================
+
+1780..17B3 ; Khmer # Lo [52] KHMER LETTER KA..KHMER INDEPENDENT VOWEL QAU
+17B4..17B5 ; Khmer # Cf [2] KHMER VOWEL INHERENT AQ..KHMER VOWEL INHERENT AA
+17B6 ; Khmer # Mc KHMER VOWEL SIGN AA
+17B7..17BD ; Khmer # Mn [7] KHMER VOWEL SIGN I..KHMER VOWEL SIGN UA
+17BE..17C5 ; Khmer # Mc [8] KHMER VOWEL SIGN OE..KHMER VOWEL SIGN AU
+17C6 ; Khmer # Mn KHMER SIGN NIKAHIT
+17C7..17C8 ; Khmer # Mc [2] KHMER SIGN REAHMUK..KHMER SIGN YUUKALEAPINTU
+17C9..17D3 ; Khmer # Mn [11] KHMER SIGN MUUSIKATOAN..KHMER SIGN BATHAMASAT
+17D4..17D6 ; Khmer # Po [3] KHMER SIGN KHAN..KHMER SIGN CAMNUC PII KUUH
+17D7 ; Khmer # Lm KHMER SIGN LEK TOO
+17D8..17DA ; Khmer # Po [3] KHMER SIGN BEYYAL..KHMER SIGN KOOMUUT
+17DB ; Khmer # Sc KHMER CURRENCY SYMBOL RIEL
+17DC ; Khmer # Lo KHMER SIGN AVAKRAHASANYA
+17DD ; Khmer # Mn KHMER SIGN ATTHACAN
+17E0..17E9 ; Khmer # Nd [10] KHMER DIGIT ZERO..KHMER DIGIT NINE
+17F0..17F9 ; Khmer # No [10] KHMER SYMBOL LEK ATTAK SON..KHMER SYMBOL LEK ATTAK PRAM-BUON
+19E0..19FF ; Khmer # So [32] KHMER SYMBOL PATHAMASAT..KHMER SYMBOL DAP-PRAM ROC
+
+# Total code points: 146
+
+# ================================================
+
+1800..1801 ; Mongolian # Po [2] MONGOLIAN BIRGA..MONGOLIAN ELLIPSIS
+1804 ; Mongolian # Po MONGOLIAN COLON
+1806 ; Mongolian # Pd MONGOLIAN TODO SOFT HYPHEN
+1807..180A ; Mongolian # Po [4] MONGOLIAN SIBE SYLLABLE BOUNDARY MARKER..MONGOLIAN NIRUGU
+180B..180D ; Mongolian # Mn [3] MONGOLIAN FREE VARIATION SELECTOR ONE..MONGOLIAN FREE VARIATION SELECTOR THREE
+180E ; Mongolian # Zs MONGOLIAN VOWEL SEPARATOR
+1810..1819 ; Mongolian # Nd [10] MONGOLIAN DIGIT ZERO..MONGOLIAN DIGIT NINE
+1820..1842 ; Mongolian # Lo [35] MONGOLIAN LETTER A..MONGOLIAN LETTER CHI
+1843 ; Mongolian # Lm MONGOLIAN LETTER TODO LONG VOWEL SIGN
+1844..1877 ; Mongolian # Lo [52] MONGOLIAN LETTER TODO E..MONGOLIAN LETTER MANCHU ZHA
+1880..18A8 ; Mongolian # Lo [41] MONGOLIAN LETTER ALI GALI ANUSVARA ONE..MONGOLIAN LETTER MANCHU ALI GALI BHA
+18A9 ; Mongolian # Mn MONGOLIAN LETTER ALI GALI DAGALGA
+18AA ; Mongolian # Lo MONGOLIAN LETTER MANCHU ALI GALI LHA
+
+# Total code points: 153
+
+# ================================================
+
+3041..3096 ; Hiragana # Lo [86] HIRAGANA LETTER SMALL A..HIRAGANA LETTER SMALL KE
+309D..309E ; Hiragana # Lm [2] HIRAGANA ITERATION MARK..HIRAGANA VOICED ITERATION MARK
+309F ; Hiragana # Lo HIRAGANA DIGRAPH YORI
+
+# Total code points: 89
+
+# ================================================
+
+30A1..30FA ; Katakana # Lo [90] KATAKANA LETTER SMALL A..KATAKANA LETTER VO
+30FD..30FE ; Katakana # Lm [2] KATAKANA ITERATION MARK..KATAKANA VOICED ITERATION MARK
+30FF ; Katakana # Lo KATAKANA DIGRAPH KOTO
+31F0..31FF ; Katakana # Lo [16] KATAKANA LETTER SMALL KU..KATAKANA LETTER SMALL RO
+32D0..32FE ; Katakana # So [47] CIRCLED KATAKANA A..CIRCLED KATAKANA WO
+3300..3357 ; Katakana # So [88] SQUARE APAATO..SQUARE WATTO
+FF66..FF6F ; Katakana # Lo [10] HALFWIDTH KATAKANA LETTER WO..HALFWIDTH KATAKANA LETTER SMALL TU
+FF71..FF9D ; Katakana # Lo [45] HALFWIDTH KATAKANA LETTER A..HALFWIDTH KATAKANA LETTER N
+
+# Total code points: 299
+
+# ================================================
+
+3105..312D ; Bopomofo # Lo [41] BOPOMOFO LETTER B..BOPOMOFO LETTER IH
+31A0..31B7 ; Bopomofo # Lo [24] BOPOMOFO LETTER BU..BOPOMOFO FINAL LETTER H
+
+# Total code points: 65
+
+# ================================================
+
+2E80..2E99 ; Han # So [26] CJK RADICAL REPEAT..CJK RADICAL RAP
+2E9B..2EF3 ; Han # So [89] CJK RADICAL CHOKE..CJK RADICAL C-SIMPLIFIED TURTLE
+2F00..2FD5 ; Han # So [214] KANGXI RADICAL ONE..KANGXI RADICAL FLUTE
+3005 ; Han # Lm IDEOGRAPHIC ITERATION MARK
+3007 ; Han # Nl IDEOGRAPHIC NUMBER ZERO
+3021..3029 ; Han # Nl [9] HANGZHOU NUMERAL ONE..HANGZHOU NUMERAL NINE
+3038..303A ; Han # Nl [3] HANGZHOU NUMERAL TEN..HANGZHOU NUMERAL THIRTY
+303B ; Han # Lm VERTICAL IDEOGRAPHIC ITERATION MARK
+3400..4DB5 ; Han # Lo [6582] CJK UNIFIED IDEOGRAPH-3400..CJK UNIFIED IDEOGRAPH-4DB5
+4E00..9FC3 ; Han # Lo [20932] CJK UNIFIED IDEOGRAPH-4E00..CJK UNIFIED IDEOGRAPH-9FC3
+F900..FA2D ; Han # Lo [302] CJK COMPATIBILITY IDEOGRAPH-F900..CJK COMPATIBILITY IDEOGRAPH-FA2D
+FA30..FA6A ; Han # Lo [59] CJK COMPATIBILITY IDEOGRAPH-FA30..CJK COMPATIBILITY IDEOGRAPH-FA6A
+FA70..FAD9 ; Han # Lo [106] CJK COMPATIBILITY IDEOGRAPH-FA70..CJK COMPATIBILITY IDEOGRAPH-FAD9
+20000..2A6D6 ; Han # Lo [42711] CJK UNIFIED IDEOGRAPH-20000..CJK UNIFIED IDEOGRAPH-2A6D6
+2F800..2FA1D ; Han # Lo [542] CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
+
+# Total code points: 71578
+
+# ================================================
+
+A000..A014 ; Yi # Lo [21] YI SYLLABLE IT..YI SYLLABLE E
+A015 ; Yi # Lm YI SYLLABLE WU
+A016..A48C ; Yi # Lo [1143] YI SYLLABLE BIT..YI SYLLABLE YYR
+A490..A4C6 ; Yi # So [55] YI RADICAL QOT..YI RADICAL KE
+
+# Total code points: 1220
+
+# ================================================
+
+10300..1031E ; Old_Italic # Lo [31] OLD ITALIC LETTER A..OLD ITALIC LETTER UU
+10320..10323 ; Old_Italic # No [4] OLD ITALIC NUMERAL ONE..OLD ITALIC NUMERAL FIFTY
+
+# Total code points: 35
+
+# ================================================
+
+10330..10340 ; Gothic # Lo [17] GOTHIC LETTER AHSA..GOTHIC LETTER PAIRTHRA
+10341 ; Gothic # Nl GOTHIC LETTER NINETY
+10342..10349 ; Gothic # Lo [8] GOTHIC LETTER RAIDA..GOTHIC LETTER OTHAL
+1034A ; Gothic # Nl GOTHIC LETTER NINE HUNDRED
+
+# Total code points: 27
+
+# ================================================
+
+10400..1044F ; Deseret # L& [80] DESERET CAPITAL LETTER LONG I..DESERET SMALL LETTER EW
+
+# Total code points: 80
+
+# ================================================
+
+0300..036F ; Inherited # Mn [112] COMBINING GRAVE ACCENT..COMBINING LATIN SMALL LETTER X
+064B..0655 ; Inherited # Mn [11] ARABIC FATHATAN..ARABIC HAMZA BELOW
+0670 ; Inherited # Mn ARABIC LETTER SUPERSCRIPT ALEF
+0951..0952 ; Inherited # Mn [2] DEVANAGARI STRESS SIGN UDATTA..DEVANAGARI STRESS SIGN ANUDATTA
+1DC0..1DE6 ; Inherited # Mn [39] COMBINING DOTTED GRAVE ACCENT..COMBINING LATIN SMALL LETTER Z
+1DFE..1DFF ; Inherited # Mn [2] COMBINING LEFT ARROWHEAD ABOVE..COMBINING RIGHT ARROWHEAD AND DOWN ARROWHEAD BELOW
+200C..200D ; Inherited # Cf [2] ZERO WIDTH NON-JOINER..ZERO WIDTH JOINER
+20D0..20DC ; Inherited # Mn [13] COMBINING LEFT HARPOON ABOVE..COMBINING FOUR DOTS ABOVE
+20DD..20E0 ; Inherited # Me [4] COMBINING ENCLOSING CIRCLE..COMBINING ENCLOSING CIRCLE BACKSLASH
+20E1 ; Inherited # Mn COMBINING LEFT RIGHT ARROW ABOVE
+20E2..20E4 ; Inherited # Me [3] COMBINING ENCLOSING SCREEN..COMBINING ENCLOSING UPWARD POINTING TRIANGLE
+20E5..20F0 ; Inherited # Mn [12] COMBINING REVERSE SOLIDUS OVERLAY..COMBINING ASTERISK ABOVE
+302A..302F ; Inherited # Mn [6] IDEOGRAPHIC LEVEL TONE MARK..HANGUL DOUBLE DOT TONE MARK
+3099..309A ; Inherited # Mn [2] COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK..COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK
+FE00..FE0F ; Inherited # Mn [16] VARIATION SELECTOR-1..VARIATION SELECTOR-16
+FE20..FE26 ; Inherited # Mn [7] COMBINING LIGATURE LEFT HALF..COMBINING CONJOINING MACRON
+101FD ; Inherited # Mn PHAISTOS DISC SIGN COMBINING OBLIQUE STROKE
+1D167..1D169 ; Inherited # Mn [3] MUSICAL SYMBOL COMBINING TREMOLO-1..MUSICAL SYMBOL COMBINING TREMOLO-3
+1D17B..1D182 ; Inherited # Mn [8] MUSICAL SYMBOL COMBINING ACCENT..MUSICAL SYMBOL COMBINING LOURE
+1D185..1D18B ; Inherited # Mn [7] MUSICAL SYMBOL COMBINING DOIT..MUSICAL SYMBOL COMBINING TRIPLE TONGUE
+1D1AA..1D1AD ; Inherited # Mn [4] MUSICAL SYMBOL COMBINING DOWN BOW..MUSICAL SYMBOL COMBINING SNAP PIZZICATO
+E0100..E01EF ; Inherited # Mn [240] VARIATION SELECTOR-17..VARIATION SELECTOR-256
+
+# Total code points: 496
+
+# ================================================
+
+1700..170C ; Tagalog # Lo [13] TAGALOG LETTER A..TAGALOG LETTER YA
+170E..1711 ; Tagalog # Lo [4] TAGALOG LETTER LA..TAGALOG LETTER HA
+1712..1714 ; Tagalog # Mn [3] TAGALOG VOWEL SIGN I..TAGALOG SIGN VIRAMA
+
+# Total code points: 20
+
+# ================================================
+
+1720..1731 ; Hanunoo # Lo [18] HANUNOO LETTER A..HANUNOO LETTER HA
+1732..1734 ; Hanunoo # Mn [3] HANUNOO VOWEL SIGN I..HANUNOO SIGN PAMUDPOD
+
+# Total code points: 21
+
+# ================================================
+
+1740..1751 ; Buhid # Lo [18] BUHID LETTER A..BUHID LETTER HA
+1752..1753 ; Buhid # Mn [2] BUHID VOWEL SIGN I..BUHID VOWEL SIGN U
+
+# Total code points: 20
+
+# ================================================
+
+1760..176C ; Tagbanwa # Lo [13] TAGBANWA LETTER A..TAGBANWA LETTER YA
+176E..1770 ; Tagbanwa # Lo [3] TAGBANWA LETTER LA..TAGBANWA LETTER SA
+1772..1773 ; Tagbanwa # Mn [2] TAGBANWA VOWEL SIGN I..TAGBANWA VOWEL SIGN U
+
+# Total code points: 18
+
+# ================================================
+
+1900..191C ; Limbu # Lo [29] LIMBU VOWEL-CARRIER LETTER..LIMBU LETTER HA
+1920..1922 ; Limbu # Mn [3] LIMBU VOWEL SIGN A..LIMBU VOWEL SIGN U
+1923..1926 ; Limbu # Mc [4] LIMBU VOWEL SIGN EE..LIMBU VOWEL SIGN AU
+1927..1928 ; Limbu # Mn [2] LIMBU VOWEL SIGN E..LIMBU VOWEL SIGN O
+1929..192B ; Limbu # Mc [3] LIMBU SUBJOINED LETTER YA..LIMBU SUBJOINED LETTER WA
+1930..1931 ; Limbu # Mc [2] LIMBU SMALL LETTER KA..LIMBU SMALL LETTER NGA
+1932 ; Limbu # Mn LIMBU SMALL LETTER ANUSVARA
+1933..1938 ; Limbu # Mc [6] LIMBU SMALL LETTER TA..LIMBU SMALL LETTER LA
+1939..193B ; Limbu # Mn [3] LIMBU SIGN MUKPHRENG..LIMBU SIGN SA-I
+1940 ; Limbu # So LIMBU SIGN LOO
+1944..1945 ; Limbu # Po [2] LIMBU EXCLAMATION MARK..LIMBU QUESTION MARK
+1946..194F ; Limbu # Nd [10] LIMBU DIGIT ZERO..LIMBU DIGIT NINE
+
+# Total code points: 66
+
+# ================================================
+
+1950..196D ; Tai_Le # Lo [30] TAI LE LETTER KA..TAI LE LETTER AI
+1970..1974 ; Tai_Le # Lo [5] TAI LE LETTER TONE-2..TAI LE LETTER TONE-6
+
+# Total code points: 35
+
+# ================================================
+
+10000..1000B ; Linear_B # Lo [12] LINEAR B SYLLABLE B008 A..LINEAR B SYLLABLE B046 JE
+1000D..10026 ; Linear_B # Lo [26] LINEAR B SYLLABLE B036 JO..LINEAR B SYLLABLE B032 QO
+10028..1003A ; Linear_B # Lo [19] LINEAR B SYLLABLE B060 RA..LINEAR B SYLLABLE B042 WO
+1003C..1003D ; Linear_B # Lo [2] LINEAR B SYLLABLE B017 ZA..LINEAR B SYLLABLE B074 ZE
+1003F..1004D ; Linear_B # Lo [15] LINEAR B SYLLABLE B020 ZO..LINEAR B SYLLABLE B091 TWO
+10050..1005D ; Linear_B # Lo [14] LINEAR B SYMBOL B018..LINEAR B SYMBOL B089
+10080..100FA ; Linear_B # Lo [123] LINEAR B IDEOGRAM B100 MAN..LINEAR B IDEOGRAM VESSEL B305
+
+# Total code points: 211
+
+# ================================================
+
+10380..1039D ; Ugaritic # Lo [30] UGARITIC LETTER ALPA..UGARITIC LETTER SSU
+1039F ; Ugaritic # Po UGARITIC WORD DIVIDER
+
+# Total code points: 31
+
+# ================================================
+
+10450..1047F ; Shavian # Lo [48] SHAVIAN LETTER PEEP..SHAVIAN LETTER YEW
+
+# Total code points: 48
+
+# ================================================
+
+10480..1049D ; Osmanya # Lo [30] OSMANYA LETTER ALEF..OSMANYA LETTER OO
+104A0..104A9 ; Osmanya # Nd [10] OSMANYA DIGIT ZERO..OSMANYA DIGIT NINE
+
+# Total code points: 40
+
+# ================================================
+
+10800..10805 ; Cypriot # Lo [6] CYPRIOT SYLLABLE A..CYPRIOT SYLLABLE JA
+10808 ; Cypriot # Lo CYPRIOT SYLLABLE JO
+1080A..10835 ; Cypriot # Lo [44] CYPRIOT SYLLABLE KA..CYPRIOT SYLLABLE WO
+10837..10838 ; Cypriot # Lo [2] CYPRIOT SYLLABLE XA..CYPRIOT SYLLABLE XE
+1083C ; Cypriot # Lo CYPRIOT SYLLABLE ZA
+1083F ; Cypriot # Lo CYPRIOT SYLLABLE ZO
+
+# Total code points: 55
+
+# ================================================
+
+2800..28FF ; Braille # So [256] BRAILLE PATTERN BLANK..BRAILLE PATTERN DOTS-12345678
+
+# Total code points: 256
+
+# ================================================
+
+1A00..1A16 ; Buginese # Lo [23] BUGINESE LETTER KA..BUGINESE LETTER HA
+1A17..1A18 ; Buginese # Mn [2] BUGINESE VOWEL SIGN I..BUGINESE VOWEL SIGN U
+1A19..1A1B ; Buginese # Mc [3] BUGINESE VOWEL SIGN E..BUGINESE VOWEL SIGN AE
+1A1E..1A1F ; Buginese # Po [2] BUGINESE PALLAWA..BUGINESE END OF SECTION
+
+# Total code points: 30
+
+# ================================================
+
+03E2..03EF ; Coptic # L& [14] COPTIC CAPITAL LETTER SHEI..COPTIC SMALL LETTER DEI
+2C80..2CE4 ; Coptic # L& [101] COPTIC CAPITAL LETTER ALFA..COPTIC SYMBOL KAI
+2CE5..2CEA ; Coptic # So [6] COPTIC SYMBOL MI RO..COPTIC SYMBOL SHIMA SIMA
+2CF9..2CFC ; Coptic # Po [4] COPTIC OLD NUBIAN FULL STOP..COPTIC OLD NUBIAN VERSE DIVIDER
+2CFD ; Coptic # No COPTIC FRACTION ONE HALF
+2CFE..2CFF ; Coptic # Po [2] COPTIC FULL STOP..COPTIC MORPHOLOGICAL DIVIDER
+
+# Total code points: 128
+
+# ================================================
+
+1980..19A9 ; New_Tai_Lue # Lo [42] NEW TAI LUE LETTER HIGH QA..NEW TAI LUE LETTER LOW XVA
+19B0..19C0 ; New_Tai_Lue # Mc [17] NEW TAI LUE VOWEL SIGN VOWEL SHORTENER..NEW TAI LUE VOWEL SIGN IY
+19C1..19C7 ; New_Tai_Lue # Lo [7] NEW TAI LUE LETTER FINAL V..NEW TAI LUE LETTER FINAL B
+19C8..19C9 ; New_Tai_Lue # Mc [2] NEW TAI LUE TONE MARK-1..NEW TAI LUE TONE MARK-2
+19D0..19D9 ; New_Tai_Lue # Nd [10] NEW TAI LUE DIGIT ZERO..NEW TAI LUE DIGIT NINE
+19DE..19DF ; New_Tai_Lue # Po [2] NEW TAI LUE SIGN LAE..NEW TAI LUE SIGN LAEV
+
+# Total code points: 80
+
+# ================================================
+
+2C00..2C2E ; Glagolitic # L& [47] GLAGOLITIC CAPITAL LETTER AZU..GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
+2C30..2C5E ; Glagolitic # L& [47] GLAGOLITIC SMALL LETTER AZU..GLAGOLITIC SMALL LETTER LATINATE MYSLITE
+
+# Total code points: 94
+
+# ================================================
+
+2D30..2D65 ; Tifinagh # Lo [54] TIFINAGH LETTER YA..TIFINAGH LETTER YAZZ
+2D6F ; Tifinagh # Lm TIFINAGH MODIFIER LETTER LABIALIZATION MARK
+
+# Total code points: 55
+
+# ================================================
+
+A800..A801 ; Syloti_Nagri # Lo [2] SYLOTI NAGRI LETTER A..SYLOTI NAGRI LETTER I
+A802 ; Syloti_Nagri # Mn SYLOTI NAGRI SIGN DVISVARA
+A803..A805 ; Syloti_Nagri # Lo [3] SYLOTI NAGRI LETTER U..SYLOTI NAGRI LETTER O
+A806 ; Syloti_Nagri # Mn SYLOTI NAGRI SIGN HASANTA
+A807..A80A ; Syloti_Nagri # Lo [4] SYLOTI NAGRI LETTER KO..SYLOTI NAGRI LETTER GHO
+A80B ; Syloti_Nagri # Mn SYLOTI NAGRI SIGN ANUSVARA
+A80C..A822 ; Syloti_Nagri # Lo [23] SYLOTI NAGRI LETTER CO..SYLOTI NAGRI LETTER HO
+A823..A824 ; Syloti_Nagri # Mc [2] SYLOTI NAGRI VOWEL SIGN A..SYLOTI NAGRI VOWEL SIGN I
+A825..A826 ; Syloti_Nagri # Mn [2] SYLOTI NAGRI VOWEL SIGN U..SYLOTI NAGRI VOWEL SIGN E
+A827 ; Syloti_Nagri # Mc SYLOTI NAGRI VOWEL SIGN OO
+A828..A82B ; Syloti_Nagri # So [4] SYLOTI NAGRI POETRY MARK-1..SYLOTI NAGRI POETRY MARK-4
+
+# Total code points: 44
+
+# ================================================
+
+103A0..103C3 ; Old_Persian # Lo [36] OLD PERSIAN SIGN A..OLD PERSIAN SIGN HA
+103C8..103CF ; Old_Persian # Lo [8] OLD PERSIAN SIGN AURAMAZDAA..OLD PERSIAN SIGN BUUMISH
+103D0 ; Old_Persian # Po OLD PERSIAN WORD DIVIDER
+103D1..103D5 ; Old_Persian # Nl [5] OLD PERSIAN NUMBER ONE..OLD PERSIAN NUMBER HUNDRED
+
+# Total code points: 50
+
+# ================================================
+
+10A00 ; Kharoshthi # Lo KHAROSHTHI LETTER A
+10A01..10A03 ; Kharoshthi # Mn [3] KHAROSHTHI VOWEL SIGN I..KHAROSHTHI VOWEL SIGN VOCALIC R
+10A05..10A06 ; Kharoshthi # Mn [2] KHAROSHTHI VOWEL SIGN E..KHAROSHTHI VOWEL SIGN O
+10A0C..10A0F ; Kharoshthi # Mn [4] KHAROSHTHI VOWEL LENGTH MARK..KHAROSHTHI SIGN VISARGA
+10A10..10A13 ; Kharoshthi # Lo [4] KHAROSHTHI LETTER KA..KHAROSHTHI LETTER GHA
+10A15..10A17 ; Kharoshthi # Lo [3] KHAROSHTHI LETTER CA..KHAROSHTHI LETTER JA
+10A19..10A33 ; Kharoshthi # Lo [27] KHAROSHTHI LETTER NYA..KHAROSHTHI LETTER TTTHA
+10A38..10A3A ; Kharoshthi # Mn [3] KHAROSHTHI SIGN BAR ABOVE..KHAROSHTHI SIGN DOT BELOW
+10A3F ; Kharoshthi # Mn KHAROSHTHI VIRAMA
+10A40..10A47 ; Kharoshthi # No [8] KHAROSHTHI DIGIT ONE..KHAROSHTHI NUMBER ONE THOUSAND
+10A50..10A58 ; Kharoshthi # Po [9] KHAROSHTHI PUNCTUATION DOT..KHAROSHTHI PUNCTUATION LINES
+
+# Total code points: 65
+
+# ================================================
+
+1B00..1B03 ; Balinese # Mn [4] BALINESE SIGN ULU RICEM..BALINESE SIGN SURANG
+1B04 ; Balinese # Mc BALINESE SIGN BISAH
+1B05..1B33 ; Balinese # Lo [47] BALINESE LETTER AKARA..BALINESE LETTER HA
+1B34 ; Balinese # Mn BALINESE SIGN REREKAN
+1B35 ; Balinese # Mc BALINESE VOWEL SIGN TEDUNG
+1B36..1B3A ; Balinese # Mn [5] BALINESE VOWEL SIGN ULU..BALINESE VOWEL SIGN RA REPA
+1B3B ; Balinese # Mc BALINESE VOWEL SIGN RA REPA TEDUNG
+1B3C ; Balinese # Mn BALINESE VOWEL SIGN LA LENGA
+1B3D..1B41 ; Balinese # Mc [5] BALINESE VOWEL SIGN LA LENGA TEDUNG..BALINESE VOWEL SIGN TALING REPA TEDUNG
+1B42 ; Balinese # Mn BALINESE VOWEL SIGN PEPET
+1B43..1B44 ; Balinese # Mc [2] BALINESE VOWEL SIGN PEPET TEDUNG..BALINESE ADEG ADEG
+1B45..1B4B ; Balinese # Lo [7] BALINESE LETTER KAF SASAK..BALINESE LETTER ASYURA SASAK
+1B50..1B59 ; Balinese # Nd [10] BALINESE DIGIT ZERO..BALINESE DIGIT NINE
+1B5A..1B60 ; Balinese # Po [7] BALINESE PANTI..BALINESE PAMENENG
+1B61..1B6A ; Balinese # So [10] BALINESE MUSICAL SYMBOL DONG..BALINESE MUSICAL SYMBOL DANG GEDE
+1B6B..1B73 ; Balinese # Mn [9] BALINESE MUSICAL SYMBOL COMBINING TEGEH..BALINESE MUSICAL SYMBOL COMBINING GONG
+1B74..1B7C ; Balinese # So [9] BALINESE MUSICAL SYMBOL RIGHT-HAND OPEN DUG..BALINESE MUSICAL SYMBOL LEFT-HAND OPEN PING
+
+# Total code points: 121
+
+# ================================================
+
+12000..1236E ; Cuneiform # Lo [879] CUNEIFORM SIGN A..CUNEIFORM SIGN ZUM
+12400..12462 ; Cuneiform # Nl [99] CUNEIFORM NUMERIC SIGN TWO ASH..CUNEIFORM NUMERIC SIGN OLD ASSYRIAN ONE QUARTER
+12470..12473 ; Cuneiform # Po [4] CUNEIFORM PUNCTUATION SIGN OLD ASSYRIAN WORD DIVIDER..CUNEIFORM PUNCTUATION SIGN DIAGONAL TRICOLON
+
+# Total code points: 982
+
+# ================================================
+
+10900..10915 ; Phoenician # Lo [22] PHOENICIAN LETTER ALF..PHOENICIAN LETTER TAU
+10916..10919 ; Phoenician # No [4] PHOENICIAN NUMBER ONE..PHOENICIAN NUMBER ONE HUNDRED
+1091F ; Phoenician # Po PHOENICIAN WORD SEPARATOR
+
+# Total code points: 27
+
+# ================================================
+
+A840..A873 ; Phags_Pa # Lo [52] PHAGS-PA LETTER KA..PHAGS-PA LETTER CANDRABINDU
+A874..A877 ; Phags_Pa # Po [4] PHAGS-PA SINGLE HEAD MARK..PHAGS-PA MARK DOUBLE SHAD
+
+# Total code points: 56
+
+# ================================================
+
+07C0..07C9 ; Nko # Nd [10] NKO DIGIT ZERO..NKO DIGIT NINE
+07CA..07EA ; Nko # Lo [33] NKO LETTER A..NKO LETTER JONA RA
+07EB..07F3 ; Nko # Mn [9] NKO COMBINING SHORT HIGH TONE..NKO COMBINING DOUBLE DOT ABOVE
+07F4..07F5 ; Nko # Lm [2] NKO HIGH TONE APOSTROPHE..NKO LOW TONE APOSTROPHE
+07F6 ; Nko # So NKO SYMBOL OO DENNEN
+07F7..07F9 ; Nko # Po [3] NKO SYMBOL GBAKURUNEN..NKO EXCLAMATION MARK
+07FA ; Nko # Lm NKO LAJANYALAN
+
+# Total code points: 59
+
+# ================================================
+
+1B80..1B81 ; Sundanese # Mn [2] SUNDANESE SIGN PANYECEK..SUNDANESE SIGN PANGLAYAR
+1B82 ; Sundanese # Mc SUNDANESE SIGN PANGWISAD
+1B83..1BA0 ; Sundanese # Lo [30] SUNDANESE LETTER A..SUNDANESE LETTER HA
+1BA1 ; Sundanese # Mc SUNDANESE CONSONANT SIGN PAMINGKAL
+1BA2..1BA5 ; Sundanese # Mn [4] SUNDANESE CONSONANT SIGN PANYAKRA..SUNDANESE VOWEL SIGN PANYUKU
+1BA6..1BA7 ; Sundanese # Mc [2] SUNDANESE VOWEL SIGN PANAELAENG..SUNDANESE VOWEL SIGN PANOLONG
+1BA8..1BA9 ; Sundanese # Mn [2] SUNDANESE VOWEL SIGN PAMEPET..SUNDANESE VOWEL SIGN PANEULEUNG
+1BAA ; Sundanese # Mc SUNDANESE SIGN PAMAAEH
+1BAE..1BAF ; Sundanese # Lo [2] SUNDANESE LETTER KHA..SUNDANESE LETTER SYA
+1BB0..1BB9 ; Sundanese # Nd [10] SUNDANESE DIGIT ZERO..SUNDANESE DIGIT NINE
+
+# Total code points: 55
+
+# ================================================
+
+1C00..1C23 ; Lepcha # Lo [36] LEPCHA LETTER KA..LEPCHA LETTER A
+1C24..1C2B ; Lepcha # Mc [8] LEPCHA SUBJOINED LETTER YA..LEPCHA VOWEL SIGN UU
+1C2C..1C33 ; Lepcha # Mn [8] LEPCHA VOWEL SIGN E..LEPCHA CONSONANT SIGN T
+1C34..1C35 ; Lepcha # Mc [2] LEPCHA CONSONANT SIGN NYIN-DO..LEPCHA CONSONANT SIGN KANG
+1C36..1C37 ; Lepcha # Mn [2] LEPCHA SIGN RAN..LEPCHA SIGN NUKTA
+1C3B..1C3F ; Lepcha # Po [5] LEPCHA PUNCTUATION TA-ROL..LEPCHA PUNCTUATION TSHOOK
+1C40..1C49 ; Lepcha # Nd [10] LEPCHA DIGIT ZERO..LEPCHA DIGIT NINE
+1C4D..1C4F ; Lepcha # Lo [3] LEPCHA LETTER TTA..LEPCHA LETTER DDA
+
+# Total code points: 74
+
+# ================================================
+
+1C50..1C59 ; Ol_Chiki # Nd [10] OL CHIKI DIGIT ZERO..OL CHIKI DIGIT NINE
+1C5A..1C77 ; Ol_Chiki # Lo [30] OL CHIKI LETTER LA..OL CHIKI LETTER OH
+1C78..1C7D ; Ol_Chiki # Lm [6] OL CHIKI MU TTUDDAG..OL CHIKI AHAD
+1C7E..1C7F ; Ol_Chiki # Po [2] OL CHIKI PUNCTUATION MUCAAD..OL CHIKI PUNCTUATION DOUBLE MUCAAD
+
+# Total code points: 48
+
+# ================================================
+
+A500..A60B ; Vai # Lo [268] VAI SYLLABLE EE..VAI SYLLABLE NG
+A60C ; Vai # Lm VAI SYLLABLE LENGTHENER
+A60D..A60F ; Vai # Po [3] VAI COMMA..VAI QUESTION MARK
+A610..A61F ; Vai # Lo [16] VAI SYLLABLE NDOLE FA..VAI SYMBOL JONG
+A620..A629 ; Vai # Nd [10] VAI DIGIT ZERO..VAI DIGIT NINE
+A62A..A62B ; Vai # Lo [2] VAI SYLLABLE NDOLE MA..VAI SYLLABLE NDOLE DO
+
+# Total code points: 300
+
+# ================================================
+
+A880..A881 ; Saurashtra # Mc [2] SAURASHTRA SIGN ANUSVARA..SAURASHTRA SIGN VISARGA
+A882..A8B3 ; Saurashtra # Lo [50] SAURASHTRA LETTER A..SAURASHTRA LETTER LLA
+A8B4..A8C3 ; Saurashtra # Mc [16] SAURASHTRA CONSONANT SIGN HAARU..SAURASHTRA VOWEL SIGN AU
+A8C4 ; Saurashtra # Mn SAURASHTRA SIGN VIRAMA
+A8CE..A8CF ; Saurashtra # Po [2] SAURASHTRA DANDA..SAURASHTRA DOUBLE DANDA
+A8D0..A8D9 ; Saurashtra # Nd [10] SAURASHTRA DIGIT ZERO..SAURASHTRA DIGIT NINE
+
+# Total code points: 81
+
+# ================================================
+
+A900..A909 ; Kayah_Li # Nd [10] KAYAH LI DIGIT ZERO..KAYAH LI DIGIT NINE
+A90A..A925 ; Kayah_Li # Lo [28] KAYAH LI LETTER KA..KAYAH LI LETTER OO
+A926..A92D ; Kayah_Li # Mn [8] KAYAH LI VOWEL UE..KAYAH LI TONE CALYA PLOPHU
+A92E..A92F ; Kayah_Li # Po [2] KAYAH LI SIGN CWI..KAYAH LI SIGN SHYA
+
+# Total code points: 48
+
+# ================================================
+
+A930..A946 ; Rejang # Lo [23] REJANG LETTER KA..REJANG LETTER A
+A947..A951 ; Rejang # Mn [11] REJANG VOWEL SIGN I..REJANG CONSONANT SIGN R
+A952..A953 ; Rejang # Mc [2] REJANG CONSONANT SIGN H..REJANG VIRAMA
+A95F ; Rejang # Po REJANG SECTION MARK
+
+# Total code points: 37
+
+# ================================================
+
+10280..1029C ; Lycian # Lo [29] LYCIAN LETTER A..LYCIAN LETTER X
+
+# Total code points: 29
+
+# ================================================
+
+102A0..102D0 ; Carian # Lo [49] CARIAN LETTER A..CARIAN LETTER UUU3
+
+# Total code points: 49
+
+# ================================================
+
+10920..10939 ; Lydian # Lo [26] LYDIAN LETTER A..LYDIAN LETTER C
+1093F ; Lydian # Po LYDIAN TRIANGULAR MARK
+
+# Total code points: 27
+
+# ================================================
+
+AA00..AA28 ; Cham # Lo [41] CHAM LETTER A..CHAM LETTER HA
+AA29..AA2E ; Cham # Mn [6] CHAM VOWEL SIGN AA..CHAM VOWEL SIGN OE
+AA2F..AA30 ; Cham # Mc [2] CHAM VOWEL SIGN O..CHAM VOWEL SIGN AI
+AA31..AA32 ; Cham # Mn [2] CHAM VOWEL SIGN AU..CHAM VOWEL SIGN UE
+AA33..AA34 ; Cham # Mc [2] CHAM CONSONANT SIGN YA..CHAM CONSONANT SIGN RA
+AA35..AA36 ; Cham # Mn [2] CHAM CONSONANT SIGN LA..CHAM CONSONANT SIGN WA
+AA40..AA42 ; Cham # Lo [3] CHAM LETTER FINAL K..CHAM LETTER FINAL NG
+AA43 ; Cham # Mn CHAM CONSONANT SIGN FINAL NG
+AA44..AA4B ; Cham # Lo [8] CHAM LETTER FINAL CH..CHAM LETTER FINAL SS
+AA4C ; Cham # Mn CHAM CONSONANT SIGN FINAL M
+AA4D ; Cham # Mc CHAM CONSONANT SIGN FINAL H
+AA50..AA59 ; Cham # Nd [10] CHAM DIGIT ZERO..CHAM DIGIT NINE
+AA5C..AA5F ; Cham # Po [4] CHAM PUNCTUATION SPIRAL..CHAM PUNCTUATION TRIPLE DANDA
+
+# Total code points: 83
+
+# EOF
--- /dev/null
+Daniel Ehrenberg\r
--- /dev/null
+USING: help.syntax help.markup ;\r
+IN: unicode.script\r
+\r
+HELP: script-of\r
+{ $values { "char" "a code point" } { "script" "a symbol" } }\r
+{ $description "Gets a symbol representing the code point of a given character. The word name of the symbol is the same as the one " } ;\r
+\r
+ABOUT: script-of\r
--- /dev/null
+USING: unicode.script tools.test ;\r
+\r
+[ Latin ] [ CHAR: a script-of ] unit-test\r
+[ Common ] [ 0 script-of ] unit-test\r
--- /dev/null
+USING: unicode.syntax.backend kernel sequences assocs io.files
+io.encodings ascii math.ranges io splitting math.parser
+namespaces byte-arrays locals math sets io.encodings.ascii
+words compiler.units arrays interval-maps ;
+IN: unicode.script
+
+<PRIVATE
+VALUE: script-table
+SYMBOL: interned
+
+: parse-script ( stream -- assoc )
+ ! assoc is code point/range => name
+ lines [ "#" split1 drop ] map [ empty? not ] filter [
+ ";" split1 [ [ blank? ] trim ] bi@
+ ] H{ } map>assoc ;
+
+: range, ( value key -- )
+ swap interned get
+ [ word-name = ] with find nip 2array , ;
+
+: expand-ranges ( assoc -- interval-map )
+ [
+ [
+ CHAR: . pick member? [
+ swap ".." split1 [ hex> ] bi@ 2array
+ ] [ swap hex> ] if range,
+ ] assoc-each
+ ] { } make <interval-map> ;
+
+: >symbols ( strings -- symbols )
+ [
+ [ "unicode.script" create dup define-symbol ] map
+ ] with-compilation-unit ;
+
+: process-script ( ranges -- )
+ dup values prune >symbols interned [
+ expand-ranges \ script-table set-value
+ ] with-variable ;
+
+: load-script ( -- )
+ "resource:extra/unicode/script/Scripts.txt"
+ ascii <file-reader> parse-script process-script ;
+
+load-script
+PRIVATE>
+
+SYMBOL: Unknown
+
+: script-of ( char -- script )
+ script-table interval-at [ Unknown ] unless* ;
--- /dev/null
+Reads the UCD to get the script of a code point\r
--- /dev/null
+USING: kernel parser sequences words ;
+IN: unicode.syntax.backend
+
+: VALUE:
+ CREATE-WORD { f } clone [ first ] curry define ; parsing
+
+: set-value ( value word -- )
+ word-def first set-first ;
: SO_SNDTIMEO HEX: 1005 ; inline
: SO_RCVTIMEO HEX: 1006 ; inline
+: F_SETFD 2 ; inline
: F_SETFL 4 ; inline
+: FD_CLOEXEC 1 ; inline
: O_NONBLOCK 4 ; inline
C-STRUCT: sockaddr-in
: SO_SNDTIMEO HEX: 15 ; inline
: SO_RCVTIMEO HEX: 14 ; inline
+: F_SETFD 2 ; inline
+: FD_CLOEXEC 1 ; inline
+
: F_SETFL 4 ; inline
: O_NONBLOCK HEX: 800 ; inline
--- /dev/null
+
+USING: namespaces io.files bootstrap.image builder.util ;
+
+IN: update.backup
+
+: backup-boot-image ( -- )
+ my-boot-image-name
+ { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string
+ move-file ;
+
+: backup-image ( -- )
+ "factor.image"
+ { "factor" "-" [ "datestamp" get ] ".image" } to-string
+ move-file ;
+
+: backup-vm ( -- )
+ "factor"
+ { "factor" "-" [ "datestamp" get ] } to-string
+ move-file ;
+
+: backup ( -- )
+ datestamp "datestamp" set
+ backup-boot-image
+ backup-image
+ backup-vm ;
--- /dev/null
+
+USING: kernel namespaces system io.files bootstrap.image http.client
+ builder.util update update.backup ;
+
+IN: update.latest
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-master ( -- )
+ image parent-directory
+ [
+ { "git" "pull" "git://factorcode.org/git/factor.git" "master" }
+ run-command
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-latest-image ( -- url )
+ { "http://factorcode.org/images/latest/" my-boot-image-name } to-string ;
+
+: download-latest-image ( -- ) remote-latest-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild-latest ( -- )
+ image parent-directory
+ [
+ backup
+ download-latest-image
+ make-clean
+ make
+ boot
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-latest ( -- )
+ image parent-directory
+ [
+ git-id
+ git-pull-master
+ git-id
+ = not
+ [ rebuild-latest ]
+ when
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update-latest
\ No newline at end of file
USING: math kernel accessors http.server http.server.actions
-http.server.sessions http.server.templating.fhtml locals ;
+http.server.sessions http.server.templating
+http.server.templating.fhtml locals ;
IN: webapps.counter
SYMBOL: count
"" f <standard-redirect>
] >>display ;
+: counter-template ( -- template )
+ "resource:extra/webapps/counter/counter.fhtml" <fhtml> ;
+
: <display-action> ( -- action )
- <action> [
- "text/html" <content>
- "resource:extra/webapps/counter/counter.fhtml" <fhtml> >>body
- ] >>display ;
+ <action> [ counter-template serve-template ] >>display ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
--- /dev/null
+body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+}
+
+.link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+}
+
+a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+}
+
+a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+}
+
+.error { color: #a00; }
+
+.field-label {
+ text-align: right;
+}
+
+.inline {
+ display: inline;
+}
+
+.navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+}
+
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+ padding: 5px;
+ color: #000;
+}
+
+.description p:first-child {
+ margin-top: 0px;
+}
+
+.description p:last-child {
+ margin-bottom: 0px;
+}
<t:style t:include="resource:extra/xmode/code2html/stylesheet.css" />
- <t:style>
- body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
- }
-
- .link-button {
- padding: 0px;
- background: none;
- border: none;
- }
-
- a, .link {
- color: #222;
- border-bottom:1px dotted #666;
- text-decoration:none;
- }
-
- a:hover, .link:hover {
- border-bottom:1px solid #66a;
- }
-
- .error { color: #a00; }
-
- .field-label {
- text-align: right;
- }
-
- .inline {
- display: inline;
- }
-
- .navbar {
- background-color: #eee;
- padding: 5px;
- border: 1px solid #ccc;
- }
-
- .big-field-label {
- vertical-align: top;
- }
-
- .description {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
- padding: 5px;
- font-size: 150%;
- color: #000000;
- }
- </t:style>
+ <t:style t:include="resource:extra/webapps/factor-website/page.css" />
<t:write-style />
</head>
<tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
</table>
- <div class="description">
- <t:view t:component="contents" />
- </div>
+ <pre class="description"><t:view t:component="contents" /></pre>
- <t:form t:action="$pastebin/delete-annotation" class="inline">
- <t:edit t:component="id" />
- <t:edit t:component="aid" />
- <button class="link-button link">Delete Annotation</button>
- </t:form>
+ <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
</t:chloe>
<t:title>New Annotation</t:title>
- <t:form t:action="$pastebin/annotate">
- <t:edit t:component="id" />
+ <t:form t:action="$pastebin/annotate" t:for="id">
<table>
<tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<tr>
- <td><t:a t:href="view-paste" query="id"><t:view t:component="summary" /></t:a></td>
+ <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
<td><t:view t:component="author" /></td>
<td><t:view t:component="date" /></td>
</tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Pastebin</t:title>
-
- <h2>Paste: <t:view t:component="summary" /></h2>
+ <t:title>Paste: <t:view t:component="summary" /></t:title>
<table>
<tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
<pre class="description"><t:view t:component="contents" /></pre>
- <t:form t:action="$pastebin/delete-paste" class="inline">
- <t:edit t:component="id" />
- <button class="link-button link">Delete Paste</button>
- </t:form>
+ <t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
|
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
http.server.components
http.server.components.code
http.server.templating.chloe
+http.server.auth
http.server.auth.login
http.server.boilerplate
http.server.validators
:: <delete-annotation-action> ( ctor next -- action )
<action>
- { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
+ { { "aid" [ v-number ] } } >>post-params
[
- "id" get "aid" get ctor call delete-tuples
-
- "id" get next <id-redirect>
+ f "aid" get ctor call select-tuple
+ [ delete-tuples ] [ id>> next <id-redirect> ] bi
] >>submit ;
:: <new-paste-action> ( form ctor next -- action )
TUPLE: pastebin < dispatcher ;
+SYMBOL: can-delete-pastes?
+
+can-delete-pastes? define-capability
+
: <pastebin> ( -- responder )
pastebin new-dispatcher
<paste-list-action> "list" add-main-responder
<feed-action> "feed.xml" add-responder
<paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
-
[ <paste> ] "$pastebin/list" <delete-paste-action> <protected> "delete-paste" add-responder
-
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> <protected> "delete-annotation" add-responder
+
[ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+
[ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
<new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
<new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
- <t:if t:var="http.server.auth:logged-in-user">
+ <t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</t:if>
<t:title>Edit Blog</t:title>
- <t:form t:action="$planet-factor/admin/edit-blog">
-
- <t:edit t:component="id" />
+ <t:form t:action="$planet-factor/admin/edit-blog" t:for="id">
<table>
</t:form>
- <t:form t:action="$planet-factor/admin/delete-blog" class="inline">
- <t:edit t:component="id" />
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
http.server.boilerplate
http.server.templating.chloe
http.server.components
-http.server.auth.login ;
+http.server.auth.login
+http.server.auth ;
IN: webapps.planet
TUPLE: planet-factor < dispatcher postings ;
blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
] ;
+SYMBOL: can-administer-planet-factor?
+
+can-administer-planet-factor? define-capability
+
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
dup <planet-action> "list" add-main-responder
dup <feed-action> "feed.xml" add-responder
- dup <planet-factor-admin> <protected> "admin" add-responder
+ dup <planet-factor-admin>
{ can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
"planet" planet-template >>template ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<t:comment>
- <t:atom title="Planet Factor - Atom" href="$planet/feed.xml" />
-</t:comment>
- <t:style include="resource:extra/webapps/planet/planet.css" />
+ <t:style t:include="resource:extra/webapps/planet/planet.css" />
<div class="navbar">
<t:a t:href="$planet-factor/list">Front Page</t:a>
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:var="http.server.auth:logged-in-user">
+ <t:if t:code="http.server.sessions:uid">
<t:if t:code="http.server.auth.login:allow-edit-profile?">
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
<t:title>Edit Item</t:title>
- <t:form action="$todo-list/edit">
- <t:edit component="id" />
-
+ <t:form t:action="$todo-list/edit" t:for="id">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="description" /></td></tr>
</table>
<input type="SUBMIT" value="Done" />
</t:form>
- <t:a href="$todo-list/view" query="id">View</t:a>
- |
- <t:form action="$todo-list/delete" class="inline">
- <t:edit component="id" />
- <button type="submit" class="link-button link">Delete</button>
- </t:form>
+ <t:if t:value="id">
+
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ |
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
+
+ </t:if>
</t:chloe>
ctor "$todo-list/list" <delete-action> "delete" add-responder
<boilerplate>
"todo" todo-template >>template
- <protected>
] ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style include="resource:extra/webapps/todo/todo.css" />
+ <t:style t:include="resource:extra/webapps/todo/todo.css" />
<div class="navbar">
<t:a t:href="$todo-list/list">List Items</t:a>
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:form t:action="$login/logout" t:flow="begin" class="inline">
- | <button type="submit" class="link-button link">Logout</button>
- </t:form>
+ <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:title>View Item</t:title>
<table>
- <tr><th class="field-label">Summary: </th><td><t:view component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:view component="priority" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:view t:component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:view t:component="priority" /></td></tr>
</table>
<div class="description">
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
|
- <t:form t:action="$todo-list/delete" class="inline">
- <t:edit t:component="id" />
- <button class="link-button link">Delete</button>
- </t:form>
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+IN: xml.backend
+
+! A stack of { tag children } pairs
+SYMBOL: xml-stack
--- /dev/null
+USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
+IN: xml.errors.tests
+
+: xml-error-test ( expected-error xml-string -- )
+ [ string>xml ] curry swap [ = ] curry must-fail-with ;
+
+T{ no-entity f 1 10 "nbsp" } "<x> </x>" xml-error-test
+T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
+} "<x></y>" xml-error-test
+T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
+T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
+T{ unopened f 1 5 } "</x>" xml-error-test
+T{ not-yes/no f 1 41 "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
+T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
+} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
+T{ bad-version f 1 28 "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
+T{ notags f 1 0 } "" xml-error-test
+T{ multitags } "<x/><y/>" xml-error-test
+T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f }
+} "<x/><?xml version='1.0'?>" xml-error-test
+T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
+xml-error-test
+T{ pre/post-content f "x" t } "x<y/>" xml-error-test
+T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
+T{ bad-instruction f 1 11 T{ instruction f "xsl" }
+} "<x><?xsl?></x>" xml-error-test
+T{ bad-directive f 1 15 T{ directive f "DOCTYPE" }
+} "<x/><!DOCTYPE>" xml-error-test
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml.data xml.writer kernel generic io prettyprint math
-debugger sequences state-parser ;
+debugger sequences state-parser accessors inspector
+namespaces io.streams.string xml.backend ;
IN: xml.errors
-TUPLE: no-entity thing ;
-: <no-entity> ( string -- error )
- { set-no-entity-thing } no-entity construct-parsing-error ;
-M: no-entity error.
- dup parsing-error.
- "Entity does not exist: &" write no-entity-thing write ";" print ;
+TUPLE: multitags ;
+C: <multitags> multitags
+M: multitags summary ( obj -- str )
+ drop "XML document contains multiple main tags" ;
-TUPLE: xml-string-error string ; ! this should not exist
+TUPLE: pre/post-content string pre? ;
+C: <pre/post-content> pre/post-content
+M: pre/post-content summary ( obj -- str )
+ [
+ "The text string:" print
+ dup string>> .
+ "was used " write
+ pre?>> "before" "after" ? write
+ " the main tag." print
+ ] with-string-writer ;
+
+TUPLE: no-entity < parsing-error thing ;
+: <no-entity> ( string -- error )
+ \ no-entity parsing-error swap >>thing ;
+M: no-entity summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Entity does not exist: &" write thing>> write ";" print
+ ] with-string-writer ;
+
+TUPLE: xml-string-error < parsing-error string ; ! this should not exist
: <xml-string-error> ( string -- xml-string-error )
- { set-xml-string-error-string }
- xml-string-error construct-parsing-error ;
-M: xml-string-error error.
- dup parsing-error.
- xml-string-error-string print ;
-
-TUPLE: mismatched open close ;
+ \ xml-string-error parsing-error swap >>string ;
+M: xml-string-error summary ( obj -- str )
+ [
+ dup call-next-method write
+ string>> print
+ ] with-string-writer ;
+
+TUPLE: mismatched < parsing-error open close ;
: <mismatched>
- { set-mismatched-open set-mismatched-close }
- mismatched construct-parsing-error ;
-M: mismatched error.
- dup parsing-error.
- "Mismatched tags" print
- "Opening tag: <" write dup mismatched-open print-name ">" print
- "Closing tag: </" write mismatched-close print-name ">" print ;
-
-TUPLE: unclosed tags ;
-! <unclosed> is ( -- unclosed ), see presentation.factor
-M: unclosed error.
- "Unclosed tags" print
- "Tags: " print
- unclosed-tags [ " <" write print-name ">" print ] each ;
-
-TUPLE: bad-uri string ;
+ \ mismatched parsing-error swap >>close swap >>open ;
+M: mismatched summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Mismatched tags" print
+ "Opening tag: <" write dup open>> print-name ">" print
+ "Closing tag: </" write close>> print-name ">" print
+ ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+: <unclosed> ( -- unclosed )
+ unclosed parsing-error
+ xml-stack get rest-slice [ first opener-name ] map >>tags ;
+M: unclosed summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Unclosed tags" print
+ "Tags: " print
+ tags>> [ " <" write print-name ">" print ] each
+ ] with-string-writer ;
+
+TUPLE: bad-uri < parsing-error string ;
: <bad-uri> ( string -- bad-uri )
- { set-bad-uri-string } bad-uri construct-parsing-error ;
-M: bad-uri error.
- dup parsing-error.
- "Bad URI:" print bad-uri-string . ;
-
-TUPLE: nonexist-ns name ;
+ \ bad-uri parsing-error swap >>string ;
+M: bad-uri summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Bad URI:" print string>> .
+ ] with-string-writer ;
+
+TUPLE: nonexist-ns < parsing-error name ;
: <nonexist-ns> ( name-string -- nonexist-ns )
- { set-nonexist-ns-name }
- nonexist-ns construct-parsing-error ;
-M: nonexist-ns error.
- dup parsing-error.
- "Namespace " write nonexist-ns-name write " has not been declared" print ;
-
-TUPLE: unopened ; ! this should give which tag was unopened
+ \ nonexist-ns parsing-error swap >>name ;
+M: nonexist-ns summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Namespace " write name>> write " has not been declared" print
+ ] with-string-writer ;
+
+TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
: <unopened> ( -- unopened )
- { } unopened construct-parsing-error ;
-M: unopened error.
- parsing-error.
- "Closed an unopened tag" print ;
-
-TUPLE: not-yes/no text ;
+ \ unopened parsing-error ;
+M: unopened summary ( obj -- str )
+ [
+ call-next-method write
+ "Closed an unopened tag" print
+ ] with-string-writer ;
+
+TUPLE: not-yes/no < parsing-error text ;
: <not-yes/no> ( text -- not-yes/no )
- { set-not-yes/no-text } not-yes/no construct-parsing-error ;
-M: not-yes/no error.
- dup parsing-error.
- "standalone must be either yes or no, not \"" write
- not-yes/no-text write "\"." print ;
-
-TUPLE: extra-attrs attrs ; ! this should actually print the names
+ \ not-yes/no parsing-error swap >>text ;
+M: not-yes/no summary ( obj -- str )
+ [
+ dup call-next-method write
+ "standalone must be either yes or no, not \"" write
+ text>> write "\"." print
+ ] with-string-writer ;
+
+! this should actually print the names
+TUPLE: extra-attrs < parsing-error attrs ;
: <extra-attrs> ( attrs -- extra-attrs )
- { set-extra-attrs-attrs }
- extra-attrs construct-parsing-error ;
-M: extra-attrs error.
- dup parsing-error.
- "Extra attributes included in xml version declaration:" print
- extra-attrs-attrs . ;
-
-TUPLE: bad-version num ;
+ \ extra-attrs parsing-error swap >>attrs ;
+M: extra-attrs summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Extra attributes included in xml version declaration:" print
+ attrs>> .
+ ] with-string-writer ;
+
+TUPLE: bad-version < parsing-error num ;
: <bad-version>
- { set-bad-version-num }
- bad-version construct-parsing-error ;
-M: bad-version error.
- "XML version must be \"1.0\" or \"1.1\". Version here was " write
- bad-version-num . ;
+ \ bad-version parsing-error swap >>num ;
+M: bad-version summary ( obj -- str )
+ [
+ "XML version must be \"1.0\" or \"1.1\". Version here was " write
+ num>> .
+ ] with-string-writer ;
TUPLE: notags ;
C: <notags> notags
-M: notags error.
- drop "XML document lacks a main tag" print ;
-
-TUPLE: multitags ;
-C: <multitags> multitags
-M: multitags error.
- drop "XML document contains multiple main tags" print ;
+M: notags summary ( obj -- str )
+ drop "XML document lacks a main tag" ;
-TUPLE: bad-prolog prolog ;
+TUPLE: bad-prolog < parsing-error prolog ;
: <bad-prolog> ( prolog -- bad-prolog )
- { set-bad-prolog-prolog }
- bad-prolog construct-parsing-error ;
-M: bad-prolog error.
- dup parsing-error.
- "Misplaced XML prolog" print
- bad-prolog-prolog write-prolog nl ;
-
-TUPLE: capitalized-prolog name ;
+ \ bad-prolog parsing-error swap >>prolog ;
+M: bad-prolog summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Misplaced XML prolog" print
+ prolog>> write-prolog nl
+ ] with-string-writer ;
+
+TUPLE: capitalized-prolog < parsing-error name ;
: <capitalized-prolog> ( name -- capitalized-prolog )
- { set-capitalized-prolog-name }
- capitalized-prolog construct-parsing-error ;
-M: capitalized-prolog error.
- dup parsing-error.
- "XML prolog name was partially or totally capitalized, using" print
- "<?" write capitalized-prolog-name write "...?>" write
- " instead of <?xml...?>" print ;
-
-TUPLE: pre/post-content string pre? ;
-C: <pre/post-content> pre/post-content
-M: pre/post-content error.
- "The text string:" print
- dup pre/post-content-string .
- "was used " write
- pre/post-content-pre? "before" "after" ? write
- " the main tag." print ;
-
-TUPLE: versionless-prolog ;
+ \ capitalized-prolog parsing-error swap >>name ;
+M: capitalized-prolog summary ( obj -- str )
+ [
+ dup call-next-method write
+ "XML prolog name was partially or totally capitalized, using" print
+ "<?" write name>> write "...?>" write
+ " instead of <?xml...?>" print
+ ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
: <versionless-prolog> ( -- versionless-prolog )
- { } versionless-prolog construct-parsing-error ;
-M: versionless-prolog error.
- parsing-error.
- "XML prolog lacks a version declaration" print ;
-
-TUPLE: bad-instruction inst ;
+ \ versionless-prolog parsing-error ;
+M: versionless-prolog summary ( obj -- str )
+ [
+ call-next-method write
+ "XML prolog lacks a version declaration" print
+ ] with-string-writer ;
+
+TUPLE: bad-instruction < parsing-error instruction ;
: <bad-instruction> ( instruction -- bad-instruction )
- { set-bad-instruction-inst }
- bad-instruction construct-parsing-error ;
-M: bad-instruction error.
- dup parsing-error.
- "Misplaced processor instruction:" print
- bad-instruction-inst write-item nl ;
-
-TUPLE: bad-directive dir ;
+ \ bad-instruction parsing-error swap >>instruction ;
+M: bad-instruction summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Misplaced processor instruction:" print
+ instruction>> write-item nl
+ ] with-string-writer ;
+
+TUPLE: bad-directive < parsing-error dir ;
: <bad-directive> ( directive -- bad-directive )
- { set-bad-directive-dir }
- bad-directive construct-parsing-error ;
-M: bad-directive error.
- dup parsing-error.
- "Misplaced directive:" print
- bad-directive-dir write-item nl ;
+ \ bad-directive parsing-error swap >>dir ;
+M: bad-directive summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Misplaced directive:" print
+ bad-directive-dir write-item nl
+ ] with-string-writer ;
UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
not-yes/no unclosed mismatched xml-string-error expected no-entity
+++ /dev/null
-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 ;
-
-T{ no-entity T{ parsing-error f 1 10 } "nbsp" } "<x> </x>" xml-error-test
-T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "<x></y>" xml-error-test
-T{ unclosed f V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
-T{ nonexist-ns T{ parsing-error f 1 5 } "x" } "<x:y/>" xml-error-test
-T{ unopened T{ parsing-error f 1 5 } } "</x>" xml-error-test
-T{ not-yes/no T{ parsing-error f 1 41 } "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
-T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
-} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
-T{ bad-version T{ parsing-error f 1 28 } "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
-T{ notags f } "" xml-error-test
-T{ multitags f } "<x/><y/>" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
-} "<x/><?xml version='1.0'?>" xml-error-test
-T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "<?XmL version='1.0'?><x/>"
-xml-error-test
-T{ pre/post-content f "x" t } "x<y/>" xml-error-test
-T{ versionless-prolog T{ parsing-error f 1 8 } } "<?xml?><x/>" xml-error-test
-T{ bad-instruction T{ parsing-error f 1 11 } T{ instruction f "xsl" }
-} "<x><?xsl?></x>" xml-error-test
-T{ bad-directive T{ parsing-error f 1 15 } T{ directive f "DOCTYPE" }
-} "<x/><!DOCTYPE>" xml-error-test
[ assemble-data ] map ;
[ "http://www.foxnews.com/oreilly/" ] [
- "extra/xml/tests/soap.xml" resource-path file>xml
+ "resource:extra/xml/tests/soap.xml" file>xml
parse-result first first
] unit-test
\ read-xml must-infer
SYMBOL: xml-file
-[ ] [ "extra/xml/tests/test.xml" resource-path
+[ ] [ "resource:extra/xml/tests/test.xml"
[ file>xml ] with-html-entities xml-file set ] unit-test
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
\r
HELP: write-xml\r
{ $values { "xml" "an XML document" } }\r
-{ $description "prints the contents of an XML document (" { $link xml } ") to stdio" }\r
+{ $description "prints the contents of an XML document (" { $link xml } ") to " { $link output-stream } "." }\r
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;\r
\r
HELP: print-xml\r
{ $values { "xml" "an XML document" } }\r
-{ $description "prints the contents of an XML document (" { $link xml } ") to stdio, followed by a newline" }\r
+{ $description "prints the contents of an XML document (" { $link xml } ") to " { $link output-stream } ", followed by a newline" }\r
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;\r
\r
HELP: pprint-xml\r
{ $values { "xml" "an XML document" } }\r
-{ $description "prints the contents of an XML document (" { $link xml } ") to stdio in a prettyprinted form." }\r
+{ $description "prints the contents of an XML document (" { $link xml } ") to " { $link output-stream } " in a prettyprinted form." }\r
{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;\r
\r
HELP: pprint-xml-but\r
\r
HELP: <pull-xml>\r
{ $values { "pull-xml" "a pull-xml tuple" } }\r
-{ $description "creates an XML pull-based parser which reads from the " { $link stdio } " stream, executing all initial XML commands to set up the parser." }\r
+{ $description "creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." }\r
{ $see-also pull-xml pull-elem pull-event } ;\r
\r
HELP: pull-elem\r
\r
HELP: write-item\r
{ $values { "object" "an XML element" } }\r
-{ $description "writes an XML element to the " { $link stdio } " stream." }\r
+{ $description "writes an XML element to " { $link output-stream } "." }\r
{ $see-also write-chunk write-xml } ;\r
\r
HELP: write-chunk\r
{ $values { "seq" "an XML document fragment" } }\r
-{ $description "writes an XML document fragment, ie a sequence of XML elements, to the " { $link stdio } " stream." }\r
+{ $description "writes an XML document fragment, ie a sequence of XML elements, to " { $link output-stream } "." }\r
{ $see-also write-item write-xml } ;\r
\r
HELP: deep-tag-named\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 io.encodings.utf8 ;
+xml.utilities state-parser assocs ascii io.encodings.utf8
+accessors xml.backend ;
IN: xml
! -- Overall parser with data tree
-! A stack of { tag children } pairs
-SYMBOL: xml-stack
-
-: <unclosed> ( -- unclosed )
- xml-stack get rest-slice [ first opener-name ] map
- { set-unclosed-tags } unclosed construct ;
-
: add-child ( object -- )
xml-stack get peek second push ;
TUPLE: pull-xml scope ;
: <pull-xml> ( -- pull-xml )
[
- stdio [ ] change ! bring stdio var in this scope
+ input-stream [ ] change ! bring var in this scope
init-parser reset-prolog init-ns-stack
text-now? on
] H{ } make-assoc
] keep ;
: load-catalog ( -- modes )
- "extra/xmode/modes/catalog" resource-path
+ "resource:extra/xmode/modes/catalog"
file>xml parse-modes-tag ;
: modes ( -- assoc )
MEMO: (load-mode) ( name -- rule-sets )
modes at [
mode-file
- "extra/xmode/modes/" prepend
- resource-path utf8 <file-reader> parse-mode
+ "resource:extra/xmode/modes/" prepend
+ utf8 <file-reader> parse-mode
] [
"text" (load-mode)
] if* ;
: default-stylesheet ( -- )
<style>
- "extra/xmode/code2html/stylesheet.css"
- resource-path utf8 file-contents write
+ "resource:extra/xmode/code2html/stylesheet.css"
+ utf8 file-contents write
</style> ;
: htmlize-stream ( path stream -- )
: htmlize-file ( path -- )
dup utf8 [
- stdio get
- over ".html" append utf8 [
- htmlize-stream
+ dup ".html" append utf8 [
+ input-stream get htmlize-stream
] with-file-writer
] with-file-reader ;
[\r
drop\r
"text/html" <content> swap\r
- [ file-http-date "last-modified" set-header ]\r
+ [ "last-modified" set-header ]\r
[\r
'[\r
,\r
"This is a great company"
}
] [
- "extra/xmode/utilities/test.xml"
- resource-path file>xml parse-company-tag
+ "resource:extra/xmode/utilities/test.xml"
+ 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>xml parse-yahoo first ] unit-test
+} ] [ "resource:extra/yahoo/test-results.xml" 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
<key>begin</key>
<string><%\s</string>
<key>end</key>
- <string>\s%></string>
+ <string>(?<=\s)%></string>
<key>name</key>
<string>source.factor.embedded.html</string>
<key>patterns</key>
" Vim syntax file
" Language: factor
" Maintainer: Alex Chapman <chapman.alex@gmail.com>
-" Last Change: 2007 Jan 18
+" Last Change: 2008 Apr 28
" For version 5.x: Clear all syntax items
" For version 6.x: Quit when a syntax file was already loaded
" kernel vocab keywords
-syn keyword factorKeyword or construct-delegate set-slots tuck while wrapper nip hashcode wrapper? both? callstack>array die dupd set-delegate callstack callstack? 3dup pick curry build >boolean ?if clone eq? = ? swapd call-clear 2over 2keep 3keep construct general-t clear 2dup when not tuple? 3compose dup call object wrapped unless* if* 2apply >r curry-quot drop when* retainstack -rot delegate with 3slip construct-boa slip compose-first compose-second 3drop construct-empty either? curry? datastack compare curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if <=> unless compose? tuple keep 2curry object? equal? set-datastack 2slip 2drop most <wrapper> null r> set-callstack dip xor rot -roll
-syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc union search-alist assoc-like key? update at* assoc-empty? at+ set-at assoc-all? assoc-hashcode intersect change-at assoc-each assoc-subset values rename-at value-at (assoc-stack) at cache assoc>map assoc-contains? assoc assoc-map assoc-pusher diff (assoc>map) assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute delete-at assoc-find keys
-syn keyword factorKeyword case dispatch-case-quot with-datastack alist>quot dispatch-case hash-case-table <buckets> hash-case-quot no-cond no-case? cond distribute-buckets (distribute-buckets) contiguous-range? cond>quot no-cond? no-case recursive-hashcode linear-case-quot hash-dispatch-quot case>quot
-syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 before? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? after? fixnum before=? bignum sq neg denominator [-] (all-integers?) times find-last-integer (each-integer) bit? * + - / >= bitand find-integer complex < real > log2 integer? max number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift between? float 1+ 1- min fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator after=? /f
-syn keyword factorKeyword slice-to append left-trim clone-like 3sequence set-column-seq map-as reversed pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* member? unclip virtual-sequence? set-length last-index* <column> drop-prefix bounds-error? set-slice-seq set-column-col seq-diff map start open-slice midpoint@ add* set-immutable-seq move-forward fourth delete set-slice-to all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) column? reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice index* move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right concat find* set-slice-from flip sum find-last* immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice column-seq sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find column remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index seq-intersect push-if 2all? lengthen column-col joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first bounds-error add bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice sum-lengths new 2each head* infimum subset slice-error subseq replace-slice repetition push trim sequence-hashcode mismatch
+syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most <wrapper> identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple
+syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-contains? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys
+syn keyword factorKeyword case dispatch-case-quot with-datastack <buckets> no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot
+syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f
+syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek contains? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch
syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc
syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array?
syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln
syn keyword factorKeyword resize-string >string <string> 1string string string?
syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
-syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name set-restart-continuation ignore-errors continuation-retain continue <continuation> restart-continuation with-disposal set-continuation-catch restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation <condition> set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts
+syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue <continuation> restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation <condition> set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts
syn cluster factorReal contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
%>" Vim syntax file
" Language: factor
" Maintainer: Alex Chapman <chapman.alex@gmail.com>
-" Last Change: 2007 Jan 18
+" Last Change: 2008 Apr 28
" For version 5.x: Clear all syntax items
" For version 6.x: Quit when a syntax file was already loaded
--- /dev/null
+Elie Chaftari
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
+!
+! export LD_LIBRARY_PATH=/opt/local/lib
+
+USING: alien alien.syntax combinators kernel system ;
+
+IN: openssl.libcrypto
+
+<<
+"libcrypto" {
+ { [ os winnt? ] [ "libeay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libcrypto.so" "cdecl" ] }
+} cond add-library
+>>
+
+C-STRUCT: bio-method
+ { "int" "type" }
+ { "void*" "name" }
+ { "void*" "bwrite" }
+ { "void*" "bread" }
+ { "void*" "bputs" }
+ { "void*" "bgets" }
+ { "void*" "ctrl" }
+ { "void*" "create" }
+ { "void*" "destroy" }
+ { "void*" "callback-ctrl" } ;
+
+C-STRUCT: bio
+ { "void*" "method" }
+ { "void*" "callback" }
+ { "void*" "cb-arg" }
+ { "int" "init" }
+ { "int" "shutdown" }
+ { "int" "flags" }
+ { "int" "retry-reason" }
+ { "int" "num" }
+ { "void*" "ptr" }
+ { "void*" "next-bio" }
+ { "void*" "prev-bio" }
+ { "int" "references" }
+ { "ulong" "num-read" }
+ { "ulong" "num-write" }
+ { "void*" "crypto-ex-data-stack" }
+ { "int" "crypto-ex-data-dummy" } ;
+
+: BIO_NOCLOSE HEX: 00 ; inline
+: BIO_CLOSE HEX: 01 ; inline
+
+: RSA_3 HEX: 3 ; inline
+: RSA_F4 HEX: 10001 ; inline
+
+: BIO_C_SET_SSL 109 ; inline
+: BIO_C_GET_SSL 110 ; inline
+
+LIBRARY: libcrypto
+
+! ===============================================
+! bio.h
+! ===============================================
+
+FUNCTION: bio* BIO_new_file ( char* filename, char* mode ) ;
+
+FUNCTION: int BIO_printf ( bio* bio, char* format ) ;
+
+FUNCTION: long BIO_ctrl ( void* bio, int cmd, long larg, void* parg ) ;
+
+FUNCTION: void* BIO_new_socket ( int fd, int close-flag ) ;
+
+FUNCTION: void* BIO_new ( void* method ) ;
+
+FUNCTION: int BIO_set ( void* bio, void* method ) ;
+
+FUNCTION: int BIO_free ( void* bio ) ;
+
+FUNCTION: void* BIO_push ( void* bio, void* append ) ;
+
+FUNCTION: int BIO_read ( void* b, void* buf, int len ) ;
+
+FUNCTION: int BIO_gets ( void* b, char* buf, int size ) ;
+
+FUNCTION: int BIO_write ( void* b, void* buf, int len ) ;
+
+FUNCTION: int BIO_puts ( void* bp, char* buf ) ;
+
+FUNCTION: ulong ERR_get_error ( ) ;
+
+FUNCTION: char* ERR_error_string ( ulong e, void* buf ) ;
+
+FUNCTION: void* BIO_f_buffer ( ) ;
+
+! ===============================================
+! evp.h
+! ===============================================
+
+! Initialize ciphers and digest tables
+FUNCTION: void OpenSSL_add_all_ciphers ( ) ;
+
+FUNCTION: void OpenSSL_add_all_digests ( ) ;
+
+! Clean them up before exiting
+FUNCTION: void EVP_cleanup ( ) ;
+
+FUNCTION: void* EVP_get_digestbyname ( char* name ) ;
+
+FUNCTION: void EVP_MD_CTX_init ( void* ctx ) ;
+
+FUNCTION: void* PEM_read_bio_DHparams ( void* bp, void* x, void* cb,
+ void* u ) ;
+
+! ===============================================
+! md5.h
+! ===============================================
+
+FUNCTION: uchar* MD5 ( uchar* d, ulong n, uchar* md ) ;
+
+! ===============================================
+! rsa.h
+! ===============================================
+
+FUNCTION: void* RSA_generate_key ( int num, ulong e, void* callback,
+ void* cb_arg ) ;
+
+FUNCTION: int RSA_check_key ( void* rsa ) ;
+
+FUNCTION: void RSA_free ( void* rsa ) ;
+
+FUNCTION: int RSA_print_fp ( void* fp, void* x, int offset ) ;
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
+!
+! export LD_LIBRARY_PATH=/opt/local/lib
+
+USING: alien alien.syntax combinators kernel system ;
+
+IN: openssl.libssl
+
+<< "libssl" {
+ { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libssl.so" "cdecl" ] }
+} cond add-library >>
+
+: X509_FILETYPE_PEM 1 ; inline
+: X509_FILETYPE_ASN1 2 ; inline
+: X509_FILETYPE_DEFAULT 3 ; inline
+
+: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
+: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
+
+: SSL_CTRL_NEED_TMP_RSA 1 ; inline
+: SSL_CTRL_SET_TMP_RSA 2 ; inline
+: SSL_CTRL_SET_TMP_DH 3 ; inline
+: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
+: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
+
+: SSL_ERROR_NONE 0 ; inline
+: SSL_ERROR_SSL 1 ; inline
+: SSL_ERROR_WANT_READ 2 ; inline
+: SSL_ERROR_WANT_WRITE 3 ; inline
+: SSL_ERROR_WANT_X509_LOOKUP 4 ; inline
+: SSL_ERROR_SYSCALL 5 ; inline ! consult errno for details
+: SSL_ERROR_ZERO_RETURN 6 ; inline
+: SSL_ERROR_WANT_CONNECT 7 ; inline
+: SSL_ERROR_WANT_ACCEPT 8 ; inline
+
+! Error messages table
+: error-messages ( -- hash )
+ H{
+ { 0 "SSL_ERROR_NONE" }
+ { 1 "SSL_ERROR_SSL" }
+ { 2 "SSL_ERROR_WANT_READ" }
+ { 3 "SSL_ERROR_WANT_WRITE" }
+ { 4 "SSL_ERROR_WANT_X509_LOOKUP" }
+ { 5 "SSL_ERROR_SYSCALL" }
+ { 6 "SSL_ERROR_ZERO_RETURN" }
+ { 7 "SSL_ERROR_WANT_CONNECT" }
+ { 8 "SSL_ERROR_WANT_ACCEPT" }
+ } ;
+
+TYPEDEF: void* ssl-method
+TYPEDEF: void* ssl-ctx
+TYPEDEF: void* ssl-pointer
+
+LIBRARY: libssl
+
+! ===============================================
+! ssl.h
+! ===============================================
+
+FUNCTION: char* SSL_get_version ( ssl-pointer ssl ) ;
+
+! Maps OpenSSL errors to strings
+FUNCTION: void SSL_load_error_strings ( ) ;
+
+! Must be called before any other action takes place
+FUNCTION: int SSL_library_init ( ) ;
+
+! Sets the default SSL version
+FUNCTION: ssl-method SSLv2_client_method ( ) ;
+
+FUNCTION: ssl-method SSLv23_client_method ( ) ;
+
+FUNCTION: ssl-method SSLv23_server_method ( ) ;
+
+FUNCTION: ssl-method SSLv23_method ( ) ; ! SSLv3 but can rollback to v2
+
+FUNCTION: ssl-method SSLv3_client_method ( ) ;
+
+FUNCTION: ssl-method SSLv3_server_method ( ) ;
+
+FUNCTION: ssl-method SSLv3_method ( ) ;
+
+FUNCTION: ssl-method TLSv1_client_method ( ) ;
+
+FUNCTION: ssl-method TLSv1_server_method ( ) ;
+
+FUNCTION: ssl-method TLSv1_method ( ) ;
+
+! Creates the context
+FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ;
+
+! Load the certificates and private keys into the SSL_CTX
+FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx,
+ char* file ) ; ! PEM type
+FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ;
+
+FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ;
+
+FUNCTION: void SSL_set_bio ( ssl-pointer ssl, void* rbio, void* wbio ) ;
+
+FUNCTION: int SSL_get_error ( ssl-pointer ssl, int ret ) ;
+
+FUNCTION: void SSL_set_connect_state ( ssl-pointer ssl ) ;
+
+FUNCTION: void SSL_set_accept_state ( ssl-pointer ssl ) ;
+
+FUNCTION: int SSL_connect ( ssl-pointer ssl ) ;
+
+FUNCTION: int SSL_accept ( ssl-pointer ssl ) ;
+
+FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
+
+FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
+
+FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ;
+
+FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
+
+FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ;
+
+FUNCTION: void RAND_seed ( void* buf, int num ) ;
+
+FUNCTION: int SSL_set_cipher_list ( ssl-pointer ssl, char* str ) ;
+
+FUNCTION: int SSL_use_RSAPrivateKey_file ( ssl-pointer ssl, char* str ) ;
+
+FUNCTION: int SSL_CTX_use_RSAPrivateKey_file ( ssl-ctx ctx, int type ) ;
+
+FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
+ char* str, int type ) ;
+
+FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
+ char* CApath ) ;
+
+FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
+
+FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
+
+! Used to manipulate settings of the SSL_CTX and SSL objects.
+! This function should never be called directly
+FUNCTION: long SSL_CTX_ctrl ( ssl-ctx ctx, int cmd, long larg, void* parg ) ;
+
+FUNCTION: void SSL_CTX_set_default_passwd_cb ( ssl-ctx ctx, void* cb ) ;
+
+FUNCTION: void SSL_CTX_set_default_passwd_cb_userdata ( ssl-ctx ctx,
+ void* u ) ;
+
+FUNCTION: int SSL_CTX_use_PrivateKey_file ( ssl-ctx ctx, char* file,
+ int type ) ;
+
+! Sets the maximum depth for the allowed ctx certificate chain verification
+FUNCTION: void SSL_CTX_set_verify_depth ( ssl-ctx ctx, int depth ) ;
+
+! Sets DH parameters to be used to be dh.
+! The key is inherited by all ssl objects created from ctx
+FUNCTION: void SSL_CTX_set_tmp_dh_callback ( ssl-ctx ctx, void* dh ) ;
+
+FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
+
+FUNCTION: void* BIO_f_ssl ( ) ;
+
+! ===============================================
+! sha.h
+! ===============================================
+
+! For a high level interface to message digests
+! use the EVP digest routines in libcrypto.factor
+
+FUNCTION: uchar* SHA1 ( uchar* d, ulong n, uchar* md ) ;
--- /dev/null
+
+USING: help.syntax help.markup ;
+
+IN: openssl
+
+ARTICLE: "openssl" "OpenSSL"
+
+"Factor on Windows has been tested with this version of OpenSSL: "
+
+{ $url "http://www.openssl.org/related/binaries.html" } ;
\ No newline at end of file
--- /dev/null
+USING: alien alien.c-types alien.strings assocs bit-arrays
+hashtables io io.files io.encodings.ascii io.sockets kernel
+mirrors openssl.libcrypto openssl.libssl namespaces math
+math.parser openssl prettyprint sequences tools.test ;
+
+! =========================================================
+! Some crypto functions (still to be turned into words)
+! =========================================================
+
+[
+ B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
+]
+[ "Hello world from the openssl binding" >md5 ] unit-test
+
+! Not found on netbsd, windows -- why?
+! [
+ ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
+ ! 82 115 0 }
+! ]
+! [ "Hello world from the openssl binding" >sha1 ] unit-test
+
+! =========================================================
+! Initialize context
+! =========================================================
+
+[ ] [ init load-error-strings ] unit-test
+
+[ ] [ ssl-v23 new-ctx ] unit-test
+
+[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test
+
+! TODO: debug 'Memory protection fault at address 6c'
+! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
+
+[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
+
+! Enter PEM pass phrase: password
+[ ] [ get-ctx "resource:extra/openssl/test/server.pem"
+SSL_FILETYPE_PEM use-private-key ] unit-test
+
+[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f
+verify-load-locations ] unit-test
+
+[ ] [ get-ctx 1 set-verify-depth ] unit-test
+
+! =========================================================
+! Load Diffie-Hellman parameters
+! =========================================================
+
+[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test
+
+[ ] [ get-bio f f f read-pem-dh-params ] unit-test
+
+[ ] [ get-bio bio-free ] unit-test
+
+! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
+[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
+
+! Workaround (this function should never be called directly)
+! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
+
+! =========================================================
+! Generate ephemeral RSA key
+! =========================================================
+
+[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
+
+! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
+! get-ctx get-rsa set-tmp-rsa-callback
+
+! Workaround (this function should never be called directly)
+[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
+
+[ ] [ get-rsa free-rsa ] unit-test
+
+! =========================================================
+! Listen and accept on socket
+! =========================================================
+
+! SYMBOL: sock
+! SYMBOL: fdset
+! SYMBOL: acset
+! SYMBOL: sbio
+! SYMBOL: ssl
+!
+! : is-set ( seq -- newseq )
+! <enum> >alist [ nip ] assoc-filter >hashtable keys ;
+!
+! ! 1234 server-socket sock set
+! "127.0.0.1" 1234 <inet4> SOCK_STREAM server-fd sock set
+!
+! FD_SETSIZE 8 * <bit-array> fdset set
+!
+! FD_SETSIZE 8 * <bit-array> t 8 rot [ set-nth ] keep fdset set
+!
+! fdset get is-set .
+
+! : loop ( -- )
+! sock get f f accept
+! dup -1 = [ drop ] [
+! dup number>string print flush
+! ! BIO_NOCLOSE bio-new-socket sbio set
+! [ get-ctx new-ssl ssl set ] keep
+! ssl get swap set-ssl-fd
+! ! ssl get sbio get dup set-ssl-bio
+! ! ssl get ssl-accept
+! ! dup 0 <= [
+! ! ssl get swap ssl-get-error
+! ! ] [ drop ] if
+! ] if
+! loop ;
+
+! { } acset set
+!
+! : loop ( -- )
+! ! FD_SETSIZE fdset get f f f select . flush
+! FD_SETSIZE fdset get f f 10000 make-timeval select
+! 0 <= [ acset get [ close ] each "timeout" print ] [
+! fdset get is-set sock get swap member? [
+! sock get f f accept dup . flush
+! acset get swap add acset set
+! ] [ ] if
+! loop
+! ] if ;
+!
+! loop
+!
+! sock get close
+
+! =========================================================
+! Dump errors to file
+! =========================================================
+
+[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test
+
+[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
+
+[ ] [ get-bio bio-free ] unit-test
+
+! =========================================================
+! Clean-up
+! =========================================================
+
+! sock get close
+
+get-ctx destroy-ctx
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
+
+USING: alien alien.c-types alien.strings assocs kernel libc
+namespaces openssl.libcrypto openssl.libssl sequences
+io.encodings.ascii ;
+
+IN: openssl
+
+SYMBOL: bio
+SYMBOL: ssl-bio
+
+SYMBOL: ctx
+SYMBOL: dh
+SYMBOL: rsa
+
+! =========================================================
+! Callback routines
+! =========================================================
+
+: password-cb ( -- alien )
+ "int" { "char*" "int" "int" "void*" } "cdecl"
+ [ 3drop "password" ascii string>alien 1023 memcpy
+ "password" length ] alien-callback ;
+
+! =========================================================
+! Error-handling routines
+! =========================================================
+
+: get-error ( -- num )
+ ERR_get_error ;
+
+: error-string ( num -- str )
+ f ERR_error_string ;
+
+: check-result ( result -- )
+ 1 = [ ] [
+ get-error error-string throw
+ ] if ;
+
+: ssl-get-error ( ssl ret -- )
+ SSL_get_error error-messages at throw ;
+
+! Write errors to a file
+: bio-new-file ( path mode -- )
+ BIO_new_file bio set ;
+
+: bio-print ( bio str -- n )
+ BIO_printf ;
+
+: bio-free ( bio -- )
+ BIO_free check-result ;
+
+! =========================================================
+! Initialization routines
+! =========================================================
+
+: init ( -- )
+ SSL_library_init drop ; ! always returns 1
+
+: load-error-strings ( -- )
+ SSL_load_error_strings ;
+
+: ssl-v23 ( -- method )
+ SSLv23_method ;
+
+: new-ctx ( method -- )
+ SSL_CTX_new ctx set ;
+
+: use-cert-chain ( ctx file -- )
+ SSL_CTX_use_certificate_chain_file check-result ;
+
+: set-default-passwd ( ctx cb -- )
+ SSL_CTX_set_default_passwd_cb ;
+
+: set-default-passwd-userdata ( ctx passwd -- )
+ SSL_CTX_set_default_passwd_cb_userdata ;
+
+: use-private-key ( ctx file type -- )
+ SSL_CTX_use_PrivateKey_file check-result ;
+
+: verify-load-locations ( ctx file path -- )
+ SSL_CTX_load_verify_locations check-result ;
+
+: set-verify-depth ( ctx depth -- )
+ SSL_CTX_set_verify_depth ;
+
+: read-pem-dh-params ( bio x cb u -- )
+ PEM_read_bio_DHparams dh set ;
+
+: set-tmp-dh-callback ( ctx dh -- )
+ SSL_CTX_set_tmp_dh_callback ;
+
+: set-ctx-ctrl ( ctx cmd larg parg -- )
+ SSL_CTX_ctrl check-result ;
+
+: generate-rsa-key ( n e cb cbarg -- )
+ RSA_generate_key rsa set ;
+
+: set-tmp-rsa-callback ( ctx rsa -- )
+ SSL_CTX_set_tmp_rsa_callback ;
+
+: free-rsa ( rsa -- )
+ RSA_free ;
+
+: bio-new-socket ( fd flag -- sbio )
+ BIO_new_socket ;
+
+: new-ssl ( ctx -- ssl )
+ SSL_new ;
+
+: set-ssl-bio ( ssl bio bio -- )
+ SSL_set_bio ;
+
+: set-ssl-fd ( ssl fd -- )
+ SSL_set_fd check-result ;
+
+: ssl-accept ( ssl -- result )
+ SSL_accept ;
+
+! =========================================================
+! Clean-up and termination routines
+! =========================================================
+
+: destroy-ctx ( ctx -- )
+ SSL_CTX_free ;
+
+! =========================================================
+! Public routines
+! =========================================================
+
+: get-bio ( -- bio )
+ bio get ;
+
+: get-ssl-bio ( -- bio )
+ ssl-bio get ;
+
+: get-ctx ( -- ctx )
+ ctx get ;
+
+: get-dh ( -- dh )
+ dh get ;
+
+: get-rsa ( -- rsa )
+ rsa get ;
+
+: >md5 ( str -- byte-array )
+ dup length 16 "uchar" <c-array> [ MD5 ] keep nip ;
+
+: >sha1 ( str -- byte-array )
+ dup length 20 "uchar" <c-array> [ SHA1 ] keep nip ;
+
--- /dev/null
+OpenSSL binding
--- /dev/null
+enterprise
+network
+bindings
--- /dev/null
+-----BEGIN DH PARAMETERS-----
+MIGHAoGBANmAnfkETuKHOCWaE+W+F3kM/e7z5A8hZb7OqwGMQrUOaBEAr4BWeZBn
+G/87hhwZgNP69/KUchm714qd/PpOspCaUJ20x6PcmKujpAgca/f19HGMBjRawQMk
+R9oaBwazuQT0l0rTTKmvpMEcrQQIcVWii3CZI56I56oqF8biGPD7AgEC
+-----END DH PARAMETERS-----
--- /dev/null
+-----BEGIN CERTIFICATE-----
+MIICIjCCAYugAwIBAgIBADANBgkqhkiG9w0BAQQFADBXMQswCQYDVQQGEwJVUzET
+MBEGA1UEChMKUlRGTSwgSW5jLjEZMBcGA1UECxMQV2lkZ2V0cyBEaXZpc2lvbjEY
+MBYGA1UEAxMPVGVzdCBDQTIwMDEwNTE3MB4XDTAxMDUxNzE2MDExNFoXDTA2MTIy
+NTE2MDExNFowVzELMAkGA1UEBhMCVVMxEzARBgNVBAoTClJURk0sIEluYy4xGTAX
+BgNVBAsTEFdpZGdldHMgRGl2aXNpb24xGDAWBgNVBAMTD1Rlc3QgQ0EyMDAxMDUx
+NzCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEAmkX40warmH0+lnwD9YjsJhRz
+ZX6qXadFry0y2trZ6gMs8Mv33IKPwOu8TE7V+3PESEtjI2wr8juV9OkbIPOm+td5
+M8+6vXyIW+JBo3ch99i0QMTf5/jTgsW+3IjV8yEdiGcZFp2NWKLRvZPq2VRbuF7R
+1pvgcaRuBJ0wGOohwnsCAwEAATANBgkqhkiG9w0BAQQFAAOBgQCUB8zMKIlX5io8
+TalbzH9Qke7BcvFAL+wp/5w1ToVsWkNrINSWKv6bl/jcqOD3aPhK7qhaeOU8ZWKL
+PoPPCnRl9Wo+1JtsOO3qIgJP79Bl9ooLGahixF2v/gea5qNISjQvwYllLSa//APP
+6kXHngO0RIRbiTBYHSkAzm6hDdsvVA==
+-----END CERTIFICATE-----
--- /dev/null
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: DES-EDE3-CBC,5772A2A7BE34B611
+
+1yJ+xAn4MudcIfXXy7ElYngJ9EohIh8yvcyVLmE4kVd0xeaL/Bqhvk25BjYCK5d9
+k1K8cjgnKEBjbC++0xtJxFSbUhwoKTLwn+sBoJDcFzMKkmJXXDbSTOaNr1sVwiAR
+SnB4lhUcHguYoV5zlRJn53ft7t1mjB6RwGH+d1Zx6t95OqM1lnKqwekwmotVAWHj
+ncu3N8qhmoPMppmzEv0fOo2/pK2WohcJykSeN5zBrZCUxoO0NBNEZkFUcVjR+KsA
+1ZeI1mU60szqg+AoU/XtFcow8RtG1QZKQbbXzyfbwaG+6LqkHaWYKHQEI1546yWK
+us1HJ734uUkZoyyyazG6PiGCYV2u/aY0i3qdmyDqTvmVIvve7E4glBrtDS9h7D40
+nPShIvOatoPzIK4Y0QSvrI3G1vTsIZT3IOZto4AWuOkLNfYS2ce7prOreF0KjhV0
+3tggw9pHdDmTjHTiIkXqheZxZ7TVu+pddZW+CuB62I8lCBGPW7os1f21e3eOD/oY
+YPCI44aJvgP+zUORuZBWqaSJ0AAIuVW9S83Yzkz/tlSFHViOebyd8Cug4TlxK1VI
+q6hbSafh4C8ma7YzlvqjMzqFifcIolcbx+1A6ot0UiayJTUra4d6Uc4Rbc9RIiG0
+jfDWC6aii9YkAgRl9WqSd31yASge/HDqVXFwR48qdlYQ57rcHviqxyrwRDnfw/lX
+Mf6LPiDKEco4MKej7SR2kK2c2AgxUzpGZeAY6ePyhxbdhA0eY21nDeFd/RbwSc5s
+eTiCCMr41OB4hfBFXKDKqsM3K7klhoz6D5WsgE6u3lDoTdz76xOSTg==
+-----END RSA PRIVATE KEY-----
+-----BEGIN CERTIFICATE-----
+MIICGDCCAYECAgEBMA0GCSqGSIb3DQEBBAUAMFcxCzAJBgNVBAYTAlVTMRMwEQYD
+VQQKEwpSVEZNLCBJbmMuMRkwFwYDVQQLExBXaWRnZXRzIERpdmlzaW9uMRgwFgYD
+VQQDEw9UZXN0IENBMjAwMTA1MTcwHhcNMDEwNTE3MTYxMDU5WhcNMDQwMzA2MTYx
+MDU5WjBRMQswCQYDVQQGEwJVUzETMBEGA1UEChMKUlRGTSwgSW5jLjEZMBcGA1UE
+CxMQV2lkZ2V0cyBEaXZpc2lvbjESMBAGA1UEAxMJbG9jYWxob3N0MIGfMA0GCSqG
+SIb3DQEBAQUAA4GNADCBiQKBgQCiWhMjNOPlPLNW4DJFBiL2fFEIkHuRor0pKw25
+J0ZYHW93lHQ4yxA6afQr99ayRjMY0D26pH41f0qjDgO4OXskBsaYOFzapSZtQMbT
+97OCZ7aHtK8z0ZGNW/cslu+1oOLomgRxJomIFgW1RyUUkQP1n0hemtUdCLOLlO7Q
+CPqZLQIDAQABMA0GCSqGSIb3DQEBBAUAA4GBAIumUwl1OoWuyN2xfoBHYAs+lRLY
+KmFLoI5+iMcGxWIsksmA+b0FLRAN43wmhPnums8eXgYbDCrKLv2xWcvKDP3mps7m
+AMivwtu/eFpYz6J8Mo1fsV4Ys08A/uPXkT23jyKo2hMu8mywkqXCXYF2e+7pEeBr
+dsbmkWK5NgoMl8eM
+-----END CERTIFICATE-----
projects / factor.git / commitdiff