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

db4
Eduardo Cavazos 2008-06-12 22:52:20 -05:00
commit 5249016972
61 changed files with 650 additions and 354 deletions

View File

@ -397,7 +397,7 @@ M: quotation '
[
{
dictionary source-files builtins
update-map class<=-cache
update-map implementors-map class<=-cache
class-not-cache classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each

View File

@ -37,6 +37,7 @@ H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
H{ } clone implementors-map set
init-caches
! Vocabulary for slot accessors
@ -492,7 +493,8 @@ tuple
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
[ tuple-layout [ <tuple-boa> ] curry ] tri
(( obj quot -- curry )) define-declared
"compose" "kernel" create
tuple
@ -513,7 +515,8 @@ tuple
"compose" "kernel" lookup
[ f "inline" set-word-prop ]
[ ]
[ tuple-layout [ <tuple-boa> ] curry ] tri define
[ tuple-layout [ <tuple-boa> ] curry ] tri
(( quot1 quot2 -- compose )) define-declared
! Primitive words
: make-primitive ( word vocab n -- )

View File

@ -49,7 +49,7 @@ millis >r
default-image-name "output-image" set-global
"math compiler help random tools ui ui.tools io handbook" "include" set-global
"math compiler help io random tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line

View File

@ -68,7 +68,10 @@ HELP: tuple-class
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
! HELP: implementors-map
! { $var-description "Assoc mapping each class to a set of generic words defining methods on this class." } ;
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }

View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private ;
compiler.units kernel.private sorting vocabs ;
IN: classes.tests
! DEFER: bah
@ -169,3 +169,9 @@ M: method-forget-class method-forget-test ;
[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
[ t ] [
all-words [ class? ] filter
implementors-map get keys
[ natural-sort ] bi@ =
] unit-test

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
quotations combinators sorting effects graphs vocabs sets ;
IN: classes
SYMBOL: class<=-cache
@ -27,24 +27,24 @@ SYMBOL: class-or-cache
SYMBOL: update-map
SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] filter ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
: predicate-effect T{ effect f 1 { "?" } } ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
r> predicate-effect define-declared ;
r> (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
@ -67,6 +67,8 @@ GENERIC: reset-class ( class -- )
M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
! update-map
: class-uses ( class -- seq )
[
@ -87,6 +89,16 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
M: class implementors implementors-map get at keys ;
M: sequence implementors [ implementors ] gather ;
: implementors-map+ ( class -- )
H{ } clone swap implementors-map get set-at ;
: implementors-map- ( class -- )
implementors-map get delete-at ;
: make-class-props ( superclass members participants metaclass -- assoc )
[
{
@ -99,7 +111,7 @@ M: word reset-class drop ;
: (define-class) ( word props -- )
>r
dup class? [ dup new-class ] unless
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
@ -139,6 +151,23 @@ GENERIC: update-methods ( class seq -- )
[ forget ] [ drop ] if
] [ 2drop ] if ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
: forget-class ( class -- )
class-usages [
{
[ forget-predicate ]
[ forget-methods ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
} cleave
] each ;
M: class forget* ( class -- )
[ forget-class ] [ call-next-method ] bi ;
GENERIC: class ( object -- class )
: instance? ( obj class -- ? )

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators ;
classes.algebra quotations arrays vocabs effects combinators
sets ;
IN: generic
! Method combination protocol
@ -94,8 +95,13 @@ M: method-body crossref?
method-word-name f <word>
[ set-word-props ] keep ;
: with-implementors ( class generic quot -- )
[ swap implementors-map get at ] dip call ; inline
: reveal-method ( method class generic -- )
[ set-at ] with-methods ;
[ [ conjoin ] with-implementors ]
[ [ set-at ] with-methods ]
2bi ;
: create-method ( class generic -- method )
2dup method dup [
@ -142,7 +148,11 @@ M: method-body forget*
[ "method-generic" word-prop ] bi
2dup method
] keep eq?
[ [ delete-at ] with-methods ] [ 2drop ] if
[
[ [ delete-at ] with-methods ]
[ [ delete-at ] with-implementors ]
2bi
] [ 2drop ] if
] if
]
[ call-next-method ] bi
@ -151,33 +161,6 @@ M: method-body forget*
M: method-body smart-usage
"method-generic" word-prop smart-usage ;
GENERIC: implementors ( class/classes -- seq )
M: class implementors
all-words [ "methods" word-prop key? ] with filter ;
M: sequence implementors
all-words [
"methods" word-prop keys
swap [ memq? ] curry contains?
] with filter ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
: forget-class ( class -- )
class-usages [
{
[ forget-predicate ]
[ forget-methods ]
[ update-map- ]
[ reset-class ]
} cleave
] each ;
M: class forget* ( class -- )
[ forget-class ] [ call-next-method ] bi ;
M: sequence update-methods ( class seq -- )
implementors [
[ update-generic ] [ make-generic drop ] 2bi
@ -188,6 +171,7 @@ M: sequence update-methods ( class seq -- )
2drop
] [
2dup "combination" set-word-prop
over "methods" word-prop values forget-all
over H{ } clone "methods" set-word-prop
dupd define-default-method
make-generic

View File

@ -33,7 +33,7 @@ HELP: group
{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
{ $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
{ $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
} ;
HELP: <groups>
@ -41,7 +41,7 @@ HELP: <groups>
{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
} ;
@ -51,7 +51,7 @@ HELP: <sliced-groups>
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <sliced-groups>"
"dup [ reverse-here ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
@ -68,7 +68,7 @@ HELP: clump
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
{ $examples
{ $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
{ $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
} ;
HELP: <clumps>
@ -77,7 +77,7 @@ HELP: <clumps>
{ $examples
"Running averages:"
{ $example
"USING: splitting sequences math prettyprint kernel ;"
"USING: grouping sequences math prettyprint kernel ;"
"IN: scratchpad"
": share-price"
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"

View File

@ -95,10 +95,8 @@ SYMBOL: +editable+
: describe ( obj -- ) H{ } describe* ;
: namestack. ( seq -- )
[
[ global eq? not ] filter
[ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
[ [ global eq? not ] filter [ keys ] gather ] keep
[ dupd assoc-stack ] curry H{ } map>assoc describe ;
: .vars ( -- )
namestack namestack. ;

View File

@ -14,7 +14,7 @@ GENERIC: encode-char ( char stream encoding -- )
GENERIC: <decoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ;
: replacement-char HEX: fffd ; inline
TUPLE: decoder stream code cr ;
@ -121,14 +121,28 @@ M: encoder stream-flush encoder-stream stream-flush ;
INSTANCE: encoder plain-writer
PRIVATE>
: re-encode ( stream encoding -- newstream )
over encoder? [ >r encoder-stream r> ] when <encoder> ;
GENERIC# re-encode 1 ( stream encoding -- newstream )
M: object re-encode <encoder> ;
M: encoder re-encode [ stream>> ] dip re-encode ;
: encode-output ( encoding -- )
output-stream [ swap re-encode ] change ;
: re-decode ( stream encoding -- newstream )
over decoder? [ >r decoder-stream r> ] when <decoder> ;
: with-encoded-output ( encoding quot -- )
[ [ output-stream get ] dip re-encode ] dip
with-output-stream* ; inline
GENERIC# re-decode 1 ( stream encoding -- newstream )
M: object re-decode <decoder> ;
M: decoder re-decode [ stream>> ] dip re-decode ;
: decode-input ( encoding -- )
input-stream [ swap re-decode ] change ;
: with-decoded-input ( encoding quot -- )
[ [ input-stream get ] dip re-decode ] dip
with-input-stream* ; inline

View File

@ -1,5 +1,6 @@
USING: kernel tools.test io.encodings.utf16 arrays sbufs
io.streams.byte-array sequences io.encodings io unicode
io.streams.byte-array sequences io.encodings io
bootstrap.unicode
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests

View File

@ -1,4 +1,5 @@
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays unicode ;
USING: io.encodings.utf8 tools.test io.encodings.string strings arrays
bootstrap.unicode ;
IN: io.encodings.utf8.tests
: decode-utf8-w/stream ( array -- newarray )

View File

@ -401,7 +401,7 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
HELP: ? ( ? true false -- true/false )
HELP: ?
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@ -409,7 +409,7 @@ HELP: >boolean
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
{ $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ;
HELP: not ( obj -- ? )
HELP: not
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
{ $description "For " { $link f } " outputs " { $link t } " and for anything else outputs " { $link f } "." }
{ $notes "This word implements boolean not, so applying it to integers will not yield useful results (all integers have a true value). Bitwise not is the " { $link bitnot } " word." } ;
@ -692,26 +692,26 @@ HELP: tri@
}
} ;
HELP: if ( cond true false -- )
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
HELP: if
{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
$nl
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
HELP: when
{ $values { "cond" "a generalized boolean" } { "true" quotation } }
{ $values { "?" "a generalized boolean" } { "true" quotation } }
{ $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
$nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: unless
{ $values { "cond" "a generalized boolean" } { "false" quotation } }
{ $values { "?" "a generalized boolean" } { "false" quotation } }
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
$nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" quotation } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@ -720,14 +720,14 @@ $nl
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
HELP: when*
{ $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
{ $values { "?" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } }
{ $description "Variant of " { $link if* } " with no false quotation."
$nl
"The following two lines are equivalent:"
{ $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ;
HELP: unless*
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
{ $values { "?" "a generalized boolean" } { "false" "a quotation " } }
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
@ -794,7 +794,7 @@ HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
HELP: curry ( obj quot -- curry )
HELP: curry
{ $values { "obj" object } { "quot" callable } { "curry" curry } }
{ $description "Partial application. Outputs a " { $link callable } " which first pushes " { $snippet "obj" } " and then calls " { $snippet "quot" } "." }
{ $class-description "The class of objects created by " { $link curry } ". These objects print identically to quotations and implement the sequence protocol, however they only use two cells of storage; a reference to the object and a reference to the underlying quotation." }
@ -832,7 +832,7 @@ HELP: with
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
HELP: compose ( quot1 quot2 -- compose )
HELP: compose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes

View File

@ -28,20 +28,20 @@ DEFER: if
: if ( ? true false -- ) ? call ;
! Single branch
: unless ( cond false -- )
: unless ( ? false -- )
swap [ drop ] [ call ] if ; inline
: when ( cond true -- )
: when ( ? true -- )
swap [ call ] [ drop ] if ; inline
! Anaphoric
: if* ( cond true false -- )
: if* ( ? true false -- )
pick [ drop call ] [ 2nip call ] if ; inline
: when* ( cond true -- )
: when* ( ? true -- )
over [ call ] [ 2drop ] if ; inline
: unless* ( cond false -- )
: unless* ( ? false -- )
over [ drop ] [ nip call ] if ; inline
! Default

View File

@ -24,7 +24,7 @@ ABOUT: "floats"
HELP: float
{ $class-description "The class of double-precision floating point numbers." } ;
HELP: >float ( x -- y )
HELP: >float
{ $values { "x" real } { "y" float } }
{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;

View File

@ -23,17 +23,21 @@ ABOUT: "integers"
HELP: fixnum
{ $class-description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ;
HELP: >fixnum ( x -- n )
HELP: >fixnum
{ $values { "x" real } { "n" fixnum } }
{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ;
HELP: bignum
{ $class-description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ;
HELP: >bignum ( x -- n )
HELP: >bignum
{ $values { "x" real } { "n" bignum } }
{ $description "Converts a real number to a bignum, with a possible loss of precision." } ;
HELP: >integer
{ $values { "x" real } { "n" bignum } }
{ $description "Converts a real number to an integer, with a possible loss of precision." } ;
HELP: integer
{ $class-description "The class of integers, which is a disjoint union of fixnums and bignums." } ;

View File

@ -3,9 +3,9 @@
USING: kernel math.private ;
IN: math
GENERIC: >fixnum ( x -- y ) foldable
GENERIC: >bignum ( x -- y ) foldable
GENERIC: >integer ( x -- y ) foldable
GENERIC: >fixnum ( x -- n ) foldable
GENERIC: >bignum ( x -- n ) foldable
GENERIC: >integer ( x -- n ) foldable
GENERIC: >float ( x -- y ) foldable
MATH: number= ( x y -- ? ) foldable

View File

@ -16,6 +16,9 @@ IN: sets
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ;
: gather ( seq quot -- newseq )
map concat prune ; inline
: unique ( seq -- assoc )
[ dup ] H{ } map>assoc ;

View File

@ -148,8 +148,12 @@ M: object redefined drop ;
2dup "declared-effect" word-prop = [ 2drop ] [
swap
[ "declared-effect" set-word-prop ]
[ drop [ redefined ] [ +inlined+ changed-definition ] bi ]
2bi
[
drop
dup primitive? [ drop ] [
[ redefined ] [ +inlined+ changed-definition ] bi
] if
] 2bi
] if ;
: define-declared ( word def effect -- )

View File

@ -7,7 +7,7 @@ kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
: download-checksums ( -- alist )
url "checksums.txt" append http-get
url "checksums.txt" append http-get nip
string-lines [ " " split1 ] { } map>assoc ;
: need-new-image? ( image -- ? )

View File

@ -0,0 +1,12 @@
USING: parser kernel namespaces ;
USE: unicode.breaks
USE: unicode.case
USE: unicode.categories
USE: unicode.collation
USE: unicode.data
USE: unicode.normalize
USE: unicode.script
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global

View File

@ -35,7 +35,7 @@ HOOK: db-close db ( handle -- )
handle>> db-close
] with-variable ;
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
@ -89,7 +89,7 @@ M: object execute-statement* ( statement type -- )
swap >>out-params
swap >>in-params
swap >>sql ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;

View File

@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array inspector ;
alien.strings io.streams.byte-array inspector present urls ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@ -84,6 +84,7 @@ M: postgresql-result-null summary ( obj -- str )
{ TIME [ dup [ timestamp>hms ] when default-param-value ] }
{ DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
{ TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
{ URL [ dup [ present ] when default-param-value ] }
[ drop default-param-value ]
} case 2array
] 2map flip dup empty? [
@ -164,6 +165,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ BLOB [ pq-get-blob ] }
{ URL [ pq-get-string dup [ >url ] when ] }
{ FACTOR-BLOB [
pq-get-blob
dup [ bytes>object ] when ] }

View File

@ -239,6 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable )
{ TIMESTAMP { "timestamp" "timestamp" f } }
{ BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } }
{ URL { "varchar" "varchar" f } }
{ +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
strings math.parser math.intervals combinators
math.bitfields.lib namespaces.lib db db.tuples db.types ;
math.bitfields.lib namespaces.lib db db.tuples db.types
sequences.lib db.sql classes words shuffle arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -99,16 +100,15 @@ M: string where ( spec obj -- ) object-where ;
] with filter ;
: where-clause ( tuple specs -- )
dupd filter-slots
dup empty? [
2drop
dupd filter-slots [
drop
] [
" where " 0% [
" and " 0%
] [
2dup slot-name>> swap get-slot-named where
] interleave drop
] if ;
] if-empty ;
M: db <delete-tuples-statement> ( tuple table -- sql )
[
@ -146,15 +146,52 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
number>string " limit " prepend append
] curry change-sql drop ;
: make-advanced-statement ( tuple advanced -- tuple' )
: make-query ( tuple query -- tuple' )
dupd
{
[ group>> [ do-group ] [ drop ] if* ]
[ order>> [ do-order ] [ drop ] if* ]
[ group>> [ do-group ] [ drop ] if-seq ]
[ order>> [ do-order ] [ drop ] if-seq ]
[ limit>> [ do-limit ] [ drop ] if* ]
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
advanced-statement boa
[ <select-by-slots-statement> ] dip make-advanced-statement ;
M: db <query> ( tuple class query -- tuple )
[ <select-by-slots-statement> ] dip make-query ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
: select-tuples* ( tuple -- statement )
dup
[
select 0,
dup class db-columns [ ", " 0, ]
[ dup column-name>> 0, 2, ] interleave
from 0,
class word-name 0,
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
M: db <count-statement> ( tuple class groups -- statement )
\ query new
swap >>group
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query ;
: where-clause* ( tuple specs -- )
dupd filter-slots [
drop
] [
\ where 0,
[ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
drop
] if-empty ;
: delete-tuple* ( tuple -- sql )
dup
[
delete 0, from 0, dup class db-table 0,
dup class db-columns where-clause*
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;

View File

@ -23,12 +23,27 @@ DEFER: sql%
: sql-function, ( seq function -- )
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
: sql-where ( seq -- )
B
[
[ second 0, ]
[ first 0, ]
[ third 1, \ ? 0, ] tri
] each ;
: sql-array% ( array -- )
B
unclip
{
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ B "select" sql% "," (sql-interleave) ] }
{ \ columns [ "," (sql-interleave) ] }
{ \ from [ "from" "," sql-interleave ] }
{ \ where [ "where" "and" sql-interleave ] }
{ \ where [ B "where" 0, sql-where ] }
{ \ group-by [ "group by" "," sql-interleave ] }
{ \ having [ "having" "," sql-interleave ] }
{ \ order-by [ "order by" "," sql-interleave ] }
@ -49,7 +64,7 @@ DEFER: sql%
ERROR: no-sql-match ;
: sql% ( obj -- )
{
{ [ dup string? ] [ " " 0% 0% ] }
{ [ dup string? ] [ 0, ] }
{ [ dup array? ] [ sql-array% ] }
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
@ -59,13 +74,4 @@ ERROR: no-sql-match ;
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[
unclip {
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;
[ [ sql% ] each ] { { } { } { } } nmake ;

View File

@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors ;
io.backend db.errors present urls ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
@ -107,6 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
object>bytes
sqlite-bind-blob-by-name
] }
{ URL [ present sqlite-bind-text-by-name ] }
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] }
@ -147,6 +148,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
{ TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ BLOB [ sqlite-column-blob ] }
{ URL [ sqlite3_column_text dup [ >url ] when ] }
{ FACTOR-BLOB [
sqlite-column-blob
dup [ bytes>object ] when

View File

@ -182,6 +182,7 @@ M: sqlite-db persistent-table ( -- assoc )
{ DOUBLE { "real" "real" } }
{ BLOB { "blob" "blob" } }
{ FACTOR-BLOB { "blob" "blob" } }
{ URL { "text" "text" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }

View File

@ -4,26 +4,27 @@ USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib ;
math.ranges strings sequences.lib urls ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
ts date time blob factor-blob url ;
: <person> ( name age real ts date time blob factor-blob -- person )
{
set-person-the-name
set-person-the-number
set-person-the-real
set-person-ts
set-person-date
set-person-time
set-person-blob
set-person-factor-blob
} person construct ;
: <person> ( name age real ts date time blob factor-blob url -- person )
person new
swap >>url
swap >>factor-blob
swap >>blob
swap >>time
swap >>date
swap >>ts
swap >>the-real
swap >>the-number
swap >>the-name ;
: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
<person> [ set-person-the-id ] keep ;
: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
<person>
swap >>the-id ;
SYMBOL: person1
SYMBOL: person2
@ -103,6 +104,7 @@ SYMBOL: person4
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
}
] [ T{ person f 4 } select-tuple ] unit-test
@ -120,19 +122,20 @@ SYMBOL: person4
{ "time" "T" TIME }
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
{ "url" "U" URL }
} define-persistent
"billy" 10 3.14 f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f <person> person2 set
"billy" 10 3.14 f f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f f <person> person2 set
"teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
"eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
: user-assigned-person-schema ( -- )
person "PERSON"
@ -146,20 +149,21 @@ SYMBOL: person4
{ "time" "T" TIME }
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
{ "url" "U" URL }
} define-persistent
1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
3 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
f <user-assigned-person> person3 set
f f <user-assigned-person> person3 set
4 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ;
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
@ -227,7 +231,7 @@ TUPLE: exam id name score ;
: random-exam ( -- exam )
f
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
100 random
exam boa ;
@ -340,7 +344,9 @@ TUPLE: exam id name score ;
}
] [
T{ exam } select-tuples
] unit-test ;
] unit-test
[ 4 ] [ T{ exam } f count-tuples ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )

View File

@ -42,8 +42,9 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
TUPLE: advanced-statement group order offset limit ;
HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
TUPLE: query group order offset limit ;
HOOK: <query> db ( tuple class query -- statement' )
HOOK: <count-statement> db ( tuple class groups -- n )
HOOK: insert-tuple* db ( tuple statement -- )
@ -55,6 +56,7 @@ SINGLETON: retryable
[ make-retryable ] map
] [
retryable >>type
10 >>retries
] if ;
: regenerate-params ( statement -- statement )
@ -69,12 +71,13 @@ SINGLETON: retryable
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop
[
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ;
drop [
[
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] [ retries>> ] bi retry drop ;
: resulting-tuple ( class row out-params -- tuple )
rot class new [
@ -146,12 +149,21 @@ M: retryable execute-statement* ( statement type -- )
: do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: query ( tuple query -- tuples )
>r dup dup class r> <query> do-select ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
: count-tuples ( tuple -- n )
select-tuples length ;
: select-tuple ( tuple -- tuple/f )
dup dup class f f f 1 <advanced-select-statement>
do-select ?first ;
dup dup class \ query new 1 >>limit <query> do-select ?first ;
: do-count ( exemplar-tuple statement -- tuples )
[
[ bind-tuple ] [ nip default-query ] 2bi
] with-disposal ;
: count-tuples ( tuple groups -- n )
>r dup dup class r> <count-statement> do-count
dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ;

View File

@ -65,7 +65,7 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL ;
FACTOR-BLOB NULL URL ;
: spec>tuple ( class spec -- tuple )
3 f pad-right

View File

@ -6,7 +6,7 @@ IN: html.parser.analyzer
TUPLE: link attributes clickable ;
: scrape-html ( url -- vector )
http-get parse-html ;
http-get nip parse-html ;
: (find-relative)
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline

View File

@ -2,7 +2,7 @@ USING: assocs html.parser html.parser.utils combinators
continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
strings ;
IN: html.parser.printer
SYMBOL: no-section
@ -16,7 +16,8 @@ TUPLE: state section ;
TUPLE: text-printer ;
TUPLE: ui-printer ;
TUPLE: src-printer ;
UNION: printer text-printer ui-printer src-printer ;
TUPLE: html-prettyprinter ;
UNION: printer text-printer ui-printer src-printer html-prettyprinter ;
HOOK: print-tag printer ( tag -- )
HOOK: print-text-tag printer ( tag -- )
HOOK: print-comment-tag printer ( tag -- )
@ -47,7 +48,7 @@ M: printer print-comment-tag ( tag -- )
tag-text write
"-->" write ;
M: printer print-dtd-tag
M: printer print-dtd-tag ( tag -- )
"<!" write
tag-text write
">" write ;
@ -70,8 +71,8 @@ M: printer print-closing-named-tag ( tag -- )
M: src-printer print-opening-named-tag ( tag -- )
"<" write
dup tag-name write
tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if
[ tag-name write ]
[ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
">" write ;
M: src-printer print-closing-named-tag ( tag -- )
@ -79,9 +80,30 @@ M: src-printer print-closing-named-tag ( tag -- )
tag-name write
">" write ;
TUPLE: unknown-tag-error tag ;
SYMBOL: tab-width
SYMBOL: #indentations
C: <unknown-tag-error> unknown-tag-error
: html-pp ( vector -- )
[
0 #indentations set
2 tab-width set
] with-scope ;
: print-tabs ( -- )
tab-width get #indentations get * CHAR: \s <repetition> write ;
M: html-prettyprinter print-opening-named-tag ( tag -- )
print-tabs "<" write
tag-name write
">\n" write ;
M: html-prettyprinter print-closing-named-tag ( tag -- )
"</" write
tag-name write
">" write ;
ERROR: unknown-tag-error tag ;
M: printer print-tag ( tag -- )
{
@ -92,15 +114,12 @@ M: printer print-tag ( tag -- )
[ print-closing-named-tag ] }
{ [ dup tag-name string? ]
[ print-opening-named-tag ] }
[ <unknown-tag-error> throw ]
[ unknown-tag-error ]
} cond ;
SYMBOL: tablestack
: with-html-printer
[
V{ } clone tablestack set
] with-scope ;
! SYMBOL: tablestack
! : with-html-printer ( vector quot -- )
! [ V{ } clone tablestack set ] with-scope ;
! { { 1 2 } { 3 4 } }
! H{ { table-gap { 10 10 } } } [

View File

@ -1,7 +1,7 @@
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
state-parser strings sequences.lib ;
IN: html.parser.utils
: string-parse-end?
@ -13,7 +13,7 @@ IN: html.parser.utils
dup length rot length 1- - head next* ;
: trim1 ( seq ch -- newseq )
[ ?head drop ] keep ?tail drop ;
[ ?head drop ] [ ?tail drop ] bi ;
: single-quote ( str -- newstr )
>r "'" r> "'" 3append ;
@ -26,11 +26,7 @@ IN: html.parser.utils
[ double-quote ] [ single-quote ] if ;
: quoted? ( str -- ? )
dup length 1 > [
[ first ] keep peek [ = ] keep "'\"" member? and
] [
drop f
] if ;
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
: ?quote ( str -- newstr )
dup quoted? [ quote ] unless ;
@ -39,4 +35,3 @@ IN: html.parser.utils
dup quoted? [ but-last-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ;

View File

@ -3,8 +3,13 @@
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 io.streams.duplex
fry debugger inspector ascii urls ;
io.encodings
io.encodings.string
io.encodings.ascii
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
fry debugger inspector ascii urls present ;
IN: http.client
: max-redirects 10 ;
@ -15,7 +20,7 @@ M: too-many-redirects summary
drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
DEFER: http-request
DEFER: (http-request)
<PRIVATE
@ -31,7 +36,7 @@ SYMBOL: redirects
redirects get max-redirects < [
request get
swap "location" header redirect-url
"GET" >>method http-request
"GET" >>method (http-request)
] [
too-many-redirects
] if
@ -45,15 +50,21 @@ PRIVATE>
: read-chunks ( -- )
read-chunk-size dup zero?
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
[ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ;
: read-response-body ( response -- response data )
dup "transfer-encoding" header "chunked" =
[ [ read-chunks ] "" make ] [ input-stream get contents ] if ;
dup "transfer-encoding" header "chunked" = [
binary decode-input
[ read-chunks ] B{ } make
over content-charset>> decode
] [
dup content-charset>> decode-input
input-stream get contents
] if ;
: http-request ( request -- response data )
: (http-request) ( request -- response data )
dup request [
dup url>> url-addr latin1 [
dup url>> url-addr ascii [
1 minutes timeouts
write-request
read-response
@ -62,14 +73,6 @@ PRIVATE>
do-redirect
] with-variable ;
: <get-request> ( url -- request )
<request>
"GET" >>method
swap >url ensure-port >>url ;
: http-get* ( url -- response data )
<get-request> http-request ;
: success? ( code -- ? ) 200 = ;
ERROR: download-failed response body ;
@ -84,18 +87,28 @@ M: download-failed error.
]
[ body>> write ] bi ;
: check-response ( response string -- string )
over code>> success? [ nip ] [ download-failed ] if ;
: check-response ( response data -- response data )
over code>> success? [ download-failed ] unless ;
: http-get ( url -- string )
http-get* check-response ;
: http-request ( request -- response data )
(http-request) check-response ;
: <get-request> ( url -- request )
<request>
"GET" >>method
swap >url ensure-port >>url ;
: http-get ( url -- response data )
<get-request> http-request ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
[ http-get ] dip latin1 [ write ] with-file-writer ;
swap http-get
[ content-charset>> ] [ '[ , write ] ] bi*
with-file-writer ;
: download ( url -- )
dup download-name download-to ;

View File

@ -1,5 +1,6 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
io.streams.string io.encodings.utf8 io.encodings.string
kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations urls hashtables ;
IN: http.tests
@ -78,7 +79,7 @@ must-fail-with
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF8
Content-Type: text/html; charset=UTF-8
blah
;
@ -88,10 +89,10 @@ blah
version: "1.1"
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
header: H{ { "content-type" "text/html; charset=UTF-8" } }
cookies: { }
content-type: "text/html"
content-charset: "UTF8"
content-charset: utf8
}
] [
read-response-test-1 lf>crlf
@ -101,7 +102,7 @@ blah
STRING: read-response-test-1'
HTTP/1.1 404 not found
content-type: text/html; charset=UTF8
content-type: text/html; charset=UTF-8
;
@ -160,14 +161,14 @@ test-db [
[ t ] [
"resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get =
"http://localhost:1237/nested/foo.html" http-get nip ascii decode =
] unit-test
[ "http://localhost:1237/redirect-loop" http-get ]
[ "http://localhost:1237/redirect-loop" http-get nip ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
"http://localhost:1237/quit" http-get
"http://localhost:1237/quit" http-get nip
] unit-test
! Dispatcher bugs
@ -194,12 +195,12 @@ test-db [
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with
[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with
[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ ] [
[
@ -218,9 +219,9 @@ test-db [
[ ] [ 100 sleep ] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
USING: html.components html.elements xml xml.utilities validators
furnace furnace.flash ;
@ -253,7 +254,7 @@ SYMBOL: a
: test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [
"http://localhost:1237/" http-get*
"http://localhost:1237/" http-get
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
@ -273,4 +274,4 @@ SYMBOL: a
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test

View File

@ -7,6 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
io io.server io.sockets.secure
io.encodings.iana io.encodings.binary io.encodings.8-bit
unicode.case unicode.categories qualified
@ -28,7 +29,8 @@ IN: http
"header" get
add-header
] [
": " split1 dup [
":" split1 dup [
[ blank? ] left-trim
swap >lower dup "last-header" set
"header" get add-header
] [
@ -36,20 +38,20 @@ IN: http
] if
] if ;
: read-lf ( -- string )
: read-lf ( -- bytes )
"\n" read-until CHAR: \n assert= ;
: read-crlf ( -- string )
: read-crlf ( -- bytes )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: read-header-line ( -- )
: (read-header) ( -- )
read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ;
empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- assoc )
H{ } clone [
"header" [ read-header-line ] with-variable
"header" [ (read-header) ] with-variable
] keep ;
: header-value>string ( value -- string )
@ -66,7 +68,8 @@ IN: http
: write-header ( assoc -- )
>alist sort-keys [
swap url-encode write ": " write
swap
check-header-string write ": " write
header-value>string check-header-string write crlf
] assoc-each crlf ;
@ -299,6 +302,7 @@ body ;
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
latin1 >>content-charset
V{ } clone >>cookies ;
: read-response-version ( response -- response )
@ -319,7 +323,9 @@ body ;
read-header >>header
dup "set-cookie" header parse-cookies >>cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
parse-content-type
[ >>content-type ]
[ name>encoding binary or >>content-charset ] bi*
] when* ;
: read-response ( -- response )
@ -341,7 +347,8 @@ body ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
[ content-charset>> ] bi
[ content-charset>> encoding>name ]
bi
[ "; charset=" swap 3append ] when* ;
: write-response-header ( response -- response )

View File

@ -1,13 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements math.parser http accessors kernel
io io.streams.string ;
io io.streams.string io.encodings.utf8 ;
IN: http.server.responses
: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
utf8 >>content-charset
swap >>content-type
swap >>body ;

View File

@ -1,10 +1,21 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader http http.server.responses logging calendar
destructors html.elements html.streams io.server
io.encodings.8-bit io.timeouts io assocs debugger continuations
fry tools.vocabs math ;
vocabs.loader destructors assocs debugger continuations
tools.vocabs math
io
io.server
io.encodings
io.encodings.utf8
io.encodings.ascii
io.encodings.binary
io.streams.limited
io.timeouts
fry logging calendar
http
http.server.responses
html.elements
html.streams ;
IN: http.server
SYMBOL: responder-nesting
@ -43,19 +54,29 @@ main-responder global [ <404> <trivial-responder> or ] change-at
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" = [ drop ] [
'[ , write-response-body ]
[
development-mode get
[ http-error. ] [ drop "Response error" ] if
] recover
] if ;
[ write-response ]
[
request get method>> "HEAD" = [ drop ] [
'[
,
[ content-charset>> encode-output ]
[ write-response-body ]
bi
]
[
utf8 [
development-mode get
[ http-error. ] [ drop "Response error" throw ] if
] with-encoded-output
] recover
] if
] bi ;
LOG: httpd-hit NOTICE
: log-request ( request -- )
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi
3array httpd-hit ;
: split-path ( string -- path )
"/" split harvest ;
@ -79,9 +100,15 @@ LOG: httpd-hit NOTICE
development-mode get-global
[ global [ refresh-all ] bind ] when ;
: setup-limits ( -- )
1 minutes timeouts
64 1024 * limit-input ;
: handle-client ( -- )
[
1 minutes timeouts
setup-limits
ascii decode-input
ascii encode-output
?refresh-all
read-request
do-request
@ -90,7 +117,7 @@ LOG: httpd-hit NOTICE
: httpd ( port -- )
dup integer? [ internet-server ] when
"http.server" latin1 [ handle-client ] with-server ;
"http.server" binary [ handle-client ] with-server ;
: httpd-main ( -- )
8888 httpd ;

View File

@ -29,7 +29,10 @@ TUPLE: file-responder root hook special allow-listings ;
H{ } clone >>special ;
: (serve-static) ( path mime-type -- response )
[ [ binary <file-reader> &dispose ] dip <content> ]
[
[ binary <file-reader> &dispose ] dip
<content> binary >>content-charset
]
[ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
[ "content-length" set-header ]
[ "last-modified" set-header ] bi* ;

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax byte-arrays alien ;
USING: help.markup help.syntax byte-arrays alien destructors ;
IN: io.buffers
ARTICLE: "buffers" "Locked I/O buffers"
@ -7,8 +7,8 @@ $nl
"Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
{ $subsection buffer }
{ $subsection <buffer> }
"Buffers must be manually deallocated:"
{ $subsection buffer-free }
"Buffers must be manually deallocated by calling " { $link dispose } "."
$nl
"Buffer operations:"
{ $subsection buffer-reset }
{ $subsection buffer-length }
@ -40,11 +40,6 @@ HELP: <buffer>
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
HELP: buffer-free
{ $values { "buffer" buffer } }
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
HELP: buffer-reset
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
@ -61,10 +56,6 @@ HELP: buffer-end
{ $values { "buffer" buffer } { "alien" alien } }
{ $description "Outputs the memory address of the current fill-pointer." } ;
HELP: (buffer-read)
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
HELP: buffer-read
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;

View File

@ -1,6 +1,7 @@
IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc
sequences tools.test namespaces byte-arrays strings accessors ;
sequences tools.test namespaces byte-arrays strings accessors
destructors ;
: buffer-set ( string buffer -- )
over >byte-array over buffer-ptr byte-array>memory
@ -18,7 +19,7 @@ sequences tools.test namespaces byte-arrays strings accessors ;
65536 <buffer>
dup buffer-read-all
over buffer-capacity
rot buffer-free
rot dispose
] unit-test
[ "hello world" "" ] [
@ -26,34 +27,34 @@ sequences tools.test namespaces byte-arrays strings accessors ;
dup buffer-read-all >string
0 pick buffer-reset
over buffer-read-all >string
rot buffer-free
rot dispose
] unit-test
[ "hello" ] [
"hello world" string>buffer
5 over buffer-read >string swap buffer-free
5 over buffer-read >string swap dispose
] unit-test
[ 11 ] [
"hello world" string>buffer
[ buffer-length ] keep buffer-free
[ buffer-length ] keep dispose
] unit-test
[ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep
" world" >byte-array over >buffer
dup buffer-read-all >string swap buffer-free
dup buffer-read-all >string swap dispose
] unit-test
[ CHAR: e ] [
"hello" string>buffer
1 over buffer-consume [ buffer-pop ] keep buffer-free
1 over buffer-consume [ buffer-pop ] keep dispose
] unit-test
"hello world" string>buffer "b" set
[ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test
"b" get buffer-free
"b" get dispose
100 <buffer> "b" set
[ 1000 "b" get n>buffer >string ] must-fail
"b" get buffer-free
"b" get dispose

View File

@ -1,77 +1,101 @@
! Copyright (C) 2004, 2005 Mackenzie Straight.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors alien.c-types alien.syntax kernel
kernel.private libc math sequences byte-arrays strings hints
accessors math.order ;
USING: accessors alien alien.accessors alien.c-types
alien.syntax kernel libc math sequences byte-arrays strings
hints accessors math.order destructors combinators ;
IN: io.buffers
TUPLE: buffer size ptr fill pos ;
TUPLE: buffer size ptr fill pos disposed ;
: <buffer> ( n -- buffer )
dup malloc 0 0 buffer boa ;
dup malloc 0 0 f buffer boa ;
: buffer-free ( buffer -- )
dup buffer-ptr free f swap set-buffer-ptr ;
M: buffer dispose* ptr>> free ;
: buffer-reset ( n buffer -- )
0 swap { set-buffer-fill set-buffer-pos } set-slots ;
: buffer-consume ( n buffer -- )
[ buffer-pos + ] keep
[ buffer-fill min ] keep
[ set-buffer-pos ] keep
dup buffer-pos over buffer-fill >= [
0 over set-buffer-pos
0 over set-buffer-fill
] when drop ;
: buffer@ ( buffer -- alien )
dup buffer-pos swap buffer-ptr <displaced-alien> ;
: buffer-end ( buffer -- alien )
dup buffer-fill swap buffer-ptr <displaced-alien> ;
: buffer-peek ( buffer -- byte )
buffer@ 0 alien-unsigned-1 ;
: buffer-pop ( buffer -- byte )
dup buffer-peek 1 rot buffer-consume ;
: (buffer-read) ( n buffer -- byte-array )
[ [ fill>> ] [ pos>> ] bi - min ] keep
buffer@ swap memory>byte-array ;
: buffer-read ( n buffer -- byte-array )
[ (buffer-read) ] [ buffer-consume ] 2bi ;
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ;
swap >>fill 0 >>pos drop ;
: buffer-capacity ( buffer -- n )
[ size>> ] [ fill>> ] bi - ;
[ size>> ] [ fill>> ] bi - ; inline
: buffer-empty? ( buffer -- ? )
fill>> zero? ;
: buffer-consume ( n buffer -- )
[ + ] change-pos
dup [ pos>> ] [ fill>> ] bi <
[ 0 >>pos 0 >>fill ] unless drop ; inline
: buffer-peek ( buffer -- byte )
[ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
: buffer-pop ( buffer -- byte )
[ buffer-peek ] [ 1 swap buffer-consume ] bi ;
HINTS: buffer-pop buffer ;
: buffer-length ( buffer -- n )
[ fill>> ] [ pos>> ] bi - ; inline
: buffer@ ( buffer -- alien )
[ pos>> ] [ ptr>> ] bi <displaced-alien> ;
: buffer-read ( n buffer -- byte-array )
[ buffer-length min ] keep
[ buffer@ ] [ buffer-consume ] 2bi
swap memory>byte-array ;
HINTS: buffer-read fixnum buffer ;
: extend-buffer ( n buffer -- )
2dup buffer-ptr swap realloc
over set-buffer-ptr set-buffer-size ;
2dup ptr>> swap realloc >>ptr swap >>size drop ;
inline
: check-overflow ( n buffer -- )
2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
inline
: >buffer ( byte-array buffer -- )
over length over check-overflow
[ buffer-end byte-array>memory ] 2keep
[ buffer-fill swap length + ] keep set-buffer-fill ;
: byte>buffer ( byte buffer -- )
1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep
[ 1+ ] change-fill drop ;
: buffer-end ( buffer -- alien )
[ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
: n>buffer ( n buffer -- )
[ buffer-fill + ] keep
[ buffer-size > [ "Buffer overflow" throw ] when ] 2keep
set-buffer-fill ;
[ + ] change-fill
[ fill>> ] [ size>> ] bi >
[ "Buffer overflow" throw ] when ; inline
: >buffer ( byte-array buffer -- )
[ [ length ] dip check-overflow ]
[ buffer-end byte-array>memory ]
[ [ length ] dip n>buffer ]
2tri ;
HINTS: >buffer byte-array buffer ;
: byte>buffer ( byte buffer -- )
[ 1 swap check-overflow ]
[ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
[ 1 swap n>buffer ]
tri ;
HINTS: byte>buffer fixnum buffer ;
: search-buffer-until ( pos fill ptr separators -- n )
[ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
: finish-buffer-until ( buffer n -- byte-array separator )
[
over pos>> -
over buffer-read
swap buffer-pop
] [
[ buffer-length ] keep
buffer-read f
] if* ;
: buffer-until ( separators buffer -- byte-array separator )
swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
search-buffer-until
finish-buffer-until ;
HINTS: buffer-until { string buffer } ;

View File

@ -1,4 +1,5 @@
USING: io.encodings.string io.encodings.8-bit tools.test strings arrays ;
USING: io.encodings.string io.encodings.8-bit
io.encodings.8-bit.private tools.test strings arrays ;
IN: io.encodings.8-bit.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
@ -8,3 +9,6 @@ IN: io.encodings.8-bit.tests
[ "bar" ] [ "bar" latin1 decode ] unit-test
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
[ t ] [ \ latin1 8-bit-encoding? ] unit-test
[ "bar" ] [ "bar" \ latin1 decode ] unit-test

View File

@ -73,6 +73,13 @@ M: 8-bit decode-char
: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
PREDICATE: 8-bit-encoding < word
word-def dup length 1 = [ first 8-bit? ] [ drop f ] if ;
M: 8-bit-encoding <encoder> word-def first <encoder> ;
M: 8-bit-encoding <decoder> word-def first <decoder> ;
PRIVATE>
[

View File

@ -41,6 +41,13 @@ PRIVATE>
[ second ] map { "None" } diff
] map ;
: more-aliases ( -- assoc )
H{
{ "UTF8" utf8 }
{ "utf8" utf8 }
{ "utf-8" utf8 }
} ;
: make-n>e ( stream -- n>e )
parse-iana [ [
dup [
@ -48,7 +55,7 @@ PRIVATE>
[ swap [ set ] with each ]
[ drop ] if*
] with each
] each ] H{ } make-assoc ;
] each ] H{ } make-assoc more-aliases assoc-union ;
PRIVATE>
"resource:extra/io/encodings/iana/character-sets"

View File

@ -71,6 +71,28 @@ M: input-port stream-read
] [ 2nip ] if
] [ 2nip ] if ;
: read-until-step ( separators port -- string/f separator/f )
dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
: read-until-loop ( seps port buf -- separator/f )
2over read-until-step over [
>r over push-all r> dup [
>r 3drop r>
] [
drop read-until-loop
] if
] [
>r 2drop 2drop r>
] if ;
M: input-port stream-read-until ( seps port -- str/f sep/f )
2dup read-until-step dup [ >r 2nip r> ] [
over [
drop
BV{ } like [ read-until-loop ] keep B{ } like swap
] [ >r 2nip r> ] if
] if ;
TUPLE: output-port < buffered-port ;
: <output-port> ( handle -- output-port )
@ -121,7 +143,7 @@ M: output-port dispose*
M: buffered-port dispose*
[ call-next-method ]
[ [ [ buffer-free ] when* f ] change-buffer drop ]
[ [ [ dispose ] when* f ] change-buffer drop ]
bi ;
M: port cancel-operation handle>> cancel-operation ;

View File

@ -0,0 +1,32 @@
IN: io.streams.limited.tests
USING: io io.streams.limited io.encodings io.encodings.string
io.encodings.ascii io.encodings.binary io.streams.byte-array
namespaces tools.test strings kernel ;
[ ] [
"hello world\nhow are you today\nthis is a very long line indeed"
ascii encode binary <byte-reader> "data" set
] unit-test
[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
[ ] [ "limited" get ascii <decoder> "decoded" set ] unit-test
[ "ello world" ] [ "decoded" get stream-readln ] unit-test
[ "how " ] [ 4 "decoded" get stream-read ] unit-test
[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with
[ ] [
"abc\ndef\nghi"
ascii encode binary <byte-reader> "data" set
] unit-test
[ ] [ "data" get 7 <limited-stream> "limited" set ] unit-test
[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with

View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io destructors accessors sequences
namespaces ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;
: <limited-stream> ( stream limit -- stream' )
limited-stream new
swap >>limit
swap >>stream
0 >>count ;
: limit-input ( limit -- )
input-stream [ swap <limited-stream> ] change ;
ERROR: limit-exceeded ;
: check-limit ( n stream -- )
[ + ] change-count
[ count>> ] [ limit>> ] bi >=
[ limit-exceeded ] when ; inline
M: limited-stream stream-read1
1 over check-limit stream>> stream-read1 ;
M: limited-stream stream-read
2dup check-limit stream>> stream-read ;
M: limited-stream stream-read-partial
2dup check-limit stream>> stream-read-partial ;
: (read-until) ( stream seps buf -- stream seps buf sep/f )
3dup [ [ stream-read1 dup ] dip memq? ] dip
swap [ drop ] [ push (read-until) ] if ;
M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
M: limited-stream dispose
stream>> dispose ;

View File

@ -5,7 +5,7 @@
USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences
splitting words byte-arrays assocs combinators.lib ;
splitting words byte-arrays assocs ;
IN: opengl
: coordinates ( point1 point2 -- x1 y2 x2 y2 )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib math.parser
vectors arrays math.parser
unicode.categories sequences.deep peg peg.private
peg.search math.ranges words memoize ;
IN: peg.parsers

View File

@ -107,7 +107,7 @@ TUPLE: entry title url description date ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
http-get read-feed ;
http-get nip read-feed ;
! Atom generation
: simple-tag, ( content name -- )

View File

@ -150,6 +150,7 @@ IN: tools.deploy.shaker
classes:class-or-cache
classes:class<=-cache
classes:classes-intersect-cache
classes:implementors-map
classes:update-map
command-line:main-vocab-hook
compiled-crossref

View File

@ -3,7 +3,7 @@
USING: kernel combinators vocabs vocabs.loader tools.vocabs io
io.files io.styles help.markup help.stylesheet sequences assocs
help.topics namespaces prettyprint words sorting definitions
arrays inspector ;
arrays inspector sets ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
@ -105,7 +105,7 @@ C: <vocab-author> vocab-author
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map
[ [ word? ] filter [ word-vocabulary ] map ] map>set
[ [ word? ] filter [ word-vocabulary ] map ] gather natural-sort
remove sift [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;

View File

@ -291,14 +291,11 @@ MEMO: all-vocabs-seq ( -- seq )
[ vocab-dir? ] with filter
] curry map concat ;
: map>set ( seq quot -- )
map concat prune natural-sort ; inline
MEMO: all-tags ( -- seq )
all-vocabs-seq [ vocab-tags ] map>set ;
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] map>set ;
all-vocabs-seq [ vocab-authors ] gather natural-sort ;
: reset-cache ( -- )
root-cache get-global clear-assoc

View File

@ -258,7 +258,7 @@ M: x11-ui-backend ui ( -- )
] ui-running ;
M: x11-ui-backend beep ( -- )
dpy 100 XBell drop ;
dpy get 100 XBell drop ;
x11-ui-backend ui-backend set-global

View File

@ -1,9 +0,0 @@
USING: unicode.syntax unicode.data unicode.breaks
unicode.normalize unicode.case unicode.categories
parser kernel namespaces ;
IN: unicode
! For now: convenience to load all Unicode vocabs
[ name>char [ "Invalid character" throw ] unless* ]
name>char-hook set-global

View File

@ -59,4 +59,4 @@ format similar-ok language country site subscription license ;
swap >>query ;
: search-yahoo ( search -- seq )
query http-get string>xml parse-yahoo ;
query http-get nip string>xml parse-yahoo ;

View File

@ -6,7 +6,7 @@ PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
DLL_EXTENSION = .dylib
ifdef X11
LIBS = -lm -framework Foundation $(X11_UI_LIBS)
LIBS = -lm -framework Foundation $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
else
LIBS = -lm -framework Cocoa -framework AppKit
endif

View File

@ -283,19 +283,6 @@ DEFINE_PRIMITIVE(resize_byte_array)
dpush(tag_object(reallot_byte_array(array,capacity)));
}
F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
{
if(*result_count == byte_array_capacity(result))
{
result = reallot_byte_array(result,*result_count * 2);
}
bput(BREF(result,*result_count),elt);
*result_count++;
return result;
}
F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
{
CELL new_size = *result_count + len;

View File

@ -212,11 +212,6 @@ F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_coun
CELL result##_count = 0; \
CELL result = tag_object(allot_byte_array(100))
F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \