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

Merge branch 'master' into experimental

db4
Alex Chapman 2009-04-15 08:58:25 +10:00
parent caabf4f6da da38a25963
commit ec62badca6
50 changed files with 829 additions and 792 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -28,8 +28,8 @@ IN: compiler.tree.propagation.recursive
{
{ [ 2dup interval-subset? ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] }
{ [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
{ [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
[ [-inf,inf] ]
} cond interval-union nip ;

6
basis/db/tuples/tuples-tests.factor
View File

@ -411,7 +411,7 @@ TUPLE: exam id name score ;
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
] unit-test
[
@ -419,7 +419,7 @@ TUPLE: exam id name score ;
T{ exam f 1 "Kyle" 100 }
}
] [
T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
] unit-test
[
@ -430,7 +430,7 @@ TUPLE: exam id name score ;
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
] unit-test
[

2
basis/furnace/cache/cache.factor vendored
View File

@ -22,7 +22,7 @@ server-state f
: expire-state ( class -- )
new
-1.0/0.0 millis [a,b] >>expires
-1/0. millis [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;

4
basis/hints/hints.factor
View File

@ -3,7 +3,7 @@
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
math generic generic.standard generic.standard.engines classes
math math.parser generic generic.standard generic.standard.engines classes
hashtables ;
IN: hints
@ -118,6 +118,8 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
\ base> { string fixnum } "specializer" set-word-prop
M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop

2
basis/lcs/lcs.factor
View File

@ -8,7 +8,7 @@ IN: lcs
0 1 ? + [ [ 1+ ] bi@ ] dip min min ;
: lcs-step ( insert delete change same? -- next )
1 -1./0. ? + max max ; ! -1./0. is -inf (float)
1 -1/0. ? + max max ; ! -1/0. is -inf (float)
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion

4
basis/math/functions/functions-tests.factor
View File

@ -22,9 +22,9 @@ IN: math.functions.tests
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test
[ 1/0. ] [ 0 -2 ^ ] unit-test
[ t ] [ 0 0.0 ^ fp-nan? ] unit-test
[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test
[ 1/0. ] [ 0 -2.0 ^ ] unit-test
[ 0 ] [ 0 3.0 ^ ] unit-test
[ 0 ] [ 0 3 ^ ] unit-test

2
basis/math/functions/functions.factor
View File

@ -81,7 +81,7 @@ PRIVATE>
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
: (^mod) ( n x y -- z )
make-bits 1 [

8
basis/math/intervals/intervals.factor
View File

@ -40,13 +40,13 @@ TUPLE: interval { from read-only } { to read-only } ;
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline
: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline
: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline

2
basis/math/libm/libm-docs.factor
View File

@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }

6
basis/pango/layouts/layouts.factor
View File

@ -44,7 +44,7 @@ FUNCTION: PangoLayoutLine*
pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ;
FUNCTION: void
pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ;
pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ;
FUNCTION: gboolean
pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ;
@ -122,7 +122,7 @@ MEMO: missing-font-metrics ( font -- metrics )
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
f 0 <int> [ pango_layout_line_index_to_x ] keep
0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
: x>line-offset ( layout x -- n )
@ -205,4 +205,4 @@ SYMBOL: cached-layouts
: cached-line ( font string -- line )
cached-layout layout>> first-line ;
[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook

86
basis/stack-checker/transforms/transforms.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel kernel.private combinators.private
words sequences generic math math.order namespaces make quotations assocs
combinators combinators.short-circuit classes.tuple
words sequences generic math math.order namespaces make quotations
assocs combinators combinators.short-circuit classes.tuple
classes.tuple.private effects summary hashtables classes generic sets
definitions generic.standard slots.private continuations locals
generalizations stack-checker.backend stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
sequences.private generalizations stack-checker.backend
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
@ -106,40 +106,68 @@ IN: stack-checker.transforms
] [ drop f ] if
] 1 define-transform
! Membership testing
CONSTANT: bit-member-max 256
! Fast at for integer maps
CONSTANT: lookup-table-at-max 256
: bit-member? ( seq -- ? )
: lookup-table-at? ( assoc -- ? )
#! Can we use a fast byte array test here?
{
[ length 4 > ]
[ [ integer? ] all? ]
[ [ 0 bit-member-max between? ] any? ]
[ assoc-size 4 > ]
[ values [ ] all? ]
[ keys [ integer? ] all? ]
[ keys [ 0 lookup-table-at-max between? ] all? ]
} 1&& ;
: bit-member-seq ( seq -- flags )
[ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
: lookup-table-seq ( assoc -- table )
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
: bit-member-quot ( seq -- newquot )
bit-member-seq
: lookup-table-quot ( seq -- newquot )
lookup-table-seq
'[
_ {
{ [ over fixnum? ] [ ?nth 1 eq? ] }
{ [ over bignum? ] [ ?nth 1 eq? ] }
[ 2drop f ]
} cond
_ over integer? [
2dup bounds-check? [
nth-unsafe dup >boolean
] [ 2drop f f ] if
] [ 2drop f f ] if
] ;
: member-quot ( seq -- newquot )
dup bit-member? [
bit-member-quot
] [
dup length 4 <= [
[ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot
: fast-lookup-table-at? ( assoc -- ? )
values {
[ [ integer? ] all? ]
[ [ 0 254 between? ] all? ]
} 1&& ;
: fast-lookup-table-seq ( assoc -- table )
lookup-table-seq [ 255 or ] B{ } map-as ;
: fast-lookup-table-quot ( seq -- newquot )
fast-lookup-table-seq
'[
_ over integer? [
2dup bounds-check? [
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
] [ 2drop f f ] if
] [ 2drop f f ] if
] ;
: at-quot ( assoc -- quot )
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
unique [ key? ] curry
lookup-table-quot
] if
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-transform
! Membership testing
: member-quot ( seq -- newquot )
dup length 4 <= [
[ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot
] [
unique [ key? ] curry
] if ;
\ member? [
@ -170,4 +198,4 @@ CONSTANT: bit-member-max 256
\ shuffle [
shuffle-mapping nths-quot
] 1 define-transform
] 1 define-transform

2
basis/ui/backend/x11/x11.factor
View File

@ -225,7 +225,7 @@ M: x-clipboard paste-clipboard
utf8 encode dup length XChangeProperty drop ;
: set-class ( dpy window -- )
XA_WM_CLASS XA_STRING 8 PropModeReplace "Factor"
XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )

2
basis/wrap/wrap.factor
View File

@ -30,7 +30,7 @@ SYMBOL: line-ideal
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
:: min-by ( seq quot -- elt )
f 1.0/0.0 seq [| key value new |
f 1/0. seq [| key value new |
new quot call :> newvalue
newvalue value < [ new newvalue ] [ key value ] if
] each drop ; inline

2
build-support/factor.sh
View File

@ -199,7 +199,7 @@ find_architecture() {
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
}
c_find_word_size() {

2
core/math/floats/floats-tests.factor
View File

@ -56,8 +56,6 @@ unit-test
[ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test
! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test
[ 0 ] [ 1/0. >bignum ] unit-test
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test

2
core/math/integers/integers.factor
View File

@ -122,7 +122,7 @@ M: bignum (log2) bignum-log2 ;
2drop 0.0
] [
dup zero? [
2drop 1.0/0.0
2drop 1/0.
] [
pre-scale
/f-loop over odd?

2
core/math/parser/parser-docs.factor
View File

@ -25,7 +25,7 @@ $nl
ABOUT: "number-strings"
HELP: digits>integer
{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;

10
core/math/parser/parser-tests.factor
View File

@ -95,17 +95,17 @@ unit-test
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test
[ t ] [ "0/0." string>number fp-nan? ] unit-test
[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
[ 1/0. ] [ "1/0." string>number ] unit-test
[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
[ -1/0. ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test

76
core/math/parser/parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences strings
arrays combinators splitting math assocs make ;
USING: kernel math.private namespaces sequences sequences.private
strings arrays combinators splitting math assocs make ;
IN: math.parser
: digit> ( ch -- n )
@ -28,13 +28,19 @@ IN: math.parser
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
} at ;
} at 255 or ; inline
: string>digits ( str -- digits )
[ digit> ] { } map-as ;
[ digit> ] B{ } map-as ; inline
: digits>integer ( seq radix -- n )
0 swap [ swapd * + ] curry reduce ;
: (digits>integer) ( valid? accum digit radix -- valid? accum )
2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
: digits>integer ( seq radix -- n/f )
[ (digits>integer) ] each-digit ; inline
DEFER: base>
@ -43,6 +49,11 @@ DEFER: base>
SYMBOL: radix
SYMBOL: negative?
: string>natural ( seq radix -- n/f )
over empty? [ 2drop f ] [
[ [ digit> ] dip (digits>integer) ] each-digit
] if ; inline
: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
@ -54,37 +65,30 @@ SYMBOL: negative?
sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
: string>ratio ( str -- a/b )
"-" ?head dup negative? set swap
"/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
: string>ratio ( str radix -- a/b )
[
"-" ?head dup negative? set swap
"/" split1 (base>) [ whole-part ] dip
3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
] with-radix ;
: valid-digits? ( seq -- ? )
{
{ [ dup empty? ] [ drop f ] }
{ [ f over memq? ] [ drop f ] }
[ radix get [ < ] curry all? ]
} cond ;
: string>integer ( str -- n/f )
"-" ?head swap
string>digits dup valid-digits?
[ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
: string>integer ( str radix -- n/f )
over first-unsafe CHAR: - = [
[ rest-slice ] dip string>natural dup [ neg ] when
] [
string>natural
] if ; inline
PRIVATE>
: base> ( str radix -- n/f )
[
CHAR: / over member? [
string>ratio
] [
CHAR: . over member? [
string>float
] [
string>integer
] if
] if
] with-radix ;
over empty? [ 2drop f ] [
over [ "/." member? ] find nip {
{ CHAR: / [ string>ratio ] }
{ CHAR: . [ drop string>float ] }
[ drop string>integer ]
} case
] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
@ -147,9 +151,9 @@ M: ratio >base
M: float >base
drop {
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0/0." ] }
{ [ dup 1/0. = ] [ drop "1/0." ] }
{ [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
[ float>string fix-float ]
} cond ;

2
core/sequences/sequences-tests.factor
View File

@ -227,7 +227,7 @@ unit-test
[ -3 10 nth ] must-fail
[ 11 10 nth ] must-fail
[ -1./0. 0 delete-nth ] must-fail
[ -1/0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test

6
core/syntax/syntax-docs.factor
View File

@ -66,6 +66,12 @@ ARTICLE: "syntax-floats" "Float syntax"
"7.e13"
"1.0e-5"
}
"There are three special float values:"
{ $table
{ "Positive infinity" { $snippet "1/0." } }
{ "Negative infinity" { $snippet "-1/0." } }
{ "Not-a-number" { $snippet "0/0." } }
}
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"

2
extra/benchmark/raytracer/raytracer.factor
View File

@ -53,7 +53,7 @@ C: <sphere> sphere
: sphere-t ( b d -- t )
-+ dup 0.0 <
[ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
[ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi

1
extra/irc/client/base/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

37
extra/irc/client/base/base.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs concurrency.mailboxes io kernel namespaces
strings words.symbol irc.client.chats irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.client.base
SYMBOL: current-irc-client
: irc> ( -- irc-client ) current-irc-client get ;
: stream> ( -- stream ) irc> stream>> ;
: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: chats> ( -- seq ) irc> chats>> values ;
: me? ( string -- ? ) irc> nick>> = ;
: with-irc ( irc-client quot: ( -- ) -- )
\ current-irc-client swap with-variable ; inline
UNION: to-target privmsg notice ;
UNION: to-channel join part topic kick rpl-channel-modes
rpl-notopic rpl-topic rpl-names rpl-names-end ;
UNION: to-one-chat to-target to-channel mode ;
UNION: to-many-chats nick quit ;
UNION: to-all-chats irc-end irc-disconnected irc-connected ;
PREDICATE: to-me < to-target target>> me? ;
GENERIC: chat-name ( irc-message -- name )
M: mode chat-name name>> ;
M: to-target chat-name target>> ;
M: to-me chat-name sender>> ;
M: to-channel chat-name channel>> ;
GENERIC: chat> ( obj -- chat/f )
M: string chat> irc> chats>> at ;
M: symbol chat> irc> chats>> at ;
M: to-one-chat chat> chat-name +server-chat+ or chat> ;

1
extra/irc/client/chats/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

22
extra/irc/client/chats/chats-docs.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel ;
IN: irc.client.chats
HELP: irc-client "IRC Client object" ;
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ;
HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ;
HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ;
HELP: irc-disconnected "Message sent to notify chats that connection was lost." ;
HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ;

50
extra/irc/client/chats/chats.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
destructors arrays sequences ;
IN: irc.client.chats
CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
: <irc-server-chat> ( -- irc-server-chat )
irc-server-chat new
<mailbox> >>in-messages ;
: <irc-channel-chat> ( name -- irc-channel-chat )
irc-channel-chat new
swap >>name
<mailbox> >>in-messages
f >>password
H{ } clone >>participants
t >>clear-participants ;
: <irc-nick-chat> ( name -- irc-nick-chat )
irc-nick-chat new
swap >>name
<mailbox> >>in-messages ;
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready
exceptions ;
: <irc-client> ( profile -- irc-client )
dup nickname>> irc-client new
swap >>nick
swap >>profile
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
15 seconds >>reconnect-time
V{ } clone >>exceptions
[ <inet> latin1 <client> ] >>connect ;
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;

1
extra/irc/client/chats/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client and Chat object definitions

28
extra/irc/client/client-docs.factor
View File

@ -1,16 +1,9 @@
USING: help.markup help.syntax quotations kernel irc.messages ;
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel
irc.messages irc.messages.base irc.messages.parser irc.client.chats ;
IN: irc.client
HELP: irc-client "IRC Client object" ;
HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
HELP: irc-channel-chat "Chat for irc channels" ;
HELP: irc-nick-chat "Chat for irc users" ;
HELP: irc-profile "IRC Client profile object" ;
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
@ -56,30 +49,31 @@ ARTICLE: "irc.client" "IRC Client"
"Some of the RFC defined irc messages as objects:"
{ $table
{ { $link irc-message } "base of all irc messages" }
{ { $link logged-in } "logged in to server" }
{ { $link rpl-welcome } "logged in to server" }
{ { $link ping } "ping message" }
{ { $link join } "channel join" }
{ { $link part } "channel part" }
{ { $link quit } "quit from irc" }
{ { $link privmsg } "private message (to client or channel)" }
{ { $link kick } "kick from channel" }
{ { $link roomlist } "list of participants in channel" }
{ { $link nick-in-use } "chosen nick is in use by another client" }
{ { $link rpl-names } "list of participants in channel" }
{ { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
{ { $link notice } "notice message" }
{ { $link mode } "mode change" }
{ { $link unhandled } "uninmplemented/unhandled message" }
}
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
{ { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
{ { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
{ { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." }
{ { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
"USING: irc.client ;"
"USING: irc.client irc.client.chats ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
@ -91,7 +85,7 @@ ARTICLE: "irc.client" "IRC Client"
"! Register and start chat (this joins the channel)"
"mychannel get bot get attach-chat"
"! Send a message to the channel"
"\"what's up?\" mychannel get speak"
"\"Hello World!\" mychannel get speak"
"! Read a message from the channel"
"mychannel get hear"
}

384
extra/irc/client/client.factor
View File

@ -1,383 +1,15 @@
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
accessors destructors namespaces io assocs arrays fry
continuations threads strings classes combinators splitting hashtables
ascii irc.messages ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
USING: accessors concurrency.mailboxes destructors
irc.client.base irc.client.chats irc.client.internals kernel
namespaces sequences ;
IN: irc.client
! ======================================
! Setup and running objects
! ======================================
CONSTANT: irc-port 6667 ! Default irc port
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready ;
: <irc-client> ( profile -- irc-client )
irc-client new
swap >>profile
<mailbox> >>in-messages
<mailbox> >>out-messages
H{ } clone >>chats
dup profile>> nickname>> >>nick
[ <inet> latin1 <client> ] >>connect
15 seconds >>reconnect-time ;
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
TUPLE: irc-nick-chat < irc-chat name ;
SYMBOL: +server-chat+
! participant modes
SYMBOL: +operator+
SYMBOL: +voice+
SYMBOL: +normal+
: participant-mode ( n -- mode )
H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
! participant changed actions
SYMBOL: +join+
SYMBOL: +part+
SYMBOL: +mode+
SYMBOL: +nick+
! chat objects
: <irc-server-chat> ( -- irc-server-chat )
<mailbox> f irc-server-chat boa ;
: <irc-channel-chat> ( name -- irc-channel-chat )
[ <mailbox> f ] dip f 60 seconds H{ } clone t
irc-channel-chat boa ;
: <irc-nick-chat> ( name -- irc-nick-chat )
[ <mailbox> f ] dip irc-nick-chat boa ;
! ======================================
! Message objects
! ======================================
TUPLE: participant-changed nick action parameter ;
C: <participant-changed> participant-changed
SINGLETON: irc-chat-end ! sent to a chat to stop its execution
SINGLETON: irc-end ! sent when the client isn't running anymore
SINGLETON: irc-disconnected ! sent when connection is lost
SINGLETON: irc-connected ! sent when connection is established
: terminate-irc ( irc-client -- )
[ is-running>> ] keep and [
f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each
] when* ;
<PRIVATE
SYMBOL: current-irc-client
! ======================================
! Utils
! ======================================
: irc> ( -- irc-client ) current-irc-client get ;
: irc-write ( s -- ) irc> stream>> stream-write ;
: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: chat> ( name -- chat/f ) irc> chats>> at ;
: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
: me? ( string -- ? ) irc> nick>> = ;
GENERIC: to-chat ( message obj -- )
M: string to-chat
chat> [ +server-chat+ chat> ] unless*
[ to-chat ] [ drop ] if* ;
M: irc-chat to-chat in-messages>> mailbox-put ;
: unregister-chat ( name -- )
irc> chats>>
[ at [ irc-chat-end ] dip to-chat ]
[ delete-at ]
2bi ;
: (remove-participant) ( nick chat -- )
[ participants>> delete-at ]
[ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
: remove-participant ( nick channel -- )
chat> [ (remove-participant) ] [ drop ] if* ;
: chats-with-participant ( nick -- seq )
irc> chats>> values
[ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
with filter ;
: to-chats-with-participant ( message nickname -- )
chats-with-participant [ to-chat ] with each ;
: remove-participant-from-all ( nick -- )
dup chats-with-participant [ (remove-participant) ] with each ;
: notify-rename ( newnick oldnick chat -- )
[ participant-changed new +nick+ >>action
[ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
: rename-participant ( newnick oldnick chat -- )
[ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
[ notify-rename ] 3bi ;
: rename-participant-in-all ( oldnick newnick -- )
swap dup chats-with-participant [ rename-participant ] with with each ;
: add-participant ( mode nick channel -- )
chat>
[ participants>> set-at ]
[ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
: change-participant-mode ( channel mode nick -- )
rot chat>
[ participants>> set-at ]
[ [ participant-changed new
[ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
3bi ; ! FIXME
! ======================================
! IRC client messages
! ======================================
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
irc> connect>> call drop ; inline
: /JOIN ( channel password -- )
"JOIN " irc-write
[ [ " :" ] dip 3append ] when* irc-print ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
! ======================================
! Server message handling
! ======================================
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
GENERIC: forward-name ( irc-message -- name )
M: join forward-name trailing>> ;
M: part forward-name channel>> ;
M: kick forward-name channel>> ;
M: mode forward-name name>> ;
M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
UNION: single-forward join part kick mode privmsg ;
UNION: multiple-forward nick quit ;
UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message
+server-chat+ chat> [ to-chat ] [ drop ] if* ;
M: single-forward forward-message dup forward-name to-chat ;
M: multiple-forward forward-message
dup irc-message-sender to-chats-with-participant ;
M: broadcast-forward forward-message
irc> chats>> values [ to-chat ] with each ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
M: logged-in process-message
name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
values [ initialize-chat ] each ;
M: ping process-message trailing>> /PONG ;
M: nick-in-use process-message name>> "_" append /NICK ;
M: join process-message
[ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
dup chat> [ add-participant ] [ 3drop ] if ;
M: part process-message
[ irc-message-sender ] [ channel>> ] bi remove-participant ;
M: kick process-message
[ [ who>> ] [ channel>> ] bi remove-participant ]
[ dup who>> me? [ unregister-chat ] [ drop ] if ]
bi ;
M: quit process-message
irc-message-sender remove-participant-from-all ;
M: nick process-message
[ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
M: mode process-message ( mode -- )
[ channel-mode? ] keep and [
[ name>> ] [ mode>> ] [ parameter>> ] tri
[ change-participant-mode ] [ 2drop ] if*
] when* ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
: names-reply>participants ( names-reply -- participants )
trailing>> [ blank? ] trim " " split
[ >nick/mode 2array ] map >hashtable ;
: maybe-clean-participants ( channel-chat -- )
dup clean-participants>> [
H{ } clone >>participants f >>clean-participants
] when drop ;
M: names-reply process-message
[ names-reply>participants ] [ channel>> chat> ] bi [
[ maybe-clean-participants ]
[ participants>> 2array assoc-combine ]
[ (>>participants) ] tri
] [ drop ] if* ;
M: end-of-names process-message
channel>> chat> [
t >>clean-participants
[ f f f <participant-changed> ] dip name>> to-chat
] when* ;
! ======================================
! Client message handling
! ======================================
GENERIC: handle-outgoing-irc ( irc-message -- ? )
M: irc-end handle-outgoing-irc drop f ;
M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
! ======================================
! Reader/Writer
! ======================================
: handle-reader-message ( irc-message -- )
irc> in-messages>> mailbox-put ;
DEFER: (connect-irc)
: (handle-disconnect) ( -- )
irc>
[ [ irc-disconnected ] dip in-messages>> mailbox-put ]
[ dup reconnect-time>> sleep (connect-irc) ]
[ nick>> /LOGIN ]
tri ;
! FIXME: do something with the exception, store somewhere to help debugging
: handle-disconnect ( error -- ? )
drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
: (reader-loop) ( -- ? )
irc> stream>> [
|dispose stream-readln [
parse-irc-line handle-reader-message t
] [
handle-disconnect
] if*
] with-destructors ;
: reader-loop ( -- ? )
[ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? )
irc> out-messages>> mailbox-get handle-outgoing-irc ;
! ======================================
! Processing loops
! ======================================
: in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get
[ forward-message ] [ process-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
: maybe-annotate-with-name ( name obj -- obj )
{ { [ dup string? ] [ strings>privmsg ] }
{ [ dup privmsg instance? ] [ swap >>name ] }
[ nip ]
} cond ;
GENERIC: annotate-message ( chat object -- object )
M: object annotate-message nip ;
M: part annotate-message swap name>> >>channel ;
M: privmsg annotate-message swap name>> >>name ;
M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
GENERIC: (attach-chat) ( irc-chat -- )
USE: prettyprint
M: irc-chat (attach-chat)
[ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
[ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
bi ;
M: irc-server-chat (attach-chat)
irc> >>client +server-chat+ irc> chats>> set-at ;
GENERIC: (remove-chat) ( irc-chat -- )
M: irc-nick-chat (remove-chat)
name>> unregister-chat ;
M: irc-channel-chat (remove-chat)
[ part new annotate-message irc> out-messages>> mailbox-put ] keep
name>> unregister-chat ;
M: irc-server-chat (remove-chat)
drop +server-chat+ unregister-chat ;
: (connect-irc) ( irc-client -- )
{
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
[ (>>stream) ]
[ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: with-irc-client ( irc-client quot: ( -- ) -- )
[ \ current-irc-client ] dip with-variable ; inline
PRIVATE>
: connect-irc ( irc-client -- )
dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
: detach-chat ( irc-chat -- )
[ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
: speak ( message irc-chat -- )
[ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
[ (connect-irc) (do-login) spawn-irc ] with-irc ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;

1
extra/irc/client/internals/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

195
extra/irc/client/client-tests.factor → extra/irc/client/internals/internals-tests.factor
View File

@ -1,10 +1,13 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays sequences
io io.streams.duplex namespaces threads destructors
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
io io.streams.duplex namespaces threads destructors
calendar concurrency.mailboxes classes assocs combinators
irc.messages.parser irc.client.base irc.client.chats
irc.client.participants irc.client.internals ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
IN: irc.client.tests
IN: irc.client.internals.tests
! Streams for testing
TUPLE: mb-writer lines last-line disposed ;
@ -28,18 +31,20 @@ M: mb-writer dispose drop ;
t >>is-ready
t >>is-running
<test-stream> >>stream
dup [ spawn-irc yield ] with-irc-client ;
dup [ spawn-irc yield ] with-irc ;
! to be used inside with-irc-client quotations
: %add-named-chat ( chat -- ) irc> attach-chat ;
! to be used inside with-irc quotations
: %add-named-chat ( chat -- ) (attach-chat) ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
: %push-lines ( lines -- ) [ %push-line ] each ;
: %join ( channel -- ) <irc-channel-chat> (attach-chat) ;
: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
[ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
: with-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline
: spawning-irc ( quot: ( -- ) -- )
[ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TESTS
@ -49,170 +54,160 @@ M: mb-writer dispose drop ;
{ "factorbot" } [ irc> nick>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line forward-name ] unit-test
string>irc-message chat-name ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
parse-irc-line forward-name ] unit-test
] with-irc
string>irc-message chat-name ] unit-test
] spawning-irc
{ privmsg "#channel" "hello" } [
"#channel" "hello" strings>privmsg
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
! Test login and nickname set
[ { "factorbot2" } [
":some.where 001 factorbot2 :Welcome factorbot2" %push-line
irc> nick>>
] unit-test
] with-irc
] spawning-irc
! Test connect
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
[ 2drop <test-stream> t ] >>connect
[ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri
[
(connect-irc)
(do-login)
irc> stream>> out>> lines>>
(terminate-irc)
] with-irc
] unit-test
! Test join
[ { "JOIN #factortest" } [
"#factortest" %join
irc> stream>> out>> lines>> pop
"#factortest" %join %pop-output-line
] unit-test
] with-irc
] spawning-irc
[ { join_ "#factortest" } [
[ { join_ "#factortest"} [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
} [ %push-line ] each
in-messages>> 0.1 seconds mailbox-get-timeout
[ class ] [ trailing>> ] bi
} %push-lines
[ join? ] read-matching-message
[ class ] [ channel>> ] bi
] unit-test
] with-irc
[ { T{ participant-changed f "somebody" +join+ } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where JOIN :#factortest" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
] spawning-irc
[ { privmsg "#factortest" "hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
] with-irc
] spawning-irc
[ { privmsg "factorbot" "hello" } [
"ircuser" <irc-nick-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message
[ class ] [ name>> ] [ trailing>> ] tri
[ class ] [ target>> ] [ trailing>> ] tri
] unit-test
] with-irc
] spawning-irc
[ { mode } [
[ { mode "#factortest" "+ns" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line
[ mode? ] read-matching-message class
[ mode? ] read-matching-message
[ class ] [ name>> ] [ mode>> ] tri
] unit-test
] with-irc
] spawning-irc
! Participant lists tests
[ { H{ { "ircuser" +normal+ } } } [
[ { { "ircuser" } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net JOIN :#factortest" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants
{ "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser!n=user@isp.net PART #factortest" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants
{ "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser2" +normal+ }
{ "ircuser" +normal+ } } clone >>participants
{ "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
participants>>
participants>> keys
] unit-test
] with-irc
] spawning-irc
[ { H{ { "ircuser2" +normal+ } } } [
[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
"ircuser" over join-participant
[ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>>
] unit-test
] with-irc
] spawning-irc
[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
{ "ircuser" T{ participant { nick "ircuser" } } }
{ "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
"ircuser" over join-participant
[ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 353 factorbot @ #factortest :ircuser2 "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced "
":ircserver.net 353 factorbot @ #factortest :ircuser "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
} %push-lines
participants>>
] unit-test
] with-irc
] spawning-irc
! Namelist change notification
[ { T{ participant-changed f f f f } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { T{ participant-changed f "ircuser" +part+ f } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
"#factortest" <irc-channel-chat>
H{ { "ircuser" +normal+ } } clone >>participants
[ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
[ participant-changed? ] read-matching-message
] unit-test
] with-irc
! Mode change
[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
[ { mode "#factortest" "+o" "ircuser" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
[ participant-changed? ] read-matching-message
[ mode? ] read-matching-message
{ [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
] unit-test
] with-irc
] spawning-irc
[ { T{ participant { nick "ircuser" } { operator t } } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
participants>> "ircuser" swap at
] unit-test
] spawning-irc
! Send privmsg
[ { "PRIVMSG #factortest :hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
"hello" swap (speak) %pop-output-line
] unit-test
] spawning-irc

162
extra/irc/client/internals/internals.factor Normal file
View File

@ -0,0 +1,162 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays concurrency.mailboxes continuations destructors
hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
strings words.symbol irc.messages.base irc.client.participants fry threads
combinators irc.messages.parser ;
EXCLUDE: sequences => join ;
IN: irc.client.internals
: /NICK ( nick -- ) "NICK " prepend irc-print ;
: /PONG ( text -- ) "PONG " prepend irc-print ;
: /LOGIN ( nick -- )
dup /NICK
"USER " prepend " hostname servername :irc.factor" append irc-print ;
: /CONNECT ( server port -- stream )
irc> connect>> call( host port -- stream local ) drop ;
: /JOIN ( channel password -- )
[ " :" swap 3append ] when* "JOIN " prepend irc-print ;
: (connect-irc) ( -- )
irc> {
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
[ (>>stream) ]
[ t swap (>>is-running) ]
[ in-messages>> [ irc-connected ] dip mailbox-put ]
} cleave ;
: (do-login) ( -- ) irc> nick>> /LOGIN ;
GENERIC: initialize-chat ( chat -- )
M: irc-chat initialize-chat drop ;
M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
GENERIC: chat-put ( message obj -- )
M: irc-chat chat-put in-messages>> mailbox-put ;
M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
M: string chat-put chat> +server-chat+ or chat-put ;
M: sequence chat-put [ chat-put ] with each ;
: delete-chat ( name -- ) irc> chats>> delete-at ;
: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
! Server message handling
GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message +server-chat+ chat-put ;
M: to-one-chat forward-message dup chat> chat-put ;
M: to-all-chats forward-message chats> chat-put ;
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
M: ping process-message trailing>> /PONG ;
M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
M: quit process-message sender>> quit-participant ;
M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
M: rpl-welcome process-message
irc>
swap nickname>> >>nick
t >>is-ready
chats>> values [ initialize-chat ] each ;
M: kick process-message
[ [ user>> ] [ chat> ] bi part-participant ]
[ dup user>> me? [ unregister-chat ] [ drop ] if ]
bi ;
M: participant-mode process-message ( participant-mode -- )
[ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
M: rpl-names process-message
[ nicks>> ] [ chat> ] bi dup ?clear-participants
'[ _ join-participant ] each ;
M: rpl-names-end process-message chat> t >>clear-participants drop ;
! Client message handling
GENERIC: handle-outgoing-irc ( irc-message -- ? )
M: irc-end handle-outgoing-irc drop f ;
M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
! Reader/Writer
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
irc> in-messages>> irc-disconnected swap mailbox-put
irc> reconnect-time>> sleep
(connect-irc)
(do-login) ;
: handle-disconnect ( error -- ? )
[ irc> exceptions>> push ] when*
irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
GENERIC: handle-input ( line/f -- ? )
M: string handle-input string>irc-message handle-reader-message t ;
M: f handle-input handle-disconnect ;
: (reader-loop) ( -- ? )
stream> [ |dispose stream-readln handle-input ] with-destructors ;
: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
! Processing loops
: in-multiplexer-loop ( -- ? )
irc> in-messages>> mailbox-get
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;
GENERIC: annotate-message ( chat object -- object )
M: object annotate-message nip ;
M: to-channel annotate-message swap name>> >>channel ;
M: to-target annotate-message swap name>> >>target ;
M: mode annotate-message swap name>> >>name ;
M: string annotate-message [ name>> ] dip strings>privmsg ;
: spawn-irc ( -- )
[ reader-loop ] "irc-reader-loop" spawn-server
[ writer-loop ] "irc-writer-loop" spawn-server
[ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
3drop ;
GENERIC: (attach-chat) ( irc-chat -- )
M: irc-chat (attach-chat)
irc>
[ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
[ is-ready>> [ initialize-chat ] [ drop ] if ]
2bi ;
M: irc-server-chat (attach-chat)
irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
GENERIC: remove-chat ( irc-chat -- )
M: irc-nick-chat remove-chat name>> unregister-chat ;
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
M: irc-channel-chat remove-chat
[ part new annotate-message irc-send ]
[ name>> unregister-chat ] bi ;
: (terminate-irc) ( -- )
irc> dup is-running>> [
f >>is-running
[ stream>> dispose ] keep
[ in-messages>> ] [ out-messages>> ] bi 2array
[ irc-end swap mailbox-put ] each
] [ drop ] if ;
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;

1
extra/irc/client/internals/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client internals

1
extra/irc/client/participants/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

55
extra/irc/client/participants/participants.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators fry hashtables
irc.client.base irc.client.chats kernel sequences splitting ;
IN: irc.client.participants
TUPLE: participant nick operator voice ;
: <participant> ( name -- participant )
{
{ [ "@" ?head ] [ t f ] }
{ [ "+" ?head ] [ f t ] }
[ f f ]
} cond participant boa ;
GENERIC: has-participant? ( name irc-chat -- ? )
M: irc-chat has-participant? 2drop f ;
M: irc-channel-chat has-participant? participants>> key? ;
: rename-X ( new old assoc quot: ( obj value -- obj ) -- )
'[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
: part-participant ( nick irc-chat -- ) participants>> delete-at ;
: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
: quit-participant ( nick -- )
dup participant-chats [ part-participant ] with each ;
: rename-participant* ( new old -- )
[ dup participant-chats [ rename-participant ] with with each ]
[ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
2bi ;
: join-participant ( nick irc-channel-chat -- )
participants>> [ <participant> dup nick>> ] dip set-at ;
: apply-mode ( ? participant mode -- )
{
{ CHAR: o [ (>>operator) ] }
{ CHAR: v [ (>>voice) ] }
[ 3drop ]
} case ;
: apply-modes ( mode-line participant -- )
[ unclip CHAR: + = ] dip
'[ [ _ _ ] dip apply-mode ] each ;
: change-participant-mode ( mode channel nick -- )
swap chat> participants>> at apply-modes ;
: ?clear-participants ( channel-chat -- )
dup clear-participants>> [
f >>clear-participants participants>> clear-assoc
] [ drop ] if ;

1
extra/irc/client/participants/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC Client chat participants handling

2
extra/irc/gitbot/gitbot.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.private kernel namespaces
USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.encodings.8-bit io.launcher io splitting
make mason.common mason.updates calendar math alarms ;
IN: irc.gitbot

1
extra/irc/messages/base/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

115
extra/irc/messages/base/base.factor Normal file
View File

@ -0,0 +1,115 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
combinators fry generic.parser kernel lexer
mirrors namespaces parser sequences splitting strings words ;
IN: irc.messages.base
TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
TUPLE: unhandled < irc-message ;
SYMBOL: string-irc-type-mapping
string-irc-type-mapping [ H{ } clone ] initialize
: register-irc-message-type ( type string -- )
string-irc-type-mapping get set-at ;
: irc>type ( string -- irc-message-class )
string-irc-type-mapping get at unhandled or ;
GENERIC: irc-trailing-slot ( irc-message -- string/f )
M: irc-message irc-trailing-slot
drop f ;
GENERIC: irc-parameter-slots ( irc-message -- seq )
M: irc-message irc-parameter-slots
drop f ;
GENERIC: process-irc-trailing ( irc-message -- )
M: irc-message process-irc-trailing
dup irc-trailing-slot [
swap [ trailing>> swap ] [ <mirror> ] bi set-at
] [ drop ] if* ;
GENERIC: process-irc-prefix ( irc-message -- )
M: irc-message process-irc-prefix
drop ;
<PRIVATE
: [slot-setter] ( mirror -- quot )
'[ [ _ set-at ] [ drop ] if* ] ; inline
PRIVATE>
GENERIC: process-irc-parameters ( irc-message -- )
M: irc-message process-irc-parameters
dup irc-parameter-slots [
swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
] [ drop ] if* ;
GENERIC: post-process-irc-message ( irc-message -- )
M: irc-message post-process-irc-message drop ;
GENERIC: fill-irc-message-slots ( irc-message -- )
M: irc-message fill-irc-message-slots
{
[ process-irc-trailing ]
[ process-irc-prefix ]
[ process-irc-parameters ]
[ post-process-irc-message ]
} cleave ;
GENERIC: irc-command-string ( irc-message -- string )
M: irc-message irc-command-string drop f ;
! FIXME: inverse of post-process is missing
GENERIC: set-irc-parameters ( irc-message -- )
M: irc-message set-irc-parameters
dup irc-parameter-slots
[ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
GENERIC: set-irc-trailing ( irc-message -- )
M: irc-message set-irc-trailing
dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
GENERIC: set-irc-command ( irc-message -- )
M: irc-message set-irc-command
[ irc-command-string ] [ (>>command) ] bi ;
: irc-message>string ( irc-message -- string )
{
[ prefix>> ]
[ command>> ]
[ parameters>> " " join ]
[ trailing>> dup [ CHAR: : prefix ] when ]
} cleave 4array sift " " join ;
<PRIVATE
: ?define-irc-parameters ( class slot-names -- )
dup empty? not [
[ \ irc-parameter-slots create-method-in ] dip
[ [ "_" = not ] keep and ] map '[ drop _ ] define
] [ 2drop ] if ;
: ?define-irc-trailing ( class slot-name -- )
[
[ \ irc-trailing-slot create-method-in ] dip
first '[ drop _ ] define
] [ drop ] if* ;
: define-irc-class ( class params -- )
[ { ":" "_" } member? not ] filter
[ irc-message ] dip define-tuple-class ;
: define-irc-parameter-slots ( class params -- )
{ ":" } split1 [ over ] dip
[ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
PRIVATE>
#! SYNTAX:
#! IRC: type "COMMAND" slot1 ...;
#! IRC: type "COMMAND" slot1 ... : trailing-slot;
SYNTAX: IRC: ( name string parameters -- )
CREATE-CLASS
[ scan-object register-irc-message-type ] keep
";" parse-tokens
[ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;

1
extra/irc/messages/base/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC messages base implementation

40
extra/irc/messages/messages-tests.factor
View File

@ -1,19 +1,12 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays
irc.messages irc.messages.private ;
irc.messages.parser irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.messages.tests
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ irc-message
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
{ prefix "someuser!n=user@some.where" }
{ command "PRIVMSG" }
{ parameters { "#factortest" } }
{ trailing "hi" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
string>irc-message f >>timestamp ] unit-test
! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ privmsg
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
@ -21,18 +14,22 @@ IN: irc.messages.tests
{ command "PRIVMSG" }
{ parameters { "#factortest" } }
{ trailing "hi" }
{ name "#factortest" } } }
{ target "#factortest" }
{ text "hi" }
{ sender "someuser" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ join
{ line ":someuser!n=user@some.where JOIN :#factortest" }
{ prefix "someuser!n=user@some.where" }
{ command "JOIN" }
{ parameters { } }
{ trailing "#factortest" } } }
{ trailing "#factortest" }
{ sender "someuser" }
{ channel "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +ns" }
@ -42,7 +39,7 @@ IN: irc.messages.tests
{ name "#factortest" }
{ mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +o someuser" }
@ -53,18 +50,19 @@ IN: irc.messages.tests
{ mode "+o" }
{ parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ nick
{ line ":someuser!n=user@some.where NICK :someuser2" }
{ prefix "someuser!n=user@some.where" }
{ command "NICK" }
{ parameters { } }
{ trailing "someuser2" } } }
{ trailing "someuser2" }
{ sender "someuser" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test
{ T{ nick-in-use
{ T{ rpl-nickname-in-use
{ line ":ircserver.net 433 * nickname :Nickname is already in use" }
{ prefix "ircserver.net" }
{ command "433" }
@ -72,4 +70,4 @@ IN: irc.messages.tests
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
parse-irc-line f >>timestamp ] unit-test
string>irc-message f >>timestamp ] unit-test

233
extra/irc/messages/messages.factor
View File

@ -1,179 +1,68 @@
! Copyright (C) 2008 Bruno Deferrari
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
arrays classes.tuple math.order words assocs strings irc.messages.base ;
EXCLUDE: sequences => join ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: logged-in < irc-message name ;
TUPLE: ping < irc-message ;
TUPLE: join < irc-message ;
TUPLE: part < irc-message channel ;
TUPLE: quit < irc-message ;
TUPLE: nick < irc-message ;
TUPLE: privmsg < irc-message name ;
TUPLE: kick < irc-message channel who ;
TUPLE: roomlist < irc-message channel names ;
TUPLE: nick-in-use < irc-message name ;
TUPLE: notice < irc-message type ;
TUPLE: mode < irc-message name mode parameter ;
TUPLE: names-reply < irc-message who channel ;
TUPLE: end-of-names < irc-message who channel ;
TUPLE: unhandled < irc-message ;
! connection
IRC: pass "PASS" password ;
IRC: nick "NICK" nickname ;
IRC: user "USER" user mode _ : realname ;
IRC: oper "OPER" name password ;
IRC: mode "MODE" name mode parameter ;
IRC: service "SERVICE" nickname _ distribution type _ : info ;
IRC: quit "QUIT" : comment ;
IRC: squit "SQUIT" server : comment ;
! channel operations
IRC: join "JOIN" : channel ;
IRC: part "PART" channel : comment ;
IRC: topic "TOPIC" channel : topic ;
IRC: names "NAMES" channel ;
IRC: list "LIST" channel ;
IRC: invite "INVITE" nickname channel ;
IRC: kick "KICK" channel user : comment ;
! chating
IRC: privmsg "PRIVMSG" target : text ;
IRC: notice "NOTICE" target : text ;
! server queries
IRC: motd "MOTD" target ;
IRC: lusers "LUSERS" mask target ;
IRC: version "VERSION" target ;
IRC: stats "STATS" query target ;
IRC: links "LINKS" server mask ;
IRC: time "TIME" target ;
IRC: connect "CONNECT" server port remote-server ;
IRC: trace "TRACE" target ;
IRC: admin "ADMIN" target ;
IRC: info "INFO" target ;
! service queries
IRC: servlist "SERVLIST" mask type ;
IRC: squery "SQUERY" service-name : text ;
! user queries
IRC: who "WHO" mask operator ;
IRC: whois "WHOIS" target mask ;
IRC: whowas "WHOWAS" nickname count target ;
! misc
IRC: kill "KILL" nickname : comment ;
IRC: ping "PING" server1 server2 ;
IRC: pong "PONG" server1 server2 ;
IRC: error "ERROR" : message ;
! numeric replies
IRC: rpl-welcome "001" nickname : comment ;
IRC: rpl-whois-user "311" nicnamek user host _ : real-name ;
IRC: rpl-channel-modes "324" channel mode params ;
IRC: rpl-notopic "331" channel : topic ;
IRC: rpl-topic "332" channel : topic ;
IRC: rpl-inviting "341" channel nickname ;
IRC: rpl-names "353" nickname _ channel : nicks ;
IRC: rpl-names-end "366" nickname channel : comment ;
! error replies
IRC: rpl-nickname-in-use "433" _ name ;
IRC: rpl-nick-collision "436" nickname : comment ;
: <irc-client-message> ( command parameters trailing -- irc-message )
irc-message new
now >>timestamp
swap >>trailing
swap >>parameters
swap >>command ;
M: rpl-names post-process-irc-message ( rpl-names -- )
[ [ blank? ] trim " " split ] change-nicks drop ;
<PRIVATE
GENERIC: command-string>> ( irc-message -- string )
M: irc-message command-string>> ( irc-message -- string ) command>> ;
M: ping command-string>> ( ping -- string ) drop "PING" ;
M: join command-string>> ( join -- string ) drop "JOIN" ;
M: part command-string>> ( part -- string ) drop "PART" ;
M: quit command-string>> ( quit -- string ) drop "QUIT" ;
M: nick command-string>> ( nick -- string ) drop "NICK" ;
M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
M: mode command-string>> ( mode -- string ) drop "MODE" ;
M: kick command-string>> ( kick -- string ) drop "KICK" ;
GENERIC: command-parameters>> ( irc-message -- seq )
M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
M: ping command-parameters>> ( ping -- seq ) drop { } ;
M: join command-parameters>> ( join -- seq ) drop { } ;
M: part command-parameters>> ( part -- seq ) channel>> 1array ;
M: quit command-parameters>> ( quit -- seq ) drop { } ;
M: nick command-parameters>> ( nick -- seq ) drop { } ;
M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
M: kick command-parameters>> ( kick -- seq )
[ channel>> ] [ who>> ] bi 2array ;
M: mode command-parameters>> ( mode -- seq )
[ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
M: irc-message >>command-parameters ( irc-message params -- irc-message )
drop ;
M: logged-in >>command-parameters ( part params -- part )
first >>name ;
M: privmsg >>command-parameters ( privmsg params -- privmsg )
first >>name ;
M: notice >>command-parameters ( notice params -- notice )
first >>type ;
M: part >>command-parameters ( part params -- part )
first >>channel ;
M: kick >>command-parameters ( kick params -- kick )
first2 [ >>channel ] [ >>who ] bi* ;
M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
second >>name ;
M: names-reply >>command-parameters ( names-reply params -- names-reply )
first3 nip [ >>who ] [ >>channel ] bi* ;
M: end-of-names >>command-parameters ( names-reply params -- names-reply )
first2 [ >>who ] [ >>channel ] bi* ;
M: mode >>command-parameters ( mode params -- mode )
dup length {
{ 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
{ 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
[ drop first >>name dup trailing>> >>mode ]
} case ;
PRIVATE>
GENERIC: irc-message>client-line ( irc-message -- string )
M: irc-message irc-message>client-line ( irc-message -- string )
[ command-string>> ]
[ command-parameters>> " " sjoin ]
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string )
M: irc-message irc-message>server-line ( irc-message -- string )
drop "not implemented yet" ;
<PRIVATE
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
: remove-heading-: ( seq -- seq )
":" ?head drop ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
[ remove-heading-: " " split1 ] [ f swap ] if ;
: split-trailing ( string -- string string/f )
":" split1 ;
: copy-message-in ( command irc-message -- command )
{
[ line>> >>line ]
[ prefix>> >>prefix ]
[ command>> >>command ]
[ trailing>> >>trailing ]
[ timestamp>> >>timestamp ]
[ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
} cleave ;
PRIVATE>
UNION: sender-in-prefix privmsg join part quit kick mode nick ;
GENERIC: irc-message-sender ( irc-message -- sender )
M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
prefix>> parse-name ;
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
: irc-message>command ( irc-message -- command )
[
command>> {
{ "PING" [ ping ] }
{ "NOTICE" [ notice ] }
{ "001" [ logged-in ] }
{ "433" [ nick-in-use ] }
{ "353" [ names-reply ] }
{ "366" [ end-of-names ] }
{ "JOIN" [ join ] }
{ "PART" [ part ] }
{ "NICK" [ nick ] }
{ "PRIVMSG" [ privmsg ] }
{ "QUIT" [ quit ] }
{ "MODE" [ mode ] }
{ "KICK" [ kick ] }
[ drop unhandled ]
} case new
] keep copy-message-in ;
: parse-irc-line ( string -- message )
string>irc-message irc-message>command ;
PREDICATE: channel-mode < mode name>> first "#&" member? ;
PREDICATE: participant-mode < channel-mode parameter>> ;

1
extra/irc/messages/parser/authors.txt Normal file
View File

@ -0,0 +1 @@
Bruno Deferrari

35
extra/irc/messages/parser/parser.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
arrays classes.tuple math.order words assocs
irc.messages.base sequences ;
IN: irc.messages.parser
<PRIVATE
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
: split-trailing ( string -- string string/f ) ":" split1 ;
: remove-heading-: ( seq -- seq ) ":" ?head drop ;
: split-prefix ( string -- string/f string )
dup ":" head? [
remove-heading-: " " split1
] [ f swap ] if ;
: split-message ( string -- prefix command parameters trailing )
split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip ;
: sender ( irc-message -- sender )
prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
PRIVATE>
: string>irc-message ( string -- irc-message )
dup split-message
[ [ irc>type new ] [ >>command ] bi ]
[ >>parameters ]
[ >>trailing ]
tri*
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
now >>timestamp dup sender >>sender ;

1
extra/irc/messages/parser/summary.txt Normal file
View File

@ -0,0 +1 @@
Basic parser for irc messages

1
extra/irc/messages/summary.txt Normal file
View File

@ -0,0 +1 @@
IRC message definitions

4
extra/math/analysis/analysis.factor
View File

@ -42,7 +42,7 @@ PRIVATE>
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1./0.
drop 1/0.
] [
[ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
@ -51,7 +51,7 @@ PRIVATE>
#! gammaln(x) is an alternative when gamma(x)'s range
#! varies too widely
dup 0 < [
drop 1./0.
drop 1/0.
] [
[ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;

9
extra/webapps/site-watcher/site-watcher.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs db.sqlite furnace furnace.actions furnace.alloy
furnace.auth furnace.auth.features.deactivate-user
USING: accessors assocs db.sqlite furnace furnace.actions
furnace.alloy furnace.auth furnace.auth.features.deactivate-user
furnace.auth.features.edit-profile
furnace.auth.features.recover-password
furnace.auth.features.registration furnace.auth.login
furnace.boilerplate furnace.redirection html.forms http.server
http.server.dispatchers kernel namespaces site-watcher site-watcher.db
site-watcher.private urls validators io.sockets.secure.unix.debug
io.servers.connection db db.tuples sequences webapps.site-watcher.common
webapps.site-watcher.watching webapps.site-watcher.spidering ;
io.servers.connection io.files.temp db db.tuples sequences
webapps.site-watcher.common webapps.site-watcher.watching
webapps.site-watcher.spidering ;
QUALIFIED: assocs
IN: webapps.site-watcher

4
misc/fuel/fuel-syntax.el
View File

@ -262,7 +262,8 @@
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))
("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)" (2 "<b"))
("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"
(2 "<b"))
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
@ -275,6 +276,7 @@
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
("\\_<call\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")("))