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

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

db4
Matthew Willis 2008-06-01 10:36:55 -07:00
parent 53952c3200 e8be61ece5
commit a3eb649fd6
38 changed files with 785 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/alien/compiler/compiler.factor
View File

@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
;
init ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
@ -336,7 +336,7 @@ M: #alien-indirect generate-node
! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks
callbacks global [ H{ } assoc-like ] change-at
[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ;
@ -344,7 +344,7 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
recursive-state get infer-quot ;
\ alien-callback [
@ -354,7 +354,7 @@ M: alien-callback-error summary
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>return
gensym dup register-callback >>xt
gensym >>xt
callback-bottom
] "infer" set-word-prop

2
core/alien/structs/structs-docs.factor
View File

@ -91,6 +91,6 @@ $nl
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;

5
core/generator/fixup/fixup-docs.factor
View File

@ -1,5 +1,6 @@
USING: help.syntax help.markup generator.fixup math kernel
words strings alien byte-array ;
USING: help.syntax help.markup math kernel
words strings alien ;
IN: generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }

6
extra/bunny/model/model.factor
View File

@ -35,10 +35,8 @@ IN: bunny.model
[ normalize ] map ;
: read-model ( stream -- model )
"Reading model" print flush [
ascii [ parse-model ] with-file-reader
[ normals ] 2keep 3array
] time ;
ascii [ parse-model ] with-file-reader
[ normals ] 2keep 3array ;
: model-path "bun_zipper.ply" temp-file ;

2
extra/combinators/lib/lib.factor
View File

@ -90,7 +90,7 @@ MACRO: 2|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
MACRO: 3|| ( quots -- ? )
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
[ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte

25
extra/db/db.factor
View File

@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
SINGLETON: throwable
SINGLETON: nonthrowable
: make-throwable ( obj -- obj' )
dup sequence? [
[ make-throwable ] map
] [
throwable >>type
] if ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
nonthrowable >>type
] if ;
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
new
swap >>out-params
swap >>in-params
swap >>sql
throwable >>type ;
swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? )
GENERIC: execute-statement* ( statement type -- )
M: throwable execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- )
drop query-results dispose ;
M: nonthrowable execute-statement* ( statement type -- )
drop [ query-results dispose ] [ 2drop ] recover ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each

11
extra/db/errors/errors.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
IN: db.errors
ERROR: db-error ;
ERROR: sql-error ;
ERROR: table-exists ;
ERROR: bad-schema ;

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

@ -175,7 +175,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
"drop table " 0% 0% drop
] query-make ;
M: postgresql-db drop-sql-statement ( class -- seq )

45
extra/db/queries/queries.factor
View File

@ -1,21 +1,19 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
strings
math.bitfields.lib namespaces.lib db db.tuples db.types
math.intervals ;
strings math.parser math.intervals combinators
math.bitfields.lib namespaces.lib db db.tuples db.types ;
IN: db.queries
GENERIC: where ( specs obj -- )
: maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains? [
make-retryable
] when ;
dup in-params>> [ generator-bind? ] contains?
[ make-retryable ] when ;
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
@ -127,3 +125,36 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
" from " 0% 0%
where-clause
] query-make ;
: do-group ( tuple groups -- )
[
", " join " group by " prepend append
] curry change-sql drop ;
: do-order ( tuple order -- )
[
", " join " order by " prepend append
] curry change-sql drop ;
: do-offset ( tuple n -- )
[
number>string " offset " prepend append
] curry change-sql drop ;
: do-limit ( tuple n -- )
[
number>string " limit " prepend append
] curry change-sql drop ;
: make-advanced-statement ( tuple advanced -- tuple' )
dupd
{
[ group>> [ do-group ] [ drop ] if* ]
[ order>> [ do-order ] [ drop ] if* ]
[ 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 ;

8
extra/db/sql/sql-tests.factor
View File

@ -4,9 +4,11 @@ IN: db.sql.tests
! TUPLE: person name age ;
: insert-1
{ insert
{ table "person" }
{ columns "name" "age" }
{ values "erg" 26 }
{
{ table "person" }
{ columns "name" "age" }
{ values "erg" 26 }
}
} ;
: update-1

32
extra/db/sqlite/lib/lib.factor
View File

@ -4,24 +4,25 @@ 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 ;
io.backend db.errors ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
sqlite-error-messages nth throw ;
ERROR: sqlite-error < db-error n string ;
ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-statement-error-string ( -- str )
db get db-handle sqlite3_errmsg ;
: throw-sqlite-error ( n -- * )
dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
sqlite-statement-error-string throw ;
SQLITE_ERROR
db get db-handle sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
{ [ dup SQLITE_OK = ] [ drop ] }
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
[ sqlite-error ]
} cond ;
{ SQLITE_OK [ ] }
{ SQLITE_ERROR [ sqlite-statement-error ] }
[ throw-sqlite-error ]
} case ;
: sqlite-open ( path -- db )
normalize-path
@ -158,12 +159,11 @@ IN: db.sqlite.lib
dup sqlite-#columns [ sqlite-column ] with map ;
: sqlite-step-has-more-rows? ( prepared -- bool )
dup SQLITE_ROW = [
drop t
] [
dup SQLITE_DONE =
[ drop ] [ sqlite-check-result ] if f
] if ;
{
{ SQLITE_ROW [ t ] }
{ SQLITE_DONE [ f ] }
[ sqlite-check-result f ]
} case ;
: sqlite-next ( prepared -- ? )
sqlite3_step sqlite-step-has-more-rows? ;

3
extra/db/sqlite/sqlite.factor
View File

@ -16,7 +16,7 @@ M: sqlite-db make-db* ( path db -- db )
swap >>path ;
M: sqlite-db db-open ( db -- db )
[ path>> sqlite-open ] [ swap >>handle ] bi ;
dup path>> sqlite-open >>handle ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
@ -197,4 +197,3 @@ M: sqlite-db compound ( str seq -- str' )
{ "default" [ first number>string join-space ] }
[ 2drop ]
} case ;

35
extra/db/tuples/tuples-tests.factor
View File

@ -3,7 +3,8 @@
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 ;
db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
@ -198,8 +199,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-sqlite ( quot -- )
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
: test-postgresql ( -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
: test-postgresql ( quot -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
@ -224,6 +225,12 @@ TUPLE: serialize-me id data ;
TUPLE: exam id name score ;
: random-exam ( -- exam )
f
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
100 random
exam boa ;
: test-intervals ( -- )
exam "EXAM"
{
@ -415,7 +422,7 @@ TUPLE: does-not-persist ;
] test-postgresql
TUPLE: suparclass a ;
TUPLE: suparclass id a ;
suparclass f {
{ "id" "ID" +db-assigned-id+ }
@ -428,8 +435,26 @@ subbclass "SUBCLASS" {
{ "b" "B" TEXT }
} define-persistent
TUPLE: fubbclass < subbclass ;
fubbclass "FUBCLASS" { } define-persistent
: test-db-inheritance ( -- )
[ ] [ subbclass ensure-table ] unit-test ;
[ ] [ subbclass ensure-table ] unit-test
[ ] [ fubbclass ensure-table ] unit-test
[ ] [
subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
] unit-test
[ t "hi" 5 ] [
subbclass new "id" get >>id select-tuple
[ subbclass? ] [ b>> ] [ a>> ] tri
] unit-test
[ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
[ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
[ test-db-inheritance ] test-sqlite

31
extra/db/tuples/tuples.factor
View File

@ -13,10 +13,10 @@ IN: db.tuples
"db-columns" set-word-prop
"db-relations" set-word-prop ;
ERROR: not-persistent ;
ERROR: not-persistent class ;
: db-table ( class -- obj )
"db-table" word-prop [ not-persistent ] unless* ;
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- obj )
superclasses [ "db-columns" word-prop ] map concat ;
@ -42,6 +42,8 @@ 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 )
HOOK: insert-tuple* db ( tuple statement -- )
@ -74,16 +76,16 @@ M: retryable execute-statement* ( statement type -- )
[ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ;
: resulting-tuple ( row out-params -- tuple )
dup first class>> new [
: resulting-tuple ( class row out-params -- tuple )
rot class new [
[
>r slot-name>> r> set-slot-named
] curry 2each
] keep ;
: query-tuples ( statement -- seq )
: query-tuples ( exemplar-tuple statement -- seq )
[ out-params>> ] keep query-results [
[ sql-row-typed swap resulting-tuple ] with query-map
[ sql-row-typed swap resulting-tuple ] with with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
@ -110,8 +112,8 @@ M: retryable execute-statement* ( statement type -- )
: recreate-table ( class -- )
[
drop-sql-statement make-nonthrowable
[ execute-statement ] with-disposals
[ drop-sql-statement [ execute-statement ] with-disposals
] curry ignore-errors
] [ create-table ] bi ;
: ensure-table ( class -- )
@ -141,9 +143,12 @@ M: retryable execute-statement* ( statement type -- )
[ bind-tuple ] keep execute-statement
] with-disposal ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples
] with-disposal ;
: do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
: select-tuple ( tuple -- tuple/f )
dup dup class f f f 1 <advanced-select-statement>
do-select ?first ;

3
extra/db/types/types.factor
View File

@ -142,7 +142,8 @@ HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
class "slots" word-prop slot-named slot-spec-offset ;
class superclasses [ "slots" word-prop ] map concat
slot-named slot-spec-offset ;
: get-slot-named ( name obj -- value )
tuck offset-of-slot slot ;

4
extra/dns/cache/cache.factor vendored
View File

@ -80,10 +80,6 @@ SYMBOL: NX
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cache-get ( query -- rrs/f )
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;

13
extra/dns/dns.factor
View File

@ -476,3 +476,16 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: message-query ( message -- query ) question-section>> 1st ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ERROR: name-error name ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
{ [ dup peek CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;

64
extra/dns/forwarding/forwarding.factor
View File

@ -2,10 +2,12 @@
USING: kernel
combinators
vectors
sequences
io.sockets
accessors
combinators.lib
newfx
dns dns.cache ;
dns dns.cache dns.misc ;
IN: dns.forwarding
@ -17,7 +19,10 @@ IN: dns.forwarding
: socket ( -- socket ) (socket) 1st ;
: init-socket ( -- ) f 5353 <inet4> <datagram> 0 (socket) as-mutate ;
: init-socket-on-port ( port -- )
f swap <inet4> <datagram> 0 (socket) as-mutate ;
: init-socket ( -- ) 53 init-socket-on-port ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -27,30 +32,37 @@ IN: dns.forwarding
: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
: init-upstream-server ( -- )
upstream-server not
[ resolv-conf-server set-upstream-server ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 1&& <-&& ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
: query->answer/cache ( query -- rrs/NX/f )
{
{ [ dup type>> CNAME = ] [ cache-get* ] }
{
[ dup clone CNAME >>type cache-get* vector? ]
[
dup clone CNAME >>type cache-get* 1st ! query rr/cname
dup rdata>> ! query rr/cname cname
>r swap clone r> ! rr/cname query cname
>>name ! rr/cname query
query->answer/cache ! rr/cname rrs/NX/f
{
{ [ dup vector? ] [ clone push-on ] }
{ [ dup NX = ] [ nip ] }
{ [ dup f = ] [ nip ] }
}
cond
dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
[ nip ]
[
drop
dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
[ nip ]
[ ! query rrs
tuck ! rrs query rrs
1st ! rrs query rr/cname
rdata>> ! rrs query name
>r clone r> >>name ! rrs query
query->answer/cache ! rrs rrs/NX/f
dup rrs? [ append ] [ nip ] if
]
}
{ [ t ] [ cache-get* ] }
}
cond ;
if
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -88,4 +100,10 @@ IN: dns.forwarding
message->ba ! addr-spec byte-array
swap ! byte-array addr-spec
socket send
loop ;
loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: start ( -- ) init-socket init-upstream-server loop ;
MAIN: start

12
extra/dns/misc/misc.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
IN: dns.misc
: resolv-conf-servers ( -- seq )
"/etc/resolv.conf" utf8 file-lines
[ " " split ] map
[ 1st "nameserver" = ] filter
[ 2nd ] map ;
: resolv-conf-server ( -- ip ) resolv-conf-servers random ;

59
extra/dns/resolver/resolver.factor
View File

@ -6,34 +6,6 @@ IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Need to cache records even in the case of name error
: cache-message ( message -- message )
dup dup rcode>> NAME-ERROR =
[
[ question-section>> 1st ]
[ authority-section>> [ type>> SOA = ] filter random ttl>> ]
bi
cache-nx
]
[
{
[ answer-section>> cache-add-rrs ]
[ authority-section>> cache-add-rrs ]
[ additional-section>> cache-add-rrs ]
}
cleave
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Ask and cache the records
: ask* ( message -- message ) ask cache-message ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup vector? ! name result ?
[ nip 1st rdata>> ]
@ -43,26 +15,17 @@ IN: dns.resolver
: name->ip/cache ( name -- ip )
canonical/cache
dup A IN query boa cache-get ! name result
{
{
[ dup NX = ]
[ 2drop f ]
{ [ dup NX = ] [ 2drop f ] }
{ [ dup f = ] [ 2drop f ] }
{ [ t ] [ nip random rdata>> ] }
}
{
[ dup f = ]
[ 2drop f ]
}
{
[ t ]
[ nip random rdata>> ]
}
}
cond ;
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
dup CNAME IN query boa query->message ask* answer-section>>
dup CNAME IN query boa query->message ask cache-message answer-section>>
[ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ]
[ drop ]
@ -70,7 +33,7 @@ IN: dns.resolver
: name->ip/server ( name -- ip )
canonical/server
dup A IN query boa query->message ask* answer-section>>
dup A IN query boa query->message ask cache-message answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
@ -78,16 +41,6 @@ IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fully-qualified ( name -- name )
{
{ [ dup empty? ] [ "." append ] }
{ [ dup peek CHAR: . = ] [ ] }
{ [ t ] [ "." append ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: name->ip ( name -- ip )
fully-qualified
dup name->ip/cache dup

20
extra/dns/stub/stub.factor Normal file
View File

@ -0,0 +1,20 @@
USING: kernel sequences random accessors dns ;
IN: dns.stub
! Stub resolver
!
! Generally useful, but particularly when running a forwarding,
! caching, nameserver on localhost with multiple Factor instances
! querying it.
: name->ip ( name -- ip )
A IN query boa
query->message
ask
dup rcode>> NAME-ERROR =
[ message-query name>> name-error ]
[ answer-section>> [ type>> A = ] filter random rdata>> ]
if ;

8
extra/io/windows/nt/backend/backend.factor
View File

@ -64,9 +64,11 @@ M: winnt add-completion ( win32-handle -- )
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
>r drop GetLastError
[ 1array ] [ expected-io-error? ] bi
[ r> 2drop f ] [ r> resume-callback t ] if
dup [
>r drop GetLastError 1array r> resume-callback t
] [
2drop f
] if
] [
resume-callback t
] if ;

43
extra/json/reader/reader-tests.factor Normal file
View File

@ -0,0 +1,43 @@
USING: arrays json.reader kernel multiline strings tools.test ;
IN: json.reader.tests
{ f } [ "false" json> ] unit-test
{ t } [ "true" json> ] unit-test
{ json-null } [ "null" json> ] unit-test
{ 0 } [ "0" json> ] unit-test
{ 102 } [ "102" json> ] unit-test
{ -102 } [ "-102" json> ] unit-test
{ 102 } [ "+102" json> ] unit-test
{ 102.0 } [ "102.0" json> ] unit-test
{ 102.5 } [ "102.5" json> ] unit-test
{ 102.5 } [ "102.50" json> ] unit-test
{ -10250 } [ "-102.5e2" json> ] unit-test
{ -10250 } [ "-102.5E+2" json> ] unit-test
{ 10.25 } [ "1025e-2" json> ] unit-test
{ 0.125 } [ "0.125" json> ] unit-test
{ -0.125 } [ "-0.125" json> ] unit-test
{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
{ H{
{ "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
{ "prime" { 2 3 5 7 11 13 } }
} } [ <" {
"fib": [1, 1, 2, 3, 5, 8,
{ "etc":"etc" } ],
"prime":
[ 2,3, 5,7,
11,
13
] }
"> json> ] unit-test
{ 0 } [ " 0" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
{ 0 } [ " 0 " json> ] unit-test

47
extra/json/reader/reader.factor
View File

@ -7,6 +7,8 @@ IN: json.reader
! Grammar for JSON from RFC 4627
SYMBOL: json-null
: [<&>] ( quot -- quot )
{ } make unclip [ <&> ] reduce ;
@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser )
" " token
"\n" token <|>
"\r" token <|>
"\t" token <|>
"" token <|> ;
"\t" token <|> <*> ;
LAZY: spaced ( parser -- parser )
'ws' swap &> 'ws' <& ;
@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser )
"," token spaced ;
LAZY: 'false' ( -- parser )
"false" token ;
"false" token [ drop f ] <@ ;
LAZY: 'null' ( -- parser )
"null" token ;
"null" token [ drop json-null ] <@ ;
LAZY: 'true' ( -- parser )
"true" token ;
"true" token [ drop t ] <@ ;
LAZY: 'quot' ( -- parser )
"\"" token ;
LAZY: 'hex-digit' ( -- parser )
[ digit> ] satisfy [ digit> ] <@ ;
: hex-digits>ch ( digits -- ch )
0 [ swap 16 * + ] reduce ;
LAZY: 'string-char' ( -- parser )
[ quotable? ] satisfy
"\\b" token [ drop 8 ] <@ <|>
"\\t" token [ drop CHAR: \t ] <@ <|>
"\\n" token [ drop CHAR: \n ] <@ <|>
"\\f" token [ drop 12 ] <@ <|>
"\\r" token [ drop CHAR: \r ] <@ <|>
"\\\"" token [ drop CHAR: " ] <@ <|>
"\\/" token [ drop CHAR: / ] <@ <|>
"\\\\" token [ drop CHAR: \\ ] <@ <|>
"\\u" token 'hex-digit' 4 exactly-n &>
[ hex-digits>ch ] <@ <|> ;
LAZY: 'string' ( -- parser )
'quot'
[
[ quotable? ] keep
[ CHAR: \\ = or ] keep
CHAR: " = not and
] satisfy <*> &>
'string-char' <*> &>
'quot' <& [ >string ] <@ ;
DEFER: 'value'
@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser )
LAZY: 'plus' ( -- parser )
"+" token ;
LAZY: 'sign' ( -- parser )
'minus' 'plus' <|> ;
LAZY: 'zero' ( -- parser )
"0" token [ drop 0 ] <@ ;
@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser )
: sign-number ( pair -- number )
#! Pair is { minus? num }
#! Convert the json number value to a factor number
dup second swap first [ -1 * ] when ;
dup second swap first [ first "-" = [ -1 * ] when ] when* ;
LAZY: 'exp' ( -- parser )
'e'
'minus' 'plus' <|> <?> &>
'sign' <?> &>
'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
: sequence>frac ( seq -- num )
@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser )
dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
LAZY: 'number' ( -- parser )
'minus' <?>
'sign' <?>
[ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser )
'object' ,
'array' ,
'number' ,
] [<|>] ;
] [<|>] spaced ;
: json> ( string -- object )
#! Parse a json formatted string to a factor object

24
extra/logging/logging-tests.factor Normal file
View File

@ -0,0 +1,24 @@
IN: logging.tests
USING: tools.test logging math ;
: input-logging-test ( a b -- c ) + ;
\ input-logging-test NOTICE add-input-logging
: output-logging-test ( a b -- c ) + ;
\ output-logging-test DEBUG add-output-logging
: error-logging-test ( a b -- c ) / ;
\ error-logging-test ERROR add-error-logging
"logging-test" [
[ 4 ] [ 1 3 input-logging-test ] unit-test
[ 4 ] [ 1 3 output-logging-test ] unit-test
[ 4/3 ] [ 4 3 error-logging-test ] unit-test
[ f ] [ 1 0 error-logging-test ] unit-test
] with-logging

55
extra/logging/logging.factor
View File

@ -4,33 +4,26 @@ USING: logging.server sequences namespaces concurrency.messaging
words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects arrays.lib parser strings
combinators.lib quotations ;
combinators.lib quotations fry symbols accessors ;
IN: logging
SYMBOL: DEBUG
SYMBOL: NOTICE
SYMBOL: WARNING
SYMBOL: ERROR
SYMBOL: CRITICAL
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
: log-levels
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
: send-to-log-server ( array string -- )
prefix "log-server" get send ;
SYMBOL: log-service
: check-log-message
pick string?
pick word?
pick word? and and
[ "Bad parameters to log-message" throw ] unless ;
: check-log-message ( msg word level -- msg word level )
3dup [ string? ] [ word? ] [ word? ] tri* and and
[ "Bad parameters to log-message" throw ] unless ; inline
: log-message ( msg word level -- )
check-log-message
log-service get dup [
>r >r >r string-lines r> word-name r> word-name r>
[ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip
4array "log-message" send-to-log-server
] [
4drop
@ -69,7 +62,7 @@ SYMBOL: log-service
PRIVATE>
: (define-logging) ( word level quot -- )
>r >r dup r> r> 2curry annotate ;
[ dup ] 2dip 2curry annotate ;
: call-logging-quot ( quot word level -- quot' )
"called" -rot [ log-message ] 3curry prepose ;
@ -79,31 +72,30 @@ PRIVATE>
: log-stack ( n word level -- )
log-service get [
>r >r [ ndup ] keep narray stack>message
r> r> log-message
[ [ ndup ] keep narray stack>message ] 2dip log-message
] [
3drop
] if ; inline
: input# stack-effect effect-in length ;
: input# stack-effect in>> length ;
: input-logging-quot ( quot word level -- quot' )
over input# -rot [ log-stack ] 3curry prepose ;
rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;
: add-input-logging ( word level -- )
[ input-logging-quot ] (define-logging) ;
: output# stack-effect effect-out length ;
: output# stack-effect out>> length ;
: output-logging-quot ( quot word level -- quot' )
over output# -rot [ log-stack ] 3curry compose ;
[ [ output# ] keep ] dip '[ @ , , , log-stack ] ;
: add-output-logging ( word level -- )
[ output-logging-quot ] (define-logging) ;
: (log-error) ( object word level -- )
log-service get [
>r >r [ print-error ] with-string-writer r> r> log-message
[ [ print-error ] with-string-writer ] 2dip log-message
] [
2drop rethrow
] if ;
@ -112,22 +104,21 @@ PRIVATE>
: log-critical ( error word -- ) CRITICAL (log-error) ;
: stack-balancer ( effect word -- quot )
>r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry
swap effect-out length f <repetition> append >quotation ;
: stack-balancer ( effect -- quot )
[ in>> length [ ndrop ] curry ]
[ out>> length f <repetition> >quotation ]
bi append ;
: error-logging-quot ( quot word -- quot' )
[ [ log-error ] curry ] keep
[ stack-effect ] keep stack-balancer compose
[ recover ] 2curry ;
dup stack-effect stack-balancer
'[ , [ , log-error @ ] recover ] ;
: add-error-logging ( word level -- )
[ over >r input-logging-quot r> error-logging-quot ]
[ [ input-logging-quot ] 2keep drop error-logging-quot ]
(define-logging) ;
: LOG:
#! Syntax: name level
CREATE-WORD
dup scan-word
[ >r >r 1array stack>message r> r> log-message ] 2curry
CREATE-WORD dup scan-word
'[ 1array stack>message , , log-message ]
define ; parsing

8
extra/namespaces/lib/lib.factor
View File

@ -2,7 +2,7 @@
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
assocs.lib math.parser math sequences.lib locals ;
assocs.lib math.parser math sequences.lib locals mirrors ;
IN: namespaces.lib
@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- )
] with-scope
]
] ;
: make-object ( quot class -- object )
new [ <mirror> swap bind ] keep ; inline
: with-object ( object quot -- )
[ <mirror> ] dip bind ; inline

8
extra/openssl/openssl.factor
View File

@ -38,15 +38,15 @@ M: TLSv1 ssl-method drop TLSv1_method ;
OpenSSL_add_all_digests
OpenSSL_add_all_ciphers ;
SYMBOL: ssl-initiazed?
SYMBOL: ssl-initialized?
: maybe-init-ssl ( -- )
ssl-initiazed? get-global [
ssl-initialized? get-global [
init-ssl
t ssl-initiazed? set-global
t ssl-initialized? set-global
] unless ;
[ f ssl-initiazed? set-global ] "openssl" add-init-hook
[ f ssl-initialized? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < secure-context aliens ;

8
extra/tools/deploy/deploy-tests.factor
View File

@ -23,7 +23,7 @@ namespaces continuations layouts accessors ;
[ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [
cell 8 = 30 15 ? 100000 * small-enough?
cell 8 = 20 10 ? 100000 * small-enough?
] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
@ -37,6 +37,12 @@ namespaces continuations layouts accessors ;
cell 8 = 40 20 ? 100000 * small-enough?
] unit-test
[ ] [ "maze" shake-and-bake ] unit-test
[ t ] [
cell 8 = 30 15 ? 100000 * small-enough?
] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [

5
extra/tools/deploy/shaker/shaker.factor
View File

@ -108,6 +108,8 @@ IN: tools.deploy.shaker
: stripped-globals ( -- seq )
[
"callbacks" "alien.compiler" lookup ,
{
bootstrap.stage2:bootstrap-time
continuations:error
@ -142,6 +144,7 @@ IN: tools.deploy.shaker
{
gensym
name>char-hook
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
@ -167,6 +170,8 @@ IN: tools.deploy.shaker
vocabs:load-vocab-hook
word
} %
{ } { "optimizer.math.partial" } strip-vocab-globals %
] when
strip-prettyprint? [

11
extra/tools/walker/walker.factor
View File

@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models arrays accessors
generic generic.standard ;
generic generic.standard definitions ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
@ -73,6 +73,7 @@ M: object add-breakpoint ;
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
[ word-def (step-into-quot) ]
} cond ;
@ -89,7 +90,6 @@ SYMBOL: step-into
SYMBOL: step-all
SYMBOL: step-into-all
SYMBOL: step-back
SYMBOL: detach
SYMBOL: abandon
SYMBOL: call-in
@ -137,7 +137,7 @@ SYMBOL: +stopped+
{
>n ndrop >c c>
continue continue-with
stop yield suspend sleep (spawn)
stop suspend (spawn)
} [
dup [ execute break ] curry
"step-into" set-word-prop
@ -168,10 +168,7 @@ SYMBOL: +stopped+
+running+ set-status ;
: walker-stopped ( -- )
+stopped+ set-status
[ status +stopped+ eq? ]
[ [ drop f ] handle-synchronous ]
[ ] while ;
+stopped+ set-status ;
: step-into-all-loop ( -- )
+running+ set-status

1
extra/urls/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/urls/summary.txt Normal file
View File

@ -0,0 +1 @@
Tools for working with URLs (uniform resource locators)

2
extra/urls/tags.txt Normal file
View File

@ -0,0 +1,2 @@
web
network

194
extra/urls/urls-tests.factor Normal file
View File

@ -0,0 +1,194 @@
IN: urls.tests
USING: urls tools.test tuple-syntax arrays kernel assocs ;
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
[ "hello world" ] [ "hello world%" url-decode ] unit-test
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] 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
: urls
{
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
"http://www.apple.com:1234/a/path?a=b#foo"
}
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/a/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
"http://www.apple.com/a/path?a=b#foo"
}
{
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/another/fine/path"
anchor: "foo"
}
"http://www.apple.com:1234/another/fine/path#foo"
}
{
TUPLE{ url
path: "/a/relative/path"
anchor: "foo"
}
"/a/relative/path#foo"
}
{
TUPLE{ url
path: "/a/relative/path"
}
"/a/relative/path"
}
{
TUPLE{ url
path: "a/relative/path"
}
"a/relative/path"
}
} ;
urls [
[ 1array ] [ [ string>url ] curry ] bi* unit-test
] assoc-each
urls [
swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
] assoc-each
[ "b" ] [ "a" "b" url-append-path ] unit-test
[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
[ "/b" ] [ "a" "/b" url-append-path ] unit-test
[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/foo"
}
TUPLE{ url
path: "/a/path"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
port: 1234
path: "/a/path/"
}
TUPLE{ url
path: "relative/path"
query: H{ { "a" "b" } }
anchor: "foo"
}
derive-url
] unit-test
[
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/baz"
}
] [
TUPLE{ url
protocol: "http"
host: "www.apple.com"
path: "/xxx/bar"
}
TUPLE{ url
path: "baz"
}
derive-url
] unit-test

160
extra/urls/urls.factor Normal file
View File

@ -0,0 +1,160 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel unicode.categories combinators sequences splitting
fry namespaces assocs arrays strings mirrors
io.encodings.string io.encodings.utf8
math math.parser accessors namespaces.lib ;
IN: urls
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
{ [ dup "/_-.:" member? ] [ t ] }
[ f ]
} cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] [
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
2drop
] [
2dup nth dup CHAR: % = [
drop url-decode-%
] [
url-decode-+-or-other
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
: 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 H{ } clone [
[
[ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
] when ;
: assoc>query ( hash -- str )
[
{
{ [ dup number? ] [ number>string 1array ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
] assoc-map
[
[
[ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: url protocol host port path query anchor ;
: query-param ( request key -- value )
swap query>> at ;
: set-query-param ( request value key -- request )
pick query>> set-at ;
: parse-host ( string -- host port )
":" split1 [ url-decode ] [
dup [
string>number
dup [ "Invalid port" throw ] unless
] when
] bi* ;
: parse-host-part ( protocol rest -- string' )
[ "protocol" set ] [
"//" ?head [ "Invalid URL" throw ] unless
"/" split1 [
parse-host [ "host" set ] [ "port" set ] bi*
] [ "/" prepend ] bi*
] bi* ;
: string>url ( string -- url )
[
":" split1 [ parse-host-part ] when*
"#" split1 [
"?" split1 [ query>assoc "query" set ] when*
url-decode "path" set
] [
url-decode "anchor" set
] bi*
] url make-object ;
: unparse-host-part ( protocol -- )
%
"://" %
"host" get url-encode %
"port" get [ ":" % # ] when*
"path" get "/" head? [ "Invalid URL" throw ] unless ;
: url>string ( url -- string )
[
<mirror> [
"protocol" get [ unparse-host-part ] when*
"path" get url-encode %
"query" get [ "?" % assoc>query % ] when*
"anchor" get [ "#" % url-encode % ] when*
] bind
] "" make ;
: url-append-path ( path1 path2 -- path )
{
{ [ dup "/" head? ] [ nip ] }
{ [ dup empty? ] [ drop ] }
{ [ over "/" tail? ] [ append ] }
{ [ "/" pick start not ] [ nip ] }
[ [ "/" last-split1 drop "/" ] dip 3append ]
} cond ;
: derive-url ( base url -- url' )
[ clone dup ] dip
2dup [ path>> ] bi@ url-append-path
[ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
>>path ;
: relative-url ( url -- url' )
clone f >>protocol f >>host f >>port ;

76
extra/webapps/pastebin/pastebin.factor
View File

@ -15,18 +15,22 @@ IN: webapps.pastebin
! DOMAIN MODEL
! ! !
TUPLE: paste id summary author mode date contents annotations ;
TUPLE: entity id summary author mode date contents ;
\ paste "PASTE"
entity f
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
{ "date" "DATE" DATETIME +not-null+ , }
{ "date" "DATE" DATETIME +not-null+ }
{ "contents" "CONTENTS" TEXT +not-null+ }
} define-persistent
TUPLE: paste < entity annotations ;
\ paste "PASTES" { } define-persistent
: <paste> ( id -- paste )
\ paste new
swap >>id ;
@ -34,23 +38,17 @@ TUPLE: paste id summary author mode date contents annotations ;
: pastes ( -- pastes )
f <paste> select-tuples ;
TUPLE: annotation aid id summary author mode contents date ;
TUPLE: annotation < entity parent ;
annotation "ANNOTATION"
annotation "ANNOTATIONS"
{
{ "aid" "AID" INTEGER +db-assigned-id+ }
{ "id" "ID" INTEGER +not-null+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
{ "date" "DATE" DATETIME +not-null+ }
{ "contents" "CONTENTS" TEXT +not-null+ }
{ "parent" "PARENT" INTEGER +not-null+ }
} define-persistent
: <annotation> ( id aid -- annotation )
: <annotation> ( parent id -- annotation )
annotation new
swap >>aid
swap >>id ;
swap >>id
swap >>parent ;
: fetch-annotations ( paste -- paste )
dup annotations>> [
@ -76,8 +74,8 @@ M: paste entity-link
id>> "id" associate "$pastebin/paste" swap link>string ;
M: annotation entity-link
[ id>> "id" associate "$pastebin/paste" swap link>string ]
[ aid>> number>string "#" prepend ] bi
[ parent>> "parent" associate "$pastebin/paste" swap link>string ]
[ id>> number>string "#" prepend ] bi
append ;
: pastebin-template ( name -- template )
@ -147,7 +145,7 @@ M: annotation entity-link
[ validate-integer-id ] >>init
[ "id" value paste annotations>> paste-feed ] >>feed ;
: validate-paste ( -- )
: validate-entity ( -- )
{
{ "summary" [ v-one-line ] }
{ "author" [ v-one-line ] }
@ -156,7 +154,7 @@ M: annotation entity-link
{ "captcha" [ v-captcha ] }
} validate-params ;
: deposit-paste-slots ( tuple -- )
: deposit-entity-slots ( tuple -- )
now >>date
{ "summary" "author" "mode" "contents" } deposit-slots ;
@ -170,10 +168,10 @@ M: annotation entity-link
"new-paste" pastebin-template >>template
[
validate-paste
validate-entity
f <paste>
[ deposit-paste-slots ]
[ deposit-entity-slots ]
[ insert-tuple ]
[ id>> "$pastebin/paste" <id-redirect> ]
tri
@ -195,31 +193,35 @@ M: annotation entity-link
: <new-annotation-action> ( -- action )
<page-action>
[ validate-paste ] >>validate
[ "id" param "$pastebin/paste" <id-redirect> ] >>display
[
{ { "id" [ v-integer ] } } validate-params
"id" value "$pastebin/paste" <id-redirect>
] >>display
[
f f <annotation>
{
[ deposit-paste-slots ]
[ { "id" } deposit-slots ]
[ insert-tuple ]
[
! Add anchor here
id>> "$pastebin/paste" <id-redirect>
]
} cleave
{ { "id" [ v-integer ] } } validate-params
validate-entity
] >>validate
[
"id" value f <annotation>
[ deposit-entity-slots ]
[ insert-tuple ]
[
! Add anchor here
parent>> "$pastebin/paste" <id-redirect>
]
tri
] >>submit ;
: <delete-annotation-action> ( -- action )
<action>
[ { { "aid" [ v-number ] } } validate-params ] >>validate
[ { { "id" [ v-number ] } } validate-params ] >>validate
[
f "aid" value <annotation> select-tuple
f "id" value <annotation> select-tuple
[ delete-tuples ]
[ id>> "$pastebin/paste" <id-redirect> ]
[ parent>> "$pastebin/paste" <id-redirect> ]
bi
] >>submit ;

11
vm/profiler.c
View File

@ -11,11 +11,12 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
CELL code = array_nth(quadruple,0);
REGISTER_ROOT(code);
CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
| (to_fixnum(array_nth(quadruple,1)) << 8));
CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
F_REL rel;
rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
CELL relocation = allot_array_2(rel_type,rel_offset);
F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
@ -24,7 +25,7 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
WORD_TYPE,
untag_object(code),
NULL, /* no labels */
untag_object(relocation),
tag_object(relocation),
untag_object(literals));
}