[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
-: c-bool> ( int -- ? )
- 0 = not ; inline
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
"uchar" define-primitive-type
<c-type>
- [ alien-unsigned-1 zero? not ] >>getter
- [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+ [ alien-unsigned-1 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test
-[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
+[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
- NSAutoreleasePool -> new slip -> release ; inline
+ NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
: NSApp ( -- app ) NSApplication -> sharedApplication ;
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
- '[ _ call _ execute ] ;
+ 1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline
: do-callback ( quot token -- )
init-catchstack
- dup 2 setenv
- slip
+ [ 2 setenv call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
] unit-test
: foobar ( quot: ( -- ) -- )
- dup slip swap [ foobar ] [ drop ] if ; inline recursive
+ [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
: impeach-node ( quot: ( node -- ) -- )
- dup slip impeach-node ; inline recursive
+ [ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
! A more complicated example
: impeach-node ( quot: ( node -- ) -- )
- dup slip impeach-node ; inline recursive
+ [ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
-alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-cpu.ppc.assembler.backend literals compiler.cfg.registers
+alien alien.accessors alien.c-types literals cpu.architecture
+cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics
-compiler.cfg.stack-frame ;
+compiler.cfg.stack-frame compiler.units ;
IN: cpu.ppc
! PowerPC register assignments:
} cond
"complex-double" c-type t >>return-in-registers? drop
-"bool" c-type 4 >>size 4 >>align drop
\ No newline at end of file
+
+[
+ <c-type>
+ [ alien-unsigned-4 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
+ "bool" define-primitive-type
+] with-compilation-unit
"Here are some built-in combinators rewritten in terms of fried quotations:"\r
{ $table\r
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
- { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }\r
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }\r
}\r
} ;\r
\r
-HELP: nslip\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link slip } " that can work " \r
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "\r
-"removed from the stack, the quotation called, and the items restored."\r
-} \r
-{ $examples\r
- { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }\r
- "Some core words expressed in terms of " { $link nslip } ":"\r
- { $table\r
- { { $link slip } { $snippet "1 nslip" } }\r
- { { $link 2slip } { $snippet "2 nslip" } }\r
- { { $link 3slip } { $snippet "3 nslip" } }\r
- }\r
-} ;\r
-\r
HELP: nkeep\r
{ $values { "quot" quotation } { "n" integer } }\r
{ $description "A generalization of " { $link keep } " that can work " \r
\r
ARTICLE: "combinator-generalizations" "Generalized combinators"\r
{ $subsection ndip }\r
-{ $subsection nslip }\r
{ $subsection nkeep }\r
{ $subsection napply }\r
{ $subsection ncleave }\r
[ [ 1 ] 5 ndip ] must-infer\r
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
\r
-[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer\r
-{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test\r
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test\r
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
MACRO: ndip ( quot n -- )
[ '[ _ dip ] ] times ;
-MACRO: nslip ( n -- )
- '[ [ call ] _ ndip ] ;
-
MACRO: nkeep ( quot n -- )
tuck '[ _ ndup _ _ ndip ] ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations sequences ;
IN: io.directories.search
HELP: each-file
}
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+HELP: find-by-extension
+{ $values
+ { "path" "a pathname string" } { "extension" "a file extension" }
+ { "seq" sequence }
+}
+{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
+{ $examples
+ { $unchecked-example
+ "USING: io.directories.search ;"
+ "\"/\" \".mp3\" find-by-extension"
+ }
+} ;
+
+HELP: find-by-extensions
+{ $values
+ { "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
+ { "seq" sequence }
+}
+{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
+{ $examples
+ { $unchecked-example
+ "USING: io.directories.search ;"
+ "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
+ }
+} ;
+
{ find-file find-all-files find-in-directories find-all-in-directories } related-words
ARTICLE: "io.directories.search" "Searching directories"
{ $subsection recursive-directory-files }
{ $subsection recursive-directory-entries }
{ $subsection each-file }
-"Finding files:"
+"Finding files by name:"
{ $subsection find-file }
{ $subsection find-all-files }
{ $subsection find-in-directories }
-{ $subsection find-all-in-directories } ;
+{ $subsection find-all-in-directories }
+"Finding files by extension:"
+{ $subsection find-by-extension }
+{ $subsection find-by-extensions } ;
ABOUT: "io.directories.search"
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
sequences system vocabs.loader locals math namespaces
-sorting assocs calendar threads io math.parser ;
+sorting assocs calendar threads io math.parser unicode.case ;
IN: io.directories.search
: qualified-directory-entries ( path -- seq )
] { } map>assoc
] with-qualified-directory-entries sort-values ;
+: find-by-extensions ( path extensions -- seq )
+ [ >lower ] map
+ '[ >lower _ [ tail? ] with any? ] find-all-files ;
+
+: find-by-extension ( path extension -- seq )
+ 1array find-by-extensions ;
+
os windows? [ "io.directories.search.windows" require ] when
try-process
] unit-test
-[ f ] [
+[ "" ] [
"cat"
"launcher-test-1" temp-file
2array
tools.test ;
IN: io.streams.string.tests
+[ "" ] [ "" [ contents ] with-string-reader ] unit-test
+
[ "line 1" CHAR: l ]
[
"line 1\nline 2\nline 3" <string-reader>
M: object infer-call*
"literal quotation" literal-expected ;
-: infer-nslip ( n -- )
- [ infer->r infer-call ] [ infer-r> ] bi ;
-
-: infer-slip ( -- ) 1 infer-nslip ;
-
-: infer-2slip ( -- ) 2 infer-nslip ;
-
-: infer-3slip ( -- ) 3 infer-nslip ;
-
: infer-ndip ( word n -- )
[ literals get ] 2dip
[ '[ _ def>> infer-quot-here ] ]
{ \ declare [ infer-declare ] }
{ \ call [ infer-call ] }
{ \ (call) [ infer-call ] }
- { \ slip [ infer-slip ] }
- { \ 2slip [ infer-2slip ] }
- { \ 3slip [ infer-3slip ] }
{ \ dip [ infer-dip ] }
{ \ 2dip [ infer-2dip ] }
{ \ 3dip [ infer-3dip ] }
"local-word-def" word-prop infer-quot-here ;
{
- declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
+ declare call (call) dip 2dip 3dip curry compose
execute (execute) call-effect-unsafe execute-effect-unsafe if
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
over [
2drop
] [
- [ swap slip ] keep swap bad-combinator
+ [ dip ] keep swap bad-combinator
] if ; inline recursive
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
{ $heading "Behavior of " { $link POSTPONE: execute( } }
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
{ $heading "Error reporting" }
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
{ $heading "Choosing the right deploy flags" }
\r
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
+\r
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test\r
+\r
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
os macosx? [\r
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
-namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words memory kernel.private
-continuations io vocabs.loader system strings sets
-vectors quotations byte-arrays sorting compiler.units
-definitions generic generic.standard tools.deploy.config ;
+USING: arrays accessors io.backend io.streams.c init fry namespaces
+make assocs kernel parser lexer strings.parser vocabs sequences words
+memory kernel.private continuations io vocabs.loader system strings
+sets vectors quotations byte-arrays sorting compiler.units definitions
+generic generic.standard tools.deploy.config combinators classes ;
QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors
QUALIFIED: continuations
strip-word-names? [ dup strip-word-names ] when
2drop ;
+: strip-compiler-classes ( -- )
+ "Stripping compiler classes" show
+ "compiler" child-vocabs [ words ] map concat [ class? ] filter
+ [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+
: strip-default-methods ( -- )
strip-debugger? [
"Stripping default methods" show
{
gensym
name>char-hook
- classes:next-method-quot-cache
- classes:class-and-cache
- classes:class-not-cache
- classes:class-or-cache
- classes:class<=-cache
- classes:classes-intersect-cache
- classes:implementors-map
- classes:update-map
+ next-method-quot-cache
+ class-and-cache
+ class-not-cache
+ class-or-cache
+ class<=-cache
+ classes-intersect-cache
+ implementors-map
+ update-map
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
-: compress-byte-arrays ( -- )
- [ byte-array? ] [ ] "byte arrays" compress ;
+: compress-objects ( -- )
+ [
+ {
+ [ dup array? [ empty? ] [ drop f ] if ]
+ [ byte-array? ]
+ [ string? ]
+ [ wrapper? ]
+ } cleave
+ or or or
+ ] [ ] "objects" compress ;
: remain-compiled ( old new -- old new )
#! Quotations which were formerly compiled must remain
[ quotation? ] [ remain-compiled ] "quotations" compress
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
-: compress-strings ( -- )
- [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
- [ wrapper? ] [ ] "wrappers" compress ;
-
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
t "quiet" set-global
f output-stream set-global ;
+: unsafe-next-method-quot ( method -- quot )
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ next-method 1quotation ;
+
: compute-next-methods ( -- )
[ standard-generic? ] instances [
"methods" word-prop [
- nip
- dup next-method-quot "next-method-quot" set-word-prop
+ nip dup
+ unsafe-next-method-quot
+ "next-method-quot" set-word-prop
] assoc-each
] each
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
: strip ( -- )
init-stripper
- strip-default-methods
strip-libc
strip-call
strip-cocoa
compute-next-methods
strip-init-hooks
strip-c-io
+ strip-compiler-classes
+ strip-default-methods
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-boot-quot
stripped-word-props
stripped-globals strip-globals
- compress-byte-arrays
+ compress-objects
compress-quotations
- compress-strings
- compress-wrappers
strip-words ;
: deploy-error-handler ( quot -- )
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
[ get values compile ] each
] bind
] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc
\ No newline at end of file
GetDoubleClickTime milliseconds double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
- class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
- msg-obj get-global [ free ] when*
- f class-name-ptr set-global
- f msg-obj set-global ;
+ class-name-ptr [
+ [ [ f UnregisterClass drop ] [ free ] bi ] when* f
+ ] change-global
+ msg-obj change-global [ [ free ] when* f ] ;
-: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
+: get-dc ( world -- )
+ handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
: get-rc ( world -- )
handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
[ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
: set-pixel-format ( pixel-format hdc -- )
- swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
+ swap handle>>
+ "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
: setup-gl ( world -- )
[ get-dc ] keep
M: windows-ui-backend (grab-input) ( handle -- )
0 ShowCursor drop
hWnd>> client-area>RECT ClipCursor drop ;
+
M: windows-ui-backend (ungrab-input) ( handle -- )
drop
f ClipCursor drop
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.pixel-formats destructors literals ;
IN: ui.gadgets.worlds
CONSTANT: default-world-pixel-format-attributes
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
-unicode.categories combinators.short-circuit ;
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
+combinators.short-circuit ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
M: macosx modifiers>string
[
{
- { A+ [ "\u{place-of-interest-sign}" ] }
- { M+ [ "\u{option-key}" ] }
- { S+ [ "\u{upwards-white-arrow}" ] }
- { C+ [ "\u{up-arrowhead}" ] }
+ { A+ [ "\u002318" ] }
+ { M+ [ "\u002325" ] }
+ { S+ [ "\u0021e7" ] }
+ { C+ [ "\u002303" ] }
} case
] map "" join ;
USING: accessors assocs classes destructors functors kernel
lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
IN: ui.pixel-formats
SYMBOLS:
M: object >PFA
drop { } ;
-M: symbol >PFA
+M: word >PFA
TABLE at [ { } ] unless* ;
M: pixel-format-attribute >PFA
dup class TABLE at
USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
] if ;
: parse-host ( string -- host port )
- ":" split1 [ url-decode ] [
- dup [
- string>number
- dup [ "Invalid port" throw ] unless
- ] when
- ] bi* ;
+ [
+ ":" split1 [ url-decode ] [
+ dup [
+ string>number
+ dup [ "Invalid port" throw ] unless
+ ] when
+ ] bi*
+ ] [ f f ] if* ;
GENERIC: >url ( obj -- url )
IUnknown::Release drop ; inline\r
\r
: with-com-interface ( interface quot -- )\r
- over [ slip ] [ com-release ] [ ] cleanup ; inline\r
+ over [ com-release ] curry [ ] cleanup ; inline\r
\r
DESTRUCTOR: com-release\r
: compile-alien-callback ( word return parameters abi quot -- word )
'[ _ _ _ _ alien-callback ]
- [ [ (( -- alien )) define-declared ] pick slip ]
+ [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
with-compilation-unit ;
: (callback-word) ( function-name interface-name counter -- word )
<PRIVATE
: call-under ( quot object -- quot )
- swap dup slip ; inline
+ swap [ call ] keep ; inline
: xml-loop ( quot: ( xml-elem -- ) -- )
parse-text call-under
": dip [ ] bi* ;"
": 2dip [ ] [ ] tri* ;"
""
- ": slip [ call ] [ ] bi* ;"
- ": 2slip [ call ] [ ] [ ] tri* ;"
- ""
": nip [ drop ] [ ] bi* ;"
": 2nip [ drop ] [ drop ] [ ] tri* ;"
""
{ $subsection both? }
{ $subsection either? } ;
-ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+ARTICLE: "retainstack-combinators" "Retain stack combinators"
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
$nl
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection 2dip }
{ $subsection 3dip }
{ $subsection 4dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
{ $subsection keep }
{ $subsection 2keep }
ARTICLE: "dataflow-combinators" "Data flow combinators"
"Data flow combinators pass values between quotations:"
-{ $subsection "slip-keep-combinators" }
+{ $subsection "retainstack-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
HELP: stream-contents
-{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." }
+{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
HELP: contents
-{ $values { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
+{ $values { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
$io-error ;
ARTICLE: "stream-protocol" "Stream protocol"
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
-continuations destructors assocs ;
+continuations destructors assocs combinators ;
IN: io
SYMBOLS: +byte+ +character+ ;
GENERIC: stream-nl ( stream -- )
ERROR: bad-seek-type type ;
+
SINGLETONS: seek-absolute seek-relative seek-end ;
+
GENERIC: stream-seek ( n seek-type stream -- )
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
: bl ( -- ) " " write ;
-: stream-lines ( stream -- seq )
- [ [ readln dup ] [ ] produce nip ] with-input-stream ;
-
-: lines ( -- seq )
- input-stream get stream-lines ;
-
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap while drop ; inline
+: stream-element-exemplar ( type -- exemplar )
+ {
+ { +byte+ [ B{ } ] }
+ { +character+ [ "" ] }
+ } case ;
+
+: element-exemplar ( -- exemplar )
+ input-stream get
+ stream-element-type
+ stream-element-exemplar ;
+
PRIVATE>
: each-line ( quot -- )
[ readln ] each-morsel ; inline
-: stream-contents ( stream -- seq )
- [
- [ 65536 read-partial dup ] [ ] produce nip concat f like
- ] with-input-stream ;
+: lines ( -- seq )
+ [ ] accumulator [ each-line ] dip { } like ;
+
+: stream-lines ( stream -- seq )
+ [ lines ] with-input-stream ;
: contents ( -- seq )
- input-stream get stream-contents ;
+ [ 65536 read-partial dup ] [ ] produce nip
+ element-exemplar concat-as ;
+
+: stream-contents ( stream -- seq )
+ [ contents ] with-input-stream ;
: each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline
USING: tools.test io.streams.byte-array io.encodings.binary
io.encodings.utf8 io kernel arrays strings namespaces ;
+[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
{ $notes "Used to implement " { $link "threads" } "." } ;
-HELP: slip
-{ $values { "quot" quotation } { "x" object } }
-{ $description "Calls a quotation while hiding the top of the stack." } ;
-
-HELP: 2slip
-{ $values { "quot" quotation } { "x" object } { "y" object } }
-{ $description "Calls a quotation while hiding the top two stack elements." } ;
-
-HELP: 3slip
-{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } }
-{ $description "Calls a quotation while hiding the top three stack elements." } ;
-
HELP: keep
{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
[ 2 ] [ f 2 xor ] unit-test
[ f ] [ f f xor ] unit-test
-[ slip ] must-fail
+[ dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 slip ] must-fail
+[ 1 [ call ] dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 2 slip ] must-fail
+[ 1 2 [ call ] dip ] must-fail
[ ] [ :c ] unit-test
-[ 1 2 3 slip ] must-fail
-[ ] [ :c ] unit-test
-
-
-[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
+[ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test
[ [ ] keep ] must-fail
: ?if ( default cond true false -- )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
-! Slippers and dippers.
+! Dippers.
! Not declared inline because the compiler special-cases them
-: slip ( quot x -- x )
- #! 'slip' and 'dip' can be defined in terms of each other
- #! because the JIT special-cases a 'dip' preceeded by
- #! a literal quotation.
- [ call ] dip ;
+: dip ( x quot -- x ) swap [ call ] dip ;
-: 2slip ( quot x y -- x y )
- #! '2slip' and '2dip' can be defined in terms of each other
- #! because the JIT special-cases a '2dip' preceeded by
- #! a literal quotation.
- [ call ] 2dip ;
+: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ;
-: 3slip ( quot x y z -- x y z )
- #! '3slip' and '3dip' can be defined in terms of each other
- #! because the JIT special-cases a '3dip' preceeded by
- #! a literal quotation.
- [ call ] 3dip ;
-
-: dip ( x quot -- x ) swap slip ;
-
-: 2dip ( x y quot -- x y ) -rot 2slip ;
-
-: 3dip ( x y z quot -- x y z ) -roll 3slip ;
+: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ;
: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
! Keepers
-: keep ( x quot -- x ) over slip ; inline
+: keep ( x quot -- x ) over [ call ] dip ; inline
: 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline
M: curry call uncurry call ;
-M: compose call uncompose slip call ;
+M: compose call uncompose [ call ] dip call ;
M: wrapper equal?
over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
{ $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." }
{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ;
+HELP: concat-as
+{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } }
+{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." }
+{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ;
+
HELP: join
{ $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } }
{ $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." }
+{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." }
{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ;
-{ join concat } related-words
+{ join concat concat-as } related-words
HELP: peek
{ $values { "seq" sequence } { "elt" object } }
: sum-lengths ( seq -- n )
0 [ length + ] reduce ;
+: concat-as ( seq exemplar -- newseq )
+ swap [ { } ] [
+ [ sum-lengths over new-resizable ] keep
+ [ over push-all ] each
+ ] if-empty swap like ;
+
: concat ( seq -- newseq )
- [ { } ] [
- [ sum-lengths ] keep
- [ first new-resizable ] keep
- [ [ over push-all ] each ] keep
- first like
- ] if-empty ;
+ [ { } ] [ dup first concat-as ] if-empty ;
<PRIVATE
PRIVATE>
: join ( seq glue -- newseq )
- [
- 2dup joined-length over new-resizable [
- [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
- interleave
- ] keep
- ] keep like ;
+ dup empty? [ concat-as ] [
+ [
+ 2dup joined-length over new-resizable [
+ [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+ interleave
+ ] keep
+ ] keep like
+ ] if ;
: padding ( seq n elt quot -- newseq )
[
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.primes.miller-rabin kernel math math.functions
-namespaces sequences accessors ;
+USING: math.primes kernel math math.functions namespaces
+sequences accessors ;
IN: crypto.rsa
! The private key is the only secret.
CONSTANT: public-key 65537
: rsa-primes ( numbits -- p q )
- 2/ 2 unique-primes first2 ;
+ 2/ 2 swap unique-primes first2 ;
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: crypto.timing kernel tools.test system math ;
-IN: crypto.timing.tests
-
-[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math threads system calendar ;
-IN: crypto.timing
-
-: with-timing ( quot n -- )
- #! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + milliseconds sleep ; inline
--- /dev/null
+Diego Martinelli
--- /dev/null
+USING: help.markup help.syntax kernel math ;
+IN: hashcash
+
+ARTICLE: "hashcash" "Hashcash"
+"Hashcash is a denial-of-service counter measure tool."
+$nl
+"A hashcash stamp constitutes a proof-of-work which takes a parameterizable amount of work to compute for the sender. The recipient can verify received hashcash stamps efficiently."
+$nl
+"More info on hashcash:"
+$nl
+{ $url "http://www.hashcash.org/" } $nl
+{ $url "http://en.wikipedia.org/wiki/Hashcash" } $nl
+{ $url "http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash" } $nl
+"This library provide basic utilities for hashcash creation and validation."
+$nl
+"Creating stamps:"
+{ $subsection mint }
+{ $subsection mint* }
+"Validation:"
+{ $subsection check-stamp }
+"Hashcash tuple and constructor:"
+{ $subsection hashcash }
+{ $subsection <hashcash> }
+"Utilities:"
+{ $subsection salt } ;
+
+{ mint mint* <hashcash> check-stamp salt } related-words
+
+HELP: mint
+{ $values { "resource" "a string" } { "stamp" "generated stamp" } }
+{ $description "This word generate a valid stamp with default parameters and the specified resource." } ;
+
+HELP: mint*
+{ $values { "tuple" "a tuple" } { "stamp" "generated stamp" } }
+{ $description "As " { $snippet "mint" } " but it takes an hashcash tuple as a parameter." } ;
+
+HELP: check-stamp
+{ $values { "stamp" "a string" } { "?" boolean } }
+{ $description "Check for stamp's validity. Only supports hashcash version 1." } ;
+
+HELP: salt
+{ $values { "length" integer } { "salted" "a string" } }
+{ $description "It generates a random string of " { $snippet "length" } " characters." } ;
+
+HELP: <hashcash>
+{ $values { "tuple" object } }
+{ $description "It fill an hashcash tuple with the default values: 1 as hashcash version, 20 as bits, today's date as date and a random 8 character long salt" } ;
+
+HELP: hashcash
+{ $class-description "An hashcash object. An hashcash have the following slots:"
+ { $table
+ { { $slot "version" } "The version number. Only version 1 is supported." }
+ { { $slot "bits" } "The claimed bit value." }
+ { { $slot "date" } "The date a stamp was minted." }
+ { { $slot "resource" } "The resource for which a stamp is minted." }
+ { { $slot "ext" } "Extensions that a specialized application may want." }
+ { { $slot "salt" } "A random salt." }
+ { { $slot "suffix" } "The computed suffix. This is supposed to be manipulated by the library." }
+ }
+} ;
--- /dev/null
+USING: accessors sequences tools.test hashcash ;
+
+[ t ] [ "foo@bar.com" mint check-stamp ] unit-test
+
+[ t ] [
+ <hashcash>
+ "foo@bar.com" >>resource
+ 16 >>bits
+ mint* check-stamp ] unit-test
+
+[ t ] [
+ "1:20:040927:mertz@gnosis.cx::odVZhQMP:7ca28" check-stamp
+] unit-test
+
+[ 8 ] [ 8 salt length ] unit-test
--- /dev/null
+! Copyright (C) 2009 Diego Martinelli.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays calendar calendar.format
+checksums checksums.openssl classes.tuple
+fry kernel make math math.functions math.parser math.ranges
+present random sequences splitting strings syntax ;
+IN: hashcash
+
+! Hashcash implementation
+! Reference materials listed below:
+!
+! http://hashcash.org
+! http://en.wikipedia.org/wiki/Hashcash
+! http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash
+!
+! And the reference implementation (in python):
+! http://www.gnosis.cx/download/gnosis/util/hashcash.py
+
+<PRIVATE
+
+! Return a string with today's date in the form YYMMDD
+: get-date ( -- str )
+ now [ year>> 100 mod pad-00 ]
+ [ month>> pad-00 ]
+ [ day>> pad-00 ] tri 3append ;
+
+! Random salt is formed by ascii characters
+! between 33 and 126
+: available-chars ( -- seq )
+ 33 126 [a,b] [ CHAR: : = not ] filter ;
+
+PRIVATE>
+
+! Generate a 'length' long random salt
+: salt ( length -- salted )
+ available-chars '[ _ random ] "" replicate-as ;
+
+TUPLE: hashcash version bits date resource ext salt suffix ;
+
+: <hashcash> ( -- tuple )
+ hashcash new
+ 1 >>version
+ 20 >>bits
+ get-date >>date
+ 8 salt >>salt ;
+
+M: hashcash string>>
+ tuple-slots [ present ] map ":" join ;
+
+<PRIVATE
+
+: sha1-checksum ( str -- bytes )
+ openssl-sha1 checksum-bytes ; inline
+
+: set-suffix ( tuple guess -- tuple )
+ >hex >>suffix ;
+
+: get-bits ( bytes -- str )
+ [ >bin 8 CHAR: 0 pad-head ] { } map-as concat ;
+
+: checksummed-bits ( tuple -- relevant-bits )
+ dup string>> sha1-checksum
+ swap bits>> 8 / ceiling head get-bits ;
+
+: all-char-zero? ( seq -- ? )
+ [ CHAR: 0 = ] all? ; inline
+
+: valid-guess? ( checksum tuple -- ? )
+ bits>> head all-char-zero? ;
+
+: (mint) ( tuple counter -- tuple )
+ 2dup set-suffix checksummed-bits pick
+ valid-guess? [ drop ] [ 1+ (mint) ] if ;
+
+PRIVATE>
+
+: mint* ( tuple -- stamp )
+ 0 (mint) string>> ;
+
+: mint ( resource -- stamp )
+ <hashcash>
+ swap >>resource
+ mint* ;
+
+! One might wanna add check based on the date,
+! passing a 'good-until' duration param
+: check-stamp ( stamp -- ? )
+ dup ":" split [ sha1-checksum get-bits ] dip
+ second string>number head all-char-zero? ;
+
--- /dev/null
+Hashcash implementation
: genre ( id3 -- string/f )
"TCON" find-id3-frame parse-genre ;
-: find-mp3s ( path -- seq )
- [ >lower ".mp3" tail? ] find-all-files ;
+: find-mp3s ( path -- seq ) ".mp3" find-by-extension ;
ERROR: id3-parse-error path error ;
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals system debugger fry
-continuations ;
+continuations strings ;
IN: mason.common
SYMBOL: current-git-id
-ERROR: output-process-error output process ;
+ERROR: output-process-error { output string } { process process } ;
M: output-process-error error.
[ "Process:" print process>> . nl ]
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io io.sockets io.encodings.utf8 io.files
io.launcher kernel make mason.config mason.common mason.email
-mason.twitter namespaces sequences prettyprint ;
+mason.twitter namespaces sequences prettyprint fry ;
IN: mason.notify
: status-notify ( input-file args -- )
target-cpu get ,
target-os get ,
] { } make prepend
- <process>
- swap >>command
- swap [ +closed+ ] unless* >>stdin
- try-output-process
+ [ 5 ] 2dip '[
+ <process>
+ _ >>command
+ _ [ +closed+ ] unless* >>stdin
+ try-output-process
+ ] retry
] [ 2drop ] if ;
: notify-begin-build ( git-id -- )
-USING: kernel math sequences namespaces
-math.primes.miller-rabin math.functions accessors random ;
+USING: kernel math sequences namespaces math.primes
+math.functions accessors random ;
IN: random.blum-blum-shub
! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.command-writer io.streams.string ;
+IN: redis.command-writer.tests
+
+#! Connection
+[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test
+
+[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test
+
+[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test
+
+#! String values
+[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test
+
+[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test
+
+[ "GETSET key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" getset ] with-string-writer
+] unit-test
+
+[ "MGET key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } mget ] with-string-writer
+] unit-test
+
+[ "SETNX key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" setnx ] with-string-writer
+] unit-test
+
+[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test
+
+[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test
+
+[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test
+
+[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test
+
+[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test
+
+[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test
+
+[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test
+
+#! Key space
+[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test
+
+[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test
+
+[ "RENAME key newkey\r\n" ] [
+ [ "newkey" "key" rename ] with-string-writer
+] unit-test
+
+[ "RENAMENX key newkey\r\n" ] [
+ [ "newkey" "key" renamenx ] with-string-writer
+] unit-test
+
+[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test
+
+[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test
+
+#! Lists
+[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test
+
+[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test
+
+[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test
+
+[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test
+
+[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
+
+[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test
+
+[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
+
+[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
+
+[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test
+
+[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test
+
+#! Sets
+[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test
+
+[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test
+
+[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [
+ [ "foo" "dstkey" "srckey" smove ] with-string-writer
+] unit-test
+
+[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test
+
+[ "SISMEMBER key 3\r\nfoo\r\n" ] [
+ [ "foo" "key" sismember ] with-string-writer
+] unit-test
+
+[ "SINTER key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } sinter ] with-string-writer
+] unit-test
+
+[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer
+] unit-test
+
+[ "SUNION key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } sunion ] with-string-writer
+] unit-test
+
+[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [
+ [ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer
+] unit-test
+
+[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test
+
+#! Multiple db
+[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test
+
+[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test
+
+[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test
+
+[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test
+
+#! Sorting
+
+#! Persistence control
+[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test
+
+[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test
+
+[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test
+
+[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test
+
+#! Remote server control
+[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test
+
+[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.crlf kernel math.parser sequences strings interpolate locals ;
+IN: redis.command-writer
+
+<PRIVATE
+
+GENERIC: write-value-with-length ( value -- )
+
+M: string write-value-with-length
+ [ length number>string write crlf ]
+ [ write ] bi ;
+
+: space ( -- ) CHAR: space write1 ;
+
+: write-key/value ( value key -- )
+ write space
+ write-value-with-length ;
+
+: write-key/integer ( integer key -- )
+ write space
+ number>string write ;
+
+PRIVATE>
+
+#! Connection
+: quit ( -- ) "QUIT" write crlf ;
+: ping ( -- ) "PING" write crlf ;
+: auth ( password -- ) "AUTH " write write crlf ;
+
+#! String values
+: set ( value key -- ) "SET " write write-key/value crlf ;
+: get ( key -- ) "GET " write write crlf ;
+: getset ( value key -- ) "GETSET " write write-key/value crlf ;
+: mget ( keys -- ) "MGET " write " " join write crlf ;
+: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
+: incr ( key -- ) "INCR " write write crlf ;
+: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
+: decr ( key -- ) "DECR " write write crlf ;
+: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
+: exists ( key -- ) "EXISTS " write write crlf ;
+: del ( key -- ) "DEL " write write crlf ;
+: type ( key -- ) "TYPE " write write crlf ;
+
+#! Key space
+: keys ( pattern -- ) "KEYS " write write crlf ;
+: randomkey ( -- ) "RANDOMKEY" write crlf ;
+: rename ( newkey key -- ) "RENAME " write write space write crlf ;
+: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
+: dbsize ( -- ) "DBSIZE" write crlf ;
+: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
+
+#! Lists
+: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
+: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
+: llen ( key -- ) "LLEN " write write crlf ;
+: lrange ( start end key -- )
+ "LRANGE " write write [ space number>string write ] bi@ crlf ;
+: ltrim ( start end key -- )
+ "LTRIM " write write [ space number>string write ] bi@ crlf ;
+: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
+: lset ( value index key -- )
+ "LSET " write write-key/integer space write-value-with-length crlf ;
+: lrem ( value amount key -- )
+ "LREM " write write-key/integer space write-value-with-length crlf ;
+: lpop ( key -- ) "LPOP " write write crlf ;
+: rpop ( key -- ) "RPOP " write write crlf ;
+
+#! Sets
+: sadd ( member key -- )
+ "SADD " write write space write-value-with-length crlf ;
+: srem ( member key -- )
+ "SREM " write write space write-value-with-length crlf ;
+: smove ( member newkey key -- )
+ "SMOVE " write write space write space write-value-with-length crlf ;
+: scard ( key -- ) "SCARD " write write crlf ;
+: sismember ( member key -- )
+ "SISMEMBER " write write space write-value-with-length crlf ;
+: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+: sinterstore ( keys destkey -- )
+ "SINTERSTORE " write write space " " join write crlf ;
+: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+: sunionstore ( keys destkey -- )
+ "SUNIONSTORE " write write " " join space write crlf ;
+: smembers ( key -- ) "SMEMBERS " write write crlf ;
+
+#! Multiple db
+: select ( integer -- ) "SELECT " write number>string write crlf ;
+: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
+: flushdb ( -- ) "FLUSHDB" write crlf ;
+: flushall ( -- ) "FLUSHALL" write crlf ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: save ( -- ) "SAVE" write crlf ;
+: bgsave ( -- ) "BGSAVE" write crlf ;
+: lastsave ( -- ) "LASTSAVE" write crlf ;
+: shutdown ( -- ) "SHUTDOWN" write crlf ;
+
+#! Remote server control
+: info ( -- ) "INFO" write crlf ;
+: monitor ( -- ) "MONITOR" write crlf ;
--- /dev/null
+Definitions of messages sent to Redis
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io redis.response-parser redis.command-writer ;
+IN: redis
+
+#! Connection
+: redis-quit ( -- ) quit flush ;
+: redis-ping ( -- response ) ping flush read-response ;
+: redis-auth ( password -- response ) auth flush read-response ;
+
+#! String values
+: redis-set ( value key -- response ) set flush read-response ;
+: redis-get ( key -- response ) get flush read-response ;
+: redis-getset ( value key -- response ) getset flush read-response ;
+: redis-mget ( keys -- response ) mget flush read-response ;
+: redis-setnx ( value key -- response ) setnx flush read-response ;
+: redis-incr ( key -- response ) incr flush read-response ;
+: redis-incrby ( integer key -- response ) incrby flush read-response ;
+: redis-decr ( key -- response ) decr flush read-response ;
+: redis-decrby ( integer key -- response ) decrby flush read-response ;
+: redis-exists ( key -- response ) exists flush read-response ;
+: redis-del ( key -- response ) del flush read-response ;
+: redis-type ( key -- response ) type flush read-response ;
+
+#! Key space
+: redis-keys ( pattern -- response ) keys flush read-response ;
+: redis-randomkey ( -- response ) randomkey flush read-response ;
+: redis-rename ( newkey key -- response ) rename flush read-response ;
+: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
+: redis-dbsize ( -- response ) dbsize flush read-response ;
+: redis-expire ( integer key -- response ) expire flush read-response ;
+
+#! Lists
+: redis-rpush ( value key -- response ) rpush flush read-response ;
+: redis-lpush ( value key -- response ) lpush flush read-response ;
+: redis-llen ( key -- response ) llen flush read-response ;
+: redis-lrange ( start end key -- response ) lrange flush read-response ;
+: redis-ltrim ( start end key -- response ) ltrim flush read-response ;
+: redis-lindex ( integer key -- response ) lindex flush read-response ;
+: redis-lset ( value index key -- response ) lset flush read-response ;
+: redis-lrem ( value amount key -- response ) lrem flush read-response ;
+: redis-lpop ( key -- response ) lpop flush read-response ;
+: redis-rpop ( key -- response ) rpop flush read-response ;
+
+#! Sets
+: redis-sadd ( member key -- response ) sadd flush read-response ;
+: redis-srem ( member key -- response ) srem flush read-response ;
+: redis-smove ( member newkey key -- response ) smove flush read-response ;
+: redis-scard ( key -- response ) scard flush read-response ;
+: redis-sismember ( member key -- response ) sismember flush read-response ;
+: redis-sinter ( keys -- response ) sinter flush read-response ;
+: redis-sinterstore ( keys destkey -- response ) sinterstore flush read-response ;
+: redis-sunion ( keys -- response ) sunion flush read-response ;
+: redis-sunionstore ( keys destkey -- response ) sunionstore flush read-response ;
+: redis-smembers ( key -- response ) smembers flush read-response ;
+
+#! Multiple db
+: redis-select ( integer -- response ) select flush read-response ;
+: redis-move ( integer key -- response ) move flush read-response ;
+: redis-flushdb ( -- response ) flushdb flush read-response ;
+: redis-flushall ( -- response ) flushall flush read-response ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: redis-save ( -- response ) save flush read-response ;
+: redis-bgsave ( -- response ) bgsave flush read-response ;
+: redis-lastsave ( -- response ) lastsave flush read-response ;
+: redis-shutdown ( -- response ) shutdown flush read-response ;
+
+#! Remote server control
+: redis-info ( -- response ) info flush read-response ;
+: redis-monitor ( -- response ) monitor flush read-response ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.response-parser io.streams.string ;
+IN: redis.response-parser.tests
+
+[ 1 ] [ ":1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ "hello" ] [ "$5\r\nhello\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ f ] [ "$-1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ { "hello" "world!" } ] [
+ "*2\r\n$5\r\nhello\r\n$6\r\nworld!\r\n" [ read-response ] with-string-reader
+] unit-test
+
+[ { "hello" f "world!" } ] [
+ "*3\r\n$5\r\nhello\r\n$-1\r\n$6\r\nworld!\r\n" [
+ read-response
+ ] with-string-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators io kernel math math.parser sequences ;
+IN: redis.response-parser
+
+<PRIVATE
+
+: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
+: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
+: read-multi-bulk ( n -- seq/f )
+ dup 0 < [ drop f ] [
+ iota [ drop (read-multi-bulk) ] map
+ ] if ;
+
+: handle-response ( string -- string ) ; ! TODO
+: handle-error ( string -- string ) ; ! TODO
+
+PRIVATE>
+
+: read-response ( -- response )
+ readln unclip {
+ { CHAR: : [ string>number ] }
+ { CHAR: + [ handle-response ] }
+ { CHAR: $ [ string>number read-bulk ] }
+ { CHAR: * [ string>number read-multi-bulk ] }
+ { CHAR: - [ handle-error ] }
+ } case ;
--- /dev/null
+Parser for responses sent by the Redis server
--- /dev/null
+Words for communicating with the Redis key-value database
{ 2keep 1 }\r
{ 2nip 2 }\r
{ 2over 4 }\r
- { 2slip 2 }\r
{ 2swap 3 }\r
{ 3curry 2 }\r
{ 3drop 1 }\r
{ 3dup 2 }\r
{ 3keep 3 }\r
- { 3slip 3 }\r
{ 4drop 2 }\r
{ 4dup 3 }\r
{ compose 1/2 }\r
{ nkeep 5 }\r
{ npick 6 }\r
{ nrot 5 }\r
- { nslip 5 }\r
{ ntuck 6 }\r
{ nwith 4 }\r
{ over 2 }\r
{ pick 4 }\r
{ roll 4 }\r
{ rot 3 }\r
- { slip 1 }\r
{ spin 3 }\r
{ swap 1 }\r
{ swapd 3 }\r
USING: tools.deploy.config ;
H{
+ { deploy-ui? t }
{ deploy-reflection 1 }
- { deploy-word-defs? f }
- { deploy-word-props? f }
+ { deploy-unicode? f }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
{ deploy-name "Spheres" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
{ deploy-compiler? t }
- { deploy-math? t }
- { deploy-io 1 }
{ deploy-threads? t }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
- { deploy-c-types? f }
}
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel spider ;
+USING: accessors assocs deques dlists kernel ;
IN: spider.unique-deque
TUPLE: todo-url url depth ;
: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
pick deque-empty? [ 3drop ] [
- [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ [ pop-front dup ] 2dip [ call ] dip [ t ] compose [ drop f ] if ]
[ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
] if ; inline recursive
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-name "Terrain" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-compiler? t }
+ { deploy-threads? t }
+}
projects / factor.git / commitdiff