From fe55e939f95b198602ca12659fc13759c33a6fc5 Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Thu, 12 Feb 2009 23:13:16 -0500 Subject: [PATCH 01/29] Added math.dual and math.derivatives for computing with dual numbers. Also made a few more methods in math.functions generic in order to specialize them on dual numbers. --- basis/math/functions/functions.factor | 8 +- extra/math/derivatives/authors.txt | 1 + .../math/derivatives/derivatives-docs.factor | 11 +++ .../math/derivatives/derivatives-tests.factor | 4 + extra/math/derivatives/derivatives.factor | 34 +++++++ extra/math/derivatives/syntax/authors.txt | 1 + .../derivatives/syntax/syntax-docs.factor | 18 ++++ extra/math/derivatives/syntax/syntax.factor | 10 +++ extra/math/dual/authors.txt | 1 + extra/math/dual/dual-docs.factor | 90 +++++++++++++++++++ extra/math/dual/dual-tests.factor | 14 +++ extra/math/dual/dual.factor | 80 +++++++++++++++++ 12 files changed, 270 insertions(+), 2 deletions(-) create mode 100644 extra/math/derivatives/authors.txt create mode 100644 extra/math/derivatives/derivatives-docs.factor create mode 100644 extra/math/derivatives/derivatives-tests.factor create mode 100644 extra/math/derivatives/derivatives.factor create mode 100644 extra/math/derivatives/syntax/authors.txt create mode 100644 extra/math/derivatives/syntax/syntax-docs.factor create mode 100644 extra/math/derivatives/syntax/syntax.factor create mode 100644 extra/math/dual/authors.txt create mode 100644 extra/math/dual/dual-docs.factor create mode 100644 extra/math/dual/dual-tests.factor create mode 100644 extra/math/dual/dual.factor diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 85b4d711ac..3a1ce18daa 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -252,10 +252,14 @@ M: real tanh ftanh ; : -i* ( x -- y ) >rect swap neg rect> ; -: asin ( x -- y ) +GENERIC: asin ( x -- y ) foldable + +M: number asin dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline -: acos ( x -- y ) +GENERIC: acos ( x -- y ) foldable + +M: number acos dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor new file mode 100644 index 0000000000..4905f260bc --- /dev/null +++ b/extra/math/derivatives/derivatives-docs.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: math.derivatives + +ARTICLE: "math.derivatives" "Derivatives" +"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs." +{ $see-also "math.derivatives.syntax" } +; + +ABOUT: "math.derivatives" diff --git a/extra/math/derivatives/derivatives-tests.factor b/extra/math/derivatives/derivatives-tests.factor new file mode 100644 index 0000000000..f95eb43849 --- /dev/null +++ b/extra/math/derivatives/derivatives-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test automatic-differentiation.derivatives ; +IN: automatic-differentiation.derivatives.tests diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor new file mode 100644 index 0000000000..8e69cec129 --- /dev/null +++ b/extra/math/derivatives/derivatives.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.derivatives.syntax ; +IN: math.derivatives + +DERIVATIVE: + [ 2drop ] [ 2drop ] +DERIVATIVE: - [ 2drop ] [ 2drop neg ] +DERIVATIVE: * [ nip * ] [ drop * ] +DERIVATIVE: / [ nip / ] [ sq / neg * ] +! Conditional checks if the epsilon-part of the exponent is +! 0 to avoid getting float answers for integer powers. +DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ] + [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ] + +DERIVATIVE: sqrt [ sqrt 2 * / ] + +DERIVATIVE: exp [ exp * ] +DERIVATIVE: log [ / ] + +DERIVATIVE: sin [ cos * ] +DERIVATIVE: cos [ sin neg * ] +DERIVATIVE: tan [ sec sq * ] + +DERIVATIVE: sinh [ cosh * ] +DERIVATIVE: cosh [ sinh * ] +DERIVATIVE: tanh [ sech sq * ] + +DERIVATIVE: asin [ sq neg 1 + sqrt / ] +DERIVATIVE: acos [ sq neg 1 + sqrt neg / ] +DERIVATIVE: atan [ sq 1 + / ] + +DERIVATIVE: asinh [ sq 1 + sqrt / ] +DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ] +DERIVATIVE: atanh [ sq neg 1 + / ] \ No newline at end of file diff --git a/extra/math/derivatives/syntax/authors.txt b/extra/math/derivatives/syntax/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/derivatives/syntax/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/derivatives/syntax/syntax-docs.factor b/extra/math/derivatives/syntax/syntax-docs.factor new file mode 100644 index 0000000000..2273e7b83c --- /dev/null +++ b/extra/math/derivatives/syntax/syntax-docs.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: math.derivatives.syntax + +HELP: DERIVATIVE: +{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property. Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively. Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative. The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." } +{ $examples + { $unchecked-example "USING: math math.functions math.derivatives.syntax ;" + "DERIVATIVE: sin [ cos * ]" + "DERIVATIVE: * [ nip * ] [ drop * ]" "" } +} ; + +ARTICLE: "math.derivatives.syntax" "Derivative Syntax" +"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word." +; + +ABOUT: "math.derivatives.syntax" diff --git a/extra/math/derivatives/syntax/syntax.factor b/extra/math/derivatives/syntax/syntax.factor new file mode 100644 index 0000000000..02b0608ed8 --- /dev/null +++ b/extra/math/derivatives/syntax/syntax.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser words effects accessors sequences + math.ranges ; + +IN: math.derivatives.syntax + +: DERIVATIVE: scan-object dup stack-effect in>> length [1,b] + [ drop scan-object ] map + "derivative" set-word-prop ; parsing \ No newline at end of file diff --git a/extra/math/dual/authors.txt b/extra/math/dual/authors.txt new file mode 100644 index 0000000000..b6089d8622 --- /dev/null +++ b/extra/math/dual/authors.txt @@ -0,0 +1 @@ +Jason W. Merrill \ No newline at end of file diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor new file mode 100644 index 0000000000..de3b0749a5 --- /dev/null +++ b/extra/math/dual/dual-docs.factor @@ -0,0 +1,90 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ; +IN: math.dual + +HELP: +{ $values + { "ordinary-part" real } { "epsilon-part" real } + { "dual" dual number } +} +{ $description "Creates a dual number from its ordinary and epsilon parts." } ; + +HELP: d* +{ $values + { "x" dual } { "y" dual } + { "x*y" dual } +} +{ $description "Multiply dual numbers." } ; + +HELP: d+ +{ $values + { "x" dual } { "y" dual } + { "x+y" dual } +} +{ $description "Add dual numbers." } ; + +HELP: d- +{ $values + { "x" dual } { "y" dual } + { "x-y" dual } +} +{ $description "Subtract dual numbers." } ; + +HELP: d/ +{ $values + { "x" dual } { "y" dual } + { "x/y" dual } +} +{ $description "Divide dual numbers." } +{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ; + +HELP: d^ +{ $values + { "x" dual } { "y" dual } + { "x^y" dual } +} +{ $description "Raise a dual number to a (possibly dual) power" } ; + +HELP: define-dual-method +{ $values + { "word" word } +} +{ $description "Defines a method on the dual numbers for generic word." } +{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ; + +{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words + +HELP: dual +{ $class-description "The class of dual numbers with non-zero epsilon part." } ; + +HELP: dual-op +{ $values + { "word" word } +} +{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." } +{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." } +{ $examples + { $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;" + "DERIVATIVE: sin [ cos * ]" + "M: dual sin \\sin dual-op ;" "" } + { $unchecked-example "USING: math math.dual math.derivatives.syntax ;" + "DERIVATIVE: * [ drop ] [ nip ]" + ": d* ( x y -- x*y ) \ * dual-op ;" "" } +} ; + +HELP: unpack-dual +{ $values + { "dual" dual } + { "ordinary-part" number } { "epsilon-part" number } +} +{ $description "Extracts the ordinary and epsilon part of a dual number." } ; + +ARTICLE: "math.dual" "Dual Numbers" +"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers." +$nl +"Dual numbers are ordered pairs " { $snippet ""} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "* = " } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f() = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "." +; + + +ABOUT: "math.dual" diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor new file mode 100644 index 0000000000..2fe751dd63 --- /dev/null +++ b/extra/math/dual/dual-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test math.dual kernel accessors math math.functions + math.constants ; +IN: math.dual.tests + +[ 0.0 1.0 ] [ 0 1 sin unpack-dual ] unit-test +[ 1.0 0.0 ] [ 0 1 cos unpack-dual ] unit-test +[ 3 5 ] [ 1 5 2 d+ unpack-dual ] unit-test +[ 0 -1 ] [ 1 5 1 6 d- unpack-dual ] unit-test +[ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test +[ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test +[ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test +[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor new file mode 100644 index 0000000000..214db9b678 --- /dev/null +++ b/extra/math/dual/dual.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2009 Jason W. Merrill. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.derivatives accessors + macros words effects sequences generalizations fry + combinators.smart generic compiler.units ; + +IN: math.dual + +TUPLE: dual ordinary-part epsilon-part ; + +C: dual + +! Ordinary numbers implement the dual protocol by returning +! themselves as the ordinary part, and 0 as the epsilon part. +M: number ordinary-part>> ; + +M: number epsilon-part>> drop 0 ; + +: unpack-dual ( dual -- ordinary-part epsilon-part ) + [ ordinary-part>> ] [ epsilon-part>> ] bi ; + +> length ; + +MACRO: ordinary-op ( word -- o ) + [ input-length ] keep + '[ [ ordinary-part>> ] _ napply _ execute ] ; + +! Takes N dual numbers ... and weaves +! their ordinary and epsilon parts to produce +! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN +! This allows a set of partial derivatives each to be evaluated +! at the same point. +MACRO: duals>nweave ( n -- ) + dup dup dup + '[ + [ [ epsilon-part>> ] _ napply ] + _ nkeep + [ ordinary-part>> ] _ napply + _ nweave + ] ; + +MACRO: chain-rule ( word -- e ) + [ input-length '[ _ duals>nweave ] ] + [ "derivative" word-prop ] + [ input-length 1+ '[ _ nspread ] ] + tri + '[ [ @ _ @ ] sum-outputs ] ; + +PRIVATE> + +MACRO: dual-op ( word -- ) + [ '[ _ ordinary-op ] ] + [ input-length '[ _ nkeep ] ] + [ '[ _ chain-rule ] ] + tri + '[ _ @ @ ] ; + +: define-dual-method ( word -- ) + [ \ dual swap create-method ] keep '[ _ dual-op ] define ; + +! Specialize math functions to operate on dual numbers. +[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan } + [ define-dual-method ] each ] with-compilation-unit + +! Inverse methods { asinh, acosh, atanh } are not generic, so +! there is no way to specialize them for dual numbers. However, +! they are defined in terms of functions that can operate on +! dual numbers and arithmetic methods, so if it becomes +! possible to make arithmetic operators work directly on dual +! numbers, we will get these for free. + +! Arithmetic methods are not generic (yet?), so we have to +! define special versions of them to operate on dual numbers. +: d+ ( x y -- x+y ) \ + dual-op ; +: d- ( x y -- x-y ) \ - dual-op ; +: d* ( x y -- x*y ) \ * dual-op ; +: d/ ( x y -- x/y ) \ / dual-op ; +: d^ ( x y -- x^y ) \ ^ dual-op ; \ No newline at end of file From b3e20dfdf2bba6c85c6828e7f38876fc35a54d08 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 15:10:46 -0600 Subject: [PATCH 02/29] better factor annotations docs --- extra/annotations/annotations-docs.factor | 30 ++++++++++++++--------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index c340554119..1effdf4067 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -9,6 +9,22 @@ IN: annotations : comment-usage.-word ( base -- word ) "s." append "annotations" lookup ; PRIVATE> +: $annotation ( element -- ) + P first + [ "!" " your comment here" surround 1array $syntax ] + [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ] + [ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ] + tri ; + +: $annotation-usage. ( element -- ) + first + [ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ; + +: $annotation-usage ( element -- ) + first + { "usages" sequence } $values + [ "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray ] bi 1array $description ; + "Code annotations" { "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism." @@ -26,17 +42,9 @@ annotation-tags natural-sort annotation-tags [ { - [ [ \ $syntax ] dip "!" " your comment here" surround 2array ] - [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ] - [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] - [ comment-word set-word-help ] - - [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ] - [ comment-usage.-word set-word-help ] - - [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ] - [ comment-usage-word set-word-help ] - + [ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ] + [ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ] + [ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ] [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] } cleave ] each From 8169c35b9ef5b2e25d7a439dcd2c80f712ed73b0 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Tue, 17 Feb 2009 16:40:01 +0900 Subject: [PATCH 03/29] io.encodings.korean TODOs --- basis/io/encodings/korean/korean.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index cd98bb1eb0..8771c1d928 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,6 +6,11 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean +! TODO: write-docs +! TODO: euckr, cp949 seperate (euckr: backslash = Won, cp949: bs <> Won) +! TODO: no byte manip. only code-tables. +! TODO: migrate to common code-table parser (by Dan). + SINGLETON: cp949 cp949 "EUC-KR" register-encoding From da9ae85637008259c5da1e21b5c070c672fce651 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Tue, 17 Feb 2009 21:46:57 +0900 Subject: [PATCH 04/29] io.encodings.korean some docs. --- basis/io/encodings/korean/korean-docs.factor | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 basis/io/encodings/korean/korean-docs.factor diff --git a/basis/io/encodings/korean/korean-docs.factor b/basis/io/encodings/korean/korean-docs.factor new file mode 100644 index 0000000000..2500e794a7 --- /dev/null +++ b/basis/io/encodings/korean/korean-docs.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Yun, Jonghyouk. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup ; +IN: io.encodings.korean + +ARTICLE: "io.encodings.korean" "Korean text encodings" +"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings." +{ $subsection cp949 } ; + +ABOUT: "io.encodings.korean" + +HELP: cp949 +{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " } +{ $see-also "encodings-introduction" } ; From 89a3e45a3abe17c8a3199391213d0db00502a570 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Tue, 17 Feb 2009 21:47:45 +0900 Subject: [PATCH 05/29] io.encodings.korean TODOs comment --- basis/io/encodings/korean/korean.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index 8771c1d928..c1fed1d57c 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,7 +6,6 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean -! TODO: write-docs ! TODO: euckr, cp949 seperate (euckr: backslash = Won, cp949: bs <> Won) ! TODO: no byte manip. only code-tables. ! TODO: migrate to common code-table parser (by Dan). From 4440a210b101b3cbde5ca545f4c2d3d4a104973a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:28:43 -0600 Subject: [PATCH 06/29] make io.servers.packet load again --- basis/io/servers/packet/{datagram.factor => packet.factor} | 3 +++ 1 file changed, 3 insertions(+) rename basis/io/servers/packet/{datagram.factor => packet.factor} (80%) diff --git a/basis/io/servers/packet/datagram.factor b/basis/io/servers/packet/packet.factor similarity index 80% rename from basis/io/servers/packet/datagram.factor rename to basis/io/servers/packet/packet.factor index c081dfb0fa..3f092ab9f1 100644 --- a/basis/io/servers/packet/datagram.factor +++ b/basis/io/servers/packet/packet.factor @@ -1,3 +1,5 @@ +USING: concurrency.combinators destructors fry +io.servers.datagram.private io.sockets kernel logging ; IN: io.servers.datagram : with-datagrams ( seq service quot -- ) + [ DEBUG ] dip '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline From d92b02b0c29414e6b8ddf5242451024d8a8fedc8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:30:06 -0600 Subject: [PATCH 07/29] use the new with-logging --- basis/io/servers/connection/connection.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index bc90915213..91fb3bfb37 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -12,6 +12,7 @@ IN: io.servers.connection TUPLE: threaded-server name +log-level secure insecure secure-config sockets @@ -29,6 +30,7 @@ ready ; : new-threaded-server ( class -- threaded-server ) new "server" >>name + DEBUG >>log-level ascii >>encoding 1 minutes >>timeout V{ } clone >>sockets @@ -115,7 +117,7 @@ M: threaded-server handle-client* handler>> call ; : (start-server) ( threaded-server -- ) init-server dup threaded-server [ - dup name>> [ + [ ] [ name>> ] [ log-level>> ] tri [ [ listen-on [ start-accept-loop ] parallel-each ] [ ready>> raise-flag ] bi From e55425a65e20565879fb728ebe22e3a18aa892e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:30:28 -0600 Subject: [PATCH 08/29] with-logging takes a log-level, more docs --- basis/logging/insomniac/insomniac.factor | 2 +- basis/logging/logging-docs.factor | 11 +++++---- basis/logging/logging.factor | 30 ++++++++++++++++++++---- basis/logging/parser/parser.factor | 4 ++-- 4 files changed, 35 insertions(+), 12 deletions(-) diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 91baae631f..935326da2d 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -30,7 +30,7 @@ SYMBOL: insomniac-recipients \ (email-log-report) NOTICE add-error-logging : email-log-report ( service word-names -- ) - "logging.insomniac" [ (email-log-report) ] with-logging ; + "logging.insomniac" DEBUG [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) [ [ email-log-report ] assoc-each rotate-logs ] 2curry diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 275d900f3d..64956493c6 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -8,6 +8,9 @@ HELP: DEBUG HELP: NOTICE { $description "Log level for ordinary messages." } ; +HELP: WARNING +{ $description "Log level for warnings." } ; + HELP: ERROR { $description "Log level for error messages." } ; @@ -18,6 +21,7 @@ ARTICLE: "logging.levels" "Log levels" "Several log levels are supported, from lowest to highest:" { $subsection DEBUG } { $subsection NOTICE } +{ $subsection WARNING } { $subsection ERROR } { $subsection CRITICAL } ; @@ -36,7 +40,7 @@ ARTICLE: "logging.files" "Log files" HELP: log-message { $values { "msg" string } { "word" word } { "level" "a log level" } } -{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; +{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; HELP: add-logging { $values { "level" "a log level" } { "word" word } } @@ -90,8 +94,8 @@ HELP: close-logs { $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ; HELP: with-logging -{ $values { "service" "a log service name" } { "quot" quotation } } -{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ; +{ $values { "service" "a log service name" } { "level" "a log level" } { "quot" quotation } } +{ $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ; ARTICLE: "logging.rotation" "Log rotation" "Log files should be rotated periodically to prevent unbounded growth." @@ -120,4 +124,3 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.server" } ; ABOUT: "logging" - diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 6769932c88..2389389074 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -4,12 +4,29 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects generalizations parser strings -quotations fry accessors ; +quotations fry accessors math assocs math.order ; IN: logging SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; -: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; +SYMBOL: log-level + +: log-levels ( -- assoc ) + H{ + { DEBUG 0 } + { NOTICE 10 } + { WARNING 20 } + { ERROR 30 } + { CRITICAL 40 } + } ; + +ERROR: undefined-log-level ; + +: log-level<=> ( log-level log-level -- ? ) + [ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ; + +: log? ( log-level -- ? ) + log-level get log-level<=> +lt+ = not ; : send-to-log-server ( array string -- ) prefix "log-server" get send ; @@ -22,7 +39,8 @@ SYMBOL: log-service : log-message ( msg word level -- ) check-log-message - log-service get dup [ + dup log? + log-service get dup and [ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip 4array "log-message" send-to-log-server ] [ @@ -35,8 +53,10 @@ SYMBOL: log-service : close-logs ( -- ) { } "close-logs" send-to-log-server ; -: with-logging ( service quot -- ) - log-service swap with-variable ; inline +: with-logging ( service level quot -- ) + '[ + _ log-service [ _ log-level _ with-variable ] with-variable + ] call ; inline ! Aspect-oriented programming idioms diff --git a/basis/logging/parser/parser.factor b/basis/logging/parser/parser.factor index 07a84ec5c6..5406d8fcd0 100644 --- a/basis/logging/parser/parser.factor +++ b/basis/logging/parser/parser.factor @@ -3,7 +3,7 @@ USING: accessors peg peg.parsers memoize kernel sequences logging arrays words strings vectors io io.files io.encodings.utf8 namespaces make combinators logging.server -calendar calendar.format ; +calendar calendar.format assocs ; IN: logging.parser TUPLE: log-entry date level word-name message ; @@ -21,7 +21,7 @@ SYMBOL: multiline "[" "]" surrounded-by ; : 'log-level' ( -- parser ) - log-levels [ + log-levels keys [ [ name>> token ] keep [ nip ] curry action ] map choice ; From bf3ef49dd0492f2b2a93d1dcfd002cb753bb67d6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:31:01 -0600 Subject: [PATCH 09/29] with-logging change --- extra/spider/spider.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index bd5b2668be..0f702d7d22 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -88,7 +88,7 @@ links processing-time timestamp ; PRIVATE> : run-spider ( spider -- spider ) - "spider" [ + "spider" DEBUG [ dup spider [ queue-initial-links [ todo>> ] [ max-depth>> ] bi From b3e3c74561d6b23c875e2d2cc2c06581a7b11839 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 11:40:50 -0600 Subject: [PATCH 10/29] add ; to word definition in stack-checker docs --- basis/stack-checker/stack-checker-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5926f08d8c..db8abac441 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -56,7 +56,7 @@ ARTICLE: "inference-recursive" "Stack effects of recursive words" "When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." $nl "Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." } +{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } "If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" From cbe99c4bedbda5520c1ae7aa7e6804277c5a914e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 12:36:27 -0600 Subject: [PATCH 11/29] use +foo+ as symbol names --- basis/tools/files/files.factor | 49 ++++++++++++------------ basis/tools/files/unix/unix.factor | 19 +++++---- basis/tools/files/windows/windows.factor | 2 +- 3 files changed, 37 insertions(+), 33 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 7508c37cac..8d882099de 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -35,9 +35,10 @@ IN: tools.files PRIVATE> -SYMBOLS: file-name file-name/type permissions file-type nlinks file-size -file-date file-time file-datetime uid gid user group link-target unix-datetime -directory-or-size ; +SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+ ++nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+ ++uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+ ++directory-or-size+ ; TUPLE: listing-tool path specs sort ; @@ -48,10 +49,10 @@ C: file-listing : ( path -- listing-tool ) listing-tool new swap >>path - { file-name } >>specs ; + { +file-name+ } >>specs ; : list-slow? ( listing-tool -- ? ) - specs>> { file-name } sequence= not ; + specs>> { +file-name+ } sequence= not ; ERROR: unknown-file-spec symbol ; @@ -59,12 +60,12 @@ HOOK: file-spec>string os ( file-listing spec -- string ) M: object file-spec>string ( file-listing spec -- string ) { - { file-name [ directory-entry>> name>> ] } - { directory-or-size [ file-info>> dir-or-size ] } - { file-size [ file-info>> size>> number>string ] } - { file-date [ file-info>> modified>> listing-date ] } - { file-time [ file-info>> modified>> listing-time ] } - { file-datetime [ file-info>> modified>> timestamp>ymdhms ] } + { +file-name+ [ directory-entry>> name>> ] } + { +directory-or-size+ [ file-info>> dir-or-size ] } + { +file-size+ [ file-info>> size>> number>string ] } + { +file-date+ [ file-info>> modified>> listing-date ] } + { +file-time+ [ file-info>> modified>> listing-time ] } + { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] } [ unknown-file-spec ] } case ; @@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines ) : directory. ( path -- ) (directory.) simple-table. ; -SYMBOLS: device-name mount-point type -available-space free-space used-space total-space -percent-used percent-free ; +SYMBOLS: +device-name+ +mount-point+ +type+ ++available-space+ +free-space+ +used-space+ +total-space+ ++percent-used+ +percent-free+ ; : percent ( real -- integer ) 100 * >integer ; inline : file-system-spec ( file-system-info obj -- str ) { - { device-name [ device-name>> "" or ] } - { mount-point [ mount-point>> "" or ] } - { type [ type>> "" or ] } - { available-space [ available-space>> 0 or ] } - { free-space [ free-space>> 0 or ] } - { used-space [ used-space>> 0 or ] } - { total-space [ total-space>> 0 or ] } - { percent-used [ + { +device-name+ [ device-name>> "" or ] } + { +mount-point+ [ mount-point>> "" or ] } + { +type+ [ type>> "" or ] } + { +available-space+ [ available-space>> 0 or ] } + { +free-space+ [ free-space>> 0 or ] } + { +used-space+ [ used-space>> 0 or ] } + { +total-space+ [ total-space>> 0 or ] } + { +percent-used+ [ [ used-space>> ] [ total-space>> ] bi [ 0 or ] bi@ dup 0 = [ 2drop 0 ] [ / percent ] if @@ -116,8 +117,8 @@ percent-used percent-free ; : file-systems. ( -- ) { - device-name available-space free-space used-space - total-space percent-used mount-point + +device-name+ +available-space+ +free-space+ +used-space+ + +total-space+ +percent-used+ +mount-point+ } print-file-systems ; { diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index e63ab09076..90e91529a1 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -47,21 +47,24 @@ IN: tools.files.unix M: unix (directory.) ( path -- lines ) - { permissions nlinks user group file-size file-date file-name } >>specs + { + +permissions+ +nlinks+ +user+ +group+ + +file-size+ +file-date+ +file-name+ + } >>specs { { directory-entry>> name>> <=> } } >>sort [ [ list-files ] with-group-cache ] with-user-cache ; M: unix file-spec>string ( file-listing spec -- string ) { - { file-name/type [ + { +file-name/type+ [ directory-entry>> [ name>> ] [ file-type>trailing ] bi append ] } - { permissions [ file-info>> permissions-string ] } - { nlinks [ file-info>> nlink>> number>string ] } - { user [ file-info>> uid>> user-name ] } - { group [ file-info>> gid>> group-name ] } - { uid [ file-info>> uid>> number>string ] } - { gid [ file-info>> gid>> number>string ] } + { +permissions+ [ file-info>> permissions-string ] } + { +nlinks+ [ file-info>> nlink>> number>string ] } + { +user+ [ file-info>> uid>> user-name ] } + { +group+ [ file-info>> gid>> group-name ] } + { +uid+ [ file-info>> uid>> number>string ] } + { +gid+ [ file-info>> gid>> number>string ] } [ call-next-method ] } case ; diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index f321c2fc7f..874b2ef5c1 100755 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -9,7 +9,7 @@ IN: tools.files.windows M: windows (directory.) ( entries -- lines ) - { file-datetime directory-or-size file-name } >>specs + { +file-datetime+ +directory-or-size+ +file-name+ } >>specs { { directory-entry>> name>> <=> } } >>sort list-files ; From 894ba6182ec2cd9fa3e19df0db1bfd389f2c19d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 17 Feb 2009 17:09:27 -0600 Subject: [PATCH 12/29] add timestamp>mdtm to calendar.format --- basis/calendar/format/format-tests.factor | 7 +++++++ basis/calendar/format/format.factor | 3 +++ 2 files changed, 10 insertions(+) diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index 81930cdf49..f8864351a4 100644 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -51,6 +51,11 @@ IN: calendar.format.tests timestamp>string ] unit-test +[ "20080504070000" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>mdtm +] unit-test + [ T{ timestamp f 2008 @@ -74,3 +79,5 @@ IN: calendar.format.tests { gmt-offset T{ duration f 0 0 0 0 0 0 } } } ] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test + + diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 15a4cb8266..916d3499fe 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -78,6 +78,9 @@ M: integer year. ( n -- ) M: timestamp year. ( timestamp -- ) year>> year. ; +: timestamp>mdtm ( timestamp -- str ) + [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ; + : (timestamp>string) ( timestamp -- ) { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; From fdad5d4d979cd004dd11ab0cb7b419589a4d4932 Mon Sep 17 00:00:00 2001 From: "Yun, Jonghyouk" Date: Wed, 18 Feb 2009 19:19:18 +0900 Subject: [PATCH 13/29] io.encodings.korean TODO removes --- basis/io/encodings/korean/korean.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor index c1fed1d57c..a021cfce33 100644 --- a/basis/io/encodings/korean/korean.factor +++ b/basis/io/encodings/korean/korean.factor @@ -6,8 +6,6 @@ math.order math.parser memoize multiline sequences splitting values hashtables io.binary ; IN: io.encodings.korean -! TODO: euckr, cp949 seperate (euckr: backslash = Won, cp949: bs <> Won) -! TODO: no byte manip. only code-tables. ! TODO: migrate to common code-table parser (by Dan). SINGLETON: cp949 From 2af9d5a6df34a3a6f1473aa959cc2e68902ead1f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:33:55 -0600 Subject: [PATCH 14/29] add canonicalize-path, fix a bug in file-extension --- core/io/pathnames/pathnames-docs.factor | 14 +++++++++++++- core/io/pathnames/pathnames-tests.factor | 4 ++++ core/io/pathnames/pathnames.factor | 9 ++++++++- 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor index a4f261391a..f5ad6e533b 100644 --- a/core/io/pathnames/pathnames-docs.factor +++ b/core/io/pathnames/pathnames-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax io.backend io.files strings ; +USING: help.markup help.syntax io.backend io.files strings +sequences ; IN: io.pathnames HELP: path-separator? @@ -22,6 +23,10 @@ HELP: file-name { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } } ; +HELP: path-components +{ $values { "path" "a pathnames string" } { "seq" sequence } } +{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ; + HELP: append-path { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; @@ -57,6 +62,10 @@ HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; +HELP: canonicalize-path +{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } } +{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ; + HELP: { $values { "string" "a pathname string" } { "pathname" pathname } } { $description "Creates a new " { $link pathname } "." } ; @@ -74,9 +83,12 @@ ARTICLE: "io.pathnames" "Pathname manipulation" { $subsection POSTPONE: P" } "Pathname manipulation:" { $subsection normalize-path } +{ $subsection canonicalize-path } { $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } +{ $subsection path-components } +{ $subsection prepend-path } { $subsection append-path } "Pathname presentations:" { $subsection pathname } diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor index 41498fa15a..c3e419e60d 100644 --- a/core/io/pathnames/pathnames-tests.factor +++ b/core/io/pathnames/pathnames-tests.factor @@ -66,3 +66,7 @@ IN: io.pathnames.tests ] with-scope [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test + +! Regression test for bug in file-extension +[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test +[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index 96ac872826..eba3e6a19f 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -119,7 +119,14 @@ PRIVATE> ] unless ; : file-extension ( filename -- extension ) - "." split1-last nip ; + file-name "." split1-last nip ; + +: path-components ( path -- seq ) + normalize-path path-separator split harvest ; + +HOOK: canonicalize-path os ( path -- path' ) + +M: object canonicalize-path normalize-path ; : resource-path ( path -- newpath ) "resource-path" get prepend-path ; From 6324fb6c13c3d74b6cf7e2d8b272163ba39f71af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:34:45 -0600 Subject: [PATCH 15/29] add unix canonicalize-path --- basis/io/files/info/unix/linux/linux.factor | 3 ++- basis/io/files/links/unix/unix.factor | 7 ++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 5dddca4f9d..72401004ae 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -72,13 +72,14 @@ M: linux file-systems ] map ; : (find-mount-point) ( path mtab-paths -- mtab-entry ) - [ follow-links ] dip 2dup at* [ + 2dup at* [ 2nip ] [ drop [ parent-directory ] dip (find-mount-point) ] if ; : find-mount-point ( path -- mtab-entry ) + canonicalize-path parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; ERROR: file-system-not-found ; diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 2f38c39e02..7d2a6ee4f3 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.files.links system unix ; +USING: io.backend io.files.links system unix io.pathnames kernel +io.files sequences ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) @@ -8,3 +9,7 @@ M: unix make-link ( path1 path2 -- ) M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; + +M: unix canonicalize-path ( path -- path' ) + path-components "/" + [ append-path dup exists? [ follow-links ] when ] reduce ; From 1045b904be7c85521cea91992a6263f38cb07013 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:35:55 -0600 Subject: [PATCH 16/29] fix logging check, unit tests --- basis/logging/logging-tests.factor | 2 +- basis/logging/logging.factor | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor index 796c8769fc..63eecc7319 100644 --- a/basis/logging/logging-tests.factor +++ b/basis/logging/logging-tests.factor @@ -13,7 +13,7 @@ USING: tools.test logging math ; \ error-logging-test ERROR add-error-logging -"logging-test" [ +"logging-test" DEBUG [ [ 4 ] [ 1 3 input-logging-test ] unit-test [ 4 ] [ 1 3 output-logging-test ] unit-test diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 2389389074..496dae2c61 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -33,14 +33,16 @@ ERROR: undefined-log-level ; SYMBOL: log-service +ERROR: bad-log-message-parameters msg word level ; + : check-log-message ( msg word level -- msg word level ) 3dup [ string? ] [ word? ] [ word? ] tri* and and - [ "Bad parameters to log-message" throw ] unless ; inline + [ bad-log-message-parameters ] unless ; inline : log-message ( msg word level -- ) check-log-message - dup log? - log-service get dup and [ + log-service get + 2dup [ log? ] [ ] bi* and [ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip 4array "log-message" send-to-log-server ] [ From 966627a1e2b1168d7d34dbd50cabc0961641abe9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 13:36:23 -0600 Subject: [PATCH 17/29] make ftp server work with firefox, simplify some code --- basis/ftp/ftp.factor | 9 +- basis/ftp/server/server.factor | 406 +++++++++++++++++---------------- 2 files changed, 212 insertions(+), 203 deletions(-) diff --git a/basis/ftp/ftp.factor b/basis/ftp/ftp.factor index adf7d5b41b..27eebc5946 100644 --- a/basis/ftp/ftp.factor +++ b/basis/ftp/ftp.factor @@ -4,8 +4,7 @@ USING: accessors arrays assocs combinators io io.files kernel math.parser sequences strings ; IN: ftp -SINGLETON: active -SINGLETON: passive +SYMBOLS: +active+ +passive+ ; TUPLE: ftp-response n strings parsed ; @@ -17,5 +16,7 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; -: ftp-ipv4 1 ; inline -: ftp-ipv6 2 ; inline + +CONSTANT: ftp-ipv4 1 + +CONSTANT: ftp-ipv6 2 diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 20a753785c..ffe16b2f4c 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -1,52 +1,46 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit accessors combinators io -io.encodings.8-bit io.encodings io.encodings.binary -io.encodings.utf8 io.files io.files.info io.directories -io.sockets kernel math.parser namespaces make sequences -ftp io.launcher.unix.parser unicode.case splitting -assocs classes io.servers.connection destructors calendar -io.timeouts io.streams.duplex threads continuations math -concurrency.promises byte-arrays io.backend tools.hexdump -io.streams.string math.bitwise tools.files io.pathnames ; +USING: accessors assocs byte-arrays calendar classes +combinators combinators.short-circuit concurrency.promises +continuations destructors ftp io io.backend io.directories +io.encodings io.encodings.8-bit io.encodings.binary +tools.files io.encodings.utf8 io.files io.files.info +io.pathnames io.launcher.unix.parser io.servers.connection +io.sockets io.streams.duplex io.streams.string io.timeouts +kernel make math math.bitwise math.parser namespaces sequences +splitting threads unicode.case logging calendar.format +strings io.files.links io.files.types ; IN: ftp.server -TUPLE: ftp-client url mode state command-promise user password ; - -: ( url -- ftp-client ) - ftp-client new - swap >>url ; - +SYMBOL: server SYMBOL: client -: ftp-server-directory ( -- str ) - \ ftp-server-directory get-global "resource:temp" or - normalize-path ; +TUPLE: ftp-server < threaded-server { serving-directory string } ; + +TUPLE: ftp-client user password extra-connection ; TUPLE: ftp-command raw tokenized ; - -: ( -- obj ) - ftp-command new ; +: ( str -- obj ) + dup \ DEBUG log-message + ftp-command new + over >>raw + swap tokenize-command >>tokenized ; TUPLE: ftp-get path ; - : ( path -- obj ) ftp-get new swap >>path ; TUPLE: ftp-put path ; - : ( path -- obj ) ftp-put new swap >>path ; TUPLE: ftp-list ; - C: ftp-list -: read-command ( -- ftp-command ) - readln - [ >>raw ] [ tokenize-command >>tokenized ] bi ; +TUPLE: ftp-disconnect ; +C: ftp-disconnect : (send-response) ( n string separator -- ) [ number>string write ] 2dip write ftp-send ; @@ -56,28 +50,50 @@ C: ftp-list [ but-last-slice [ "-" (send-response) ] with each ] [ first " " (send-response) ] 2bi ; -: server-response ( n string -- ) +: server-response ( string n -- ) + 2dup number>string swap ":" glue \ server-response DEBUG log-message - swap add-response-line swap >>n + swap add-response-line send-response ; -: ftp-error ( string -- ) - 500 "Unrecognized command: " rot append server-response ; +: serving? ( path -- ? ) + normalize-path server get serving-directory>> head? ; + +: can-serve-directory? ( path -- ? ) + canonicalize-path + { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; + +: can-serve-file? ( path -- ? ) + canonicalize-path + { + [ exists? ] + [ file-info type>> +regular-file+ = ] + [ serving? ] + } 1&& ; + +: can-serve? ( path -- ? ) + [ can-serve-file? ] [ can-serve-directory? ] bi or ; + +: ftp-error ( string -- ) 500 server-response ; +: ftp-syntax-error ( string -- ) 501 server-response ; +: ftp-unimplemented ( string -- ) 502 server-response ; +: ftp-file-not-available ( string -- ) 550 server-response ; +: ftp-illegal-file-name ( string -- ) 553 server-response ; : send-banner ( -- ) - 220 "Welcome to " host-name append server-response ; + "Welcome to " host-name append 220 server-response ; : anonymous-only ( -- ) - 530 "This FTP server is anonymous only." server-response ; + "This FTP server is anonymous only." 530 server-response ; : handle-QUIT ( obj -- ) - drop 221 "Goodbye." server-response ; + drop "Goodbye." 221 server-response ; : handle-USER ( ftp-command -- ) [ tokenized>> second client get (>>user) - 331 "Please specify the password." server-response + "Please specify the password." 331 server-response ] [ 2drop "bad USER" ftp-error ] recover ; @@ -85,7 +101,7 @@ C: ftp-list : handle-PASS ( ftp-command -- ) [ tokenized>> second client get (>>password) - 230 "Login successful" server-response + "Login successful" 230 server-response ] [ 2drop "PASS error" ftp-error ] recover ; @@ -102,7 +118,7 @@ ERROR: type-error type ; : handle-TYPE ( obj -- ) [ tokenized>> second parse-type - [ 200 ] dip "Switching to " " mode" surround server-response + "Switching to " " mode" surround 200 server-response ] [ 2drop "TYPE is binary only" ftp-error ] recover ; @@ -115,65 +131,57 @@ ERROR: type-error type ; : handle-PWD ( obj -- ) drop - 257 current-directory get "\"" dup surround server-response ; + current-directory get "\"" dup surround 257 server-response ; : handle-SYST ( obj -- ) drop - 215 "UNIX Type: L8" server-response ; - -: if-command-promise ( quot -- ) - [ client get command-promise>> ] dip - [ "Establish an active or passive connection first" ftp-error ] if* ; - -: handle-STOR ( obj -- ) - [ - tokenized>> second - [ [ ] dip fulfill ] if-command-promise - ] [ - 2drop - ] recover ; - -! EPRT |2|::1|62138| -! : handle-EPRT ( obj -- ) - ! tokenized>> second "|" split harvest ; + "UNIX Type: L8" 215 server-response ; : start-directory ( -- ) - 150 "Here comes the directory listing." server-response ; + "Here comes the directory listing." 150 server-response ; + +: transfer-outgoing-file ( path -- ) + [ "Opening BINARY mode data connection for " ] dip + [ file-name ] [ + file-info size>> number>string + "(" " bytes)." surround + ] bi " " glue append 150 server-response ; + +: transfer-incoming-file ( path -- ) + "Opening BINARY mode data connection for " prepend + 150 server-response ; + +: finish-file-transfer ( -- ) + "File send OK." 226 server-response ; + +GENERIC: handle-passive-command ( stream obj -- ) + +: passive-loop ( server -- ) + [ + [ + |dispose + 30 seconds over set-timeout + accept drop &dispose + client get extra-connection>> + 30 seconds ?promise-timeout + handle-passive-command + ] + [ client get f >>extra-connection drop ] + [ drop ] cleanup + ] with-destructors ; : finish-directory ( -- ) - 226 "Directory send OK." server-response ; + "Directory send OK." 226 server-response ; -GENERIC: service-command ( stream obj -- ) - -M: ftp-list service-command ( stream obj -- ) +M: ftp-list handle-passive-command ( stream obj -- ) drop start-directory [ utf8 encode-output [ current-directory get directory. ] with-string-writer string-lines harvest [ ftp-send ] each - ] with-output-stream - finish-directory ; + ] with-output-stream finish-directory ; -: transfer-outgoing-file ( path -- ) - [ - 150 - "Opening BINARY mode data connection for " - ] dip - [ - file-name - ] [ - file-info size>> number>string - "(" " bytes)." surround - ] bi " " glue append server-response ; - -: transfer-incoming-file ( path -- ) - [ 150 ] dip "Opening BINARY mode data connection for " prepend - server-response ; - -: finish-file-transfer ( -- ) - 226 "File send OK." server-response ; - -M: ftp-get service-command ( stream obj -- ) +M: ftp-get handle-passive-command ( stream obj -- ) [ path>> [ transfer-outgoing-file ] @@ -183,7 +191,7 @@ M: ftp-get service-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -M: ftp-put service-command ( stream obj -- ) +M: ftp-put handle-passive-command ( stream obj -- ) [ path>> [ transfer-incoming-file ] @@ -193,165 +201,165 @@ M: ftp-put service-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -: passive-loop ( server -- ) - [ - [ - |dispose - 30 seconds over set-timeout - accept drop &dispose - client get command-promise>> - 30 seconds ?promise-timeout - service-command - ] - [ client get f >>command-promise drop ] - [ drop ] cleanup - ] with-destructors ; +M: ftp-disconnect handle-passive-command ( stream obj -- ) + drop dispose ; + +: fulfill-client ( obj -- ) + client get extra-connection>> [ + fulfill + ] [ + drop + "Establish an active or passive connection first" ftp-error + ] if* ; + +: handle-STOR ( obj -- ) + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + drop + fulfill-client + ] if ; : handle-LIST ( obj -- ) - drop - [ [ ] dip fulfill ] if-command-promise ; - -: handle-SIZE ( obj -- ) - [ - [ 213 ] dip - tokenized>> second file-info size>> - number>string server-response + drop current-directory get + can-serve-directory? [ + fulfill-client ] [ - 2drop - 550 "Could not get file size" server-response - ] recover ; + fulfill-client + ] if ; + +: not-a-plain-file ( path -- ) + ": not a plain file." append ftp-error ; : handle-RETR ( obj -- ) - [ tokenized>> second swap fulfill ] - curry if-command-promise ; + tokenized>> second + dup can-serve-file? [ + fulfill-client + ] [ + not-a-plain-file + fulfill-client + ] if ; + +: handle-SIZE ( obj -- ) + tokenized>> second + dup can-serve-file? [ + file-info size>> number>string 213 server-response + ] [ + not-a-plain-file + ] if ; : expect-connection ( -- port ) + client get (>>extra-connection) random-local-server - client get >>command-promise drop [ [ passive-loop ] curry in-thread ] [ addr>> port>> ] bi ; : handle-PASV ( obj -- ) - drop client get passive >>mode drop - 221 + drop expect-connection port>bytes [ number>string ] bi@ "," glue "Entering Passive Mode (127,0,0,1," ")" surround - server-response ; + 221 server-response ; : handle-EPSV ( obj -- ) drop - client get command-promise>> [ - "You already have a passive stream" ftp-error - ] [ - 229 - expect-connection number>string - "Entering Extended Passive Mode (|||" "|)" surround - server-response - ] if ; + client get f >>extra-connection drop + expect-connection number>string + "Entering Extended Passive Mode (|||" "|)" surround + 229 server-response ; -! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 -! : handle-LPRT ( obj -- ) tokenized>> "," split ; - -ERROR: not-a-directory ; -ERROR: no-permissions ; - -: handle-CWD ( obj -- ) - [ - tokenized>> second dup normalize-path - dup ftp-server-directory head? [ - no-permissions - ] unless - - file-info directory? [ - set-current-directory - 250 "Directory successully changed." server-response +: handle-MDTM ( obj -- ) + tokenized>> 1 swap ?nth [ + dup file-info dup directory? [ + drop not-a-plain-file ] [ - not-a-directory + nip + modified>> timestamp>mdtm + 213 server-response ] if ] [ - 2drop - 550 "Failed to change directory." server-response - ] recover ; + "" not-a-plain-file + ] if* ; -: unrecognized-command ( obj -- ) raw>> ftp-error ; +ERROR: not-a-directory ; +ERROR: no-directory-permissions ; -: handle-client-loop ( -- ) - readln - USE: prettyprint global [ dup . flush ] bind - [ >>raw ] - [ tokenize-command >>tokenized ] bi +: directory-change-success ( -- ) + "Directory successully changed." 250 server-response ; + +: directory-change-failed ( -- ) + "Failed to change directory." 553 server-response ; + +: handle-CWD ( obj -- ) + tokenized>> 1 swap ?nth [ + dup can-serve-directory? [ + set-current-directory + directory-change-success + ] [ + drop + directory-change-failed + ] if + ] [ + directory-change-success + ] if* ; + +: unrecognized-command ( obj -- ) + raw>> "Unrecognized command: " prepend ftp-error ; + +: client-loop-dispatch ( str/f -- ? ) dup tokenized>> first >upper { + { "QUIT" [ handle-QUIT f ] } { "USER" [ handle-USER t ] } { "PASS" [ handle-PASS t ] } - { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } - { "CWD" [ handle-CWD t ] } - ! { "XCWD" [ ] } - ! { "CDUP" [ ] } - ! { "SMNT" [ ] } - - ! { "REIN" [ drop client get reset-ftp-client t ] } - { "QUIT" [ handle-QUIT f ] } - - ! { "PORT" [ ] } ! TODO - { "PASV" [ handle-PASV t ] } - ! { "MODE" [ ] } - { "TYPE" [ handle-TYPE t ] } - ! { "STRU" [ ] } - - ! { "ALLO" [ ] } - ! { "REST" [ ] } - { "STOR" [ handle-STOR t ] } - ! { "STOU" [ ] } - { "RETR" [ handle-RETR t ] } - { "LIST" [ handle-LIST t ] } - { "SIZE" [ handle-SIZE t ] } - ! { "NLST" [ ] } - ! { "APPE" [ ] } - ! { "RNFR" [ ] } - ! { "RNTO" [ ] } - ! { "DELE" [ handle-DELE t ] } - ! { "RMD" [ handle-RMD t ] } - ! ! { "XRMD" [ handle-XRMD t ] } - ! { "MKD" [ handle-MKD t ] } - { "PWD" [ handle-PWD t ] } - ! { "ABOR" [ ] } - { "SYST" [ handle-SYST t ] } - ! { "STAT" [ ] } - ! { "HELP" [ ] } - - ! { "SITE" [ ] } - ! { "NOOP" [ ] } - - ! { "EPRT" [ handle-EPRT ] } - ! { "LPRT" [ handle-LPRT ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] } + { "PWD" [ handle-PWD t ] } + { "TYPE" [ handle-TYPE t ] } + { "CWD" [ handle-CWD t ] } + { "PASV" [ handle-PASV t ] } { "EPSV" [ handle-EPSV t ] } - ! { "LPSV" [ drop handle-LPSV t ] } + { "LIST" [ handle-LIST t ] } + { "STOR" [ handle-STOR t ] } + { "RETR" [ handle-RETR t ] } + { "SIZE" [ handle-SIZE t ] } + { "MDTM" [ handle-MDTM t ] } [ drop unrecognized-command t ] - } case [ handle-client-loop ] when ; + } case ; -TUPLE: ftp-server < threaded-server ; +: read-command ( -- ftp-command/f ) + readln [ f ] [ ] if-empty ; + +: handle-client-loop ( -- ) + read-command [ + client-loop-dispatch + [ handle-client-loop ] when + ] when* ; + +: serve-directory ( server -- ) + serving-directory>> [ + send-banner + handle-client-loop + ] with-directory ; M: ftp-server handle-client* ( server -- ) - drop [ - ftp-server-directory [ - host-name client set - send-banner handle-client-loop - ] with-directory + "New client" \ handle-client* DEBUG log-message + ftp-client new client set + [ server set ] [ serve-directory ] bi ] with-destructors ; -: ( port -- server ) +: ( directory port -- server ) ftp-server new-threaded-server swap >>insecure + swap >>serving-directory "ftp.server" >>name 5 minutes >>timeout latin1 >>encoding ; -: ftpd ( port -- ) +: ftpd ( directory port -- ) start-server ; -: ftpd-main ( -- ) 2100 ftpd ; +: ftpd-main ( path -- ) 2100 ftpd ; MAIN: ftpd-main From 30e639ae39266a897fa28dcfcdf98cf746120889 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 15:29:06 -0600 Subject: [PATCH 18/29] add a couple unit tests to ftp --- basis/ftp/client/client.factor | 2 +- basis/ftp/ftp.factor | 4 --- basis/ftp/server/server-tests.factor | 50 ++++++++++++++++++++++++++++ basis/ftp/server/server.factor | 4 +-- 4 files changed, 52 insertions(+), 8 deletions(-) create mode 100644 basis/ftp/server/server-tests.factor diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index ac21bb8f78..14877110d3 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -93,7 +93,7 @@ ERROR: ftp-error got expected ; : ensure-login ( url -- url ) dup username>> [ "anonymous" >>username - "ftp-client" >>password + "ftp-client@factorcode.org" >>password ] unless ; : >ftp-url ( url -- url' ) >url ensure-port ensure-login ; diff --git a/basis/ftp/ftp.factor b/basis/ftp/ftp.factor index 27eebc5946..eea98c0172 100644 --- a/basis/ftp/ftp.factor +++ b/basis/ftp/ftp.factor @@ -16,7 +16,3 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; - -CONSTANT: ftp-ipv4 1 - -CONSTANT: ftp-ipv6 2 diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor new file mode 100644 index 0000000000..d7d9d8384d --- /dev/null +++ b/basis/ftp/server/server-tests.factor @@ -0,0 +1,50 @@ +USING: calendar ftp.server io.encodings.ascii io.files +io.files.unique namespaces threads tools.test kernel +io.servers.connection ftp.client accessors urls +io.pathnames io.directories sequences fry ; +IN: ftp.server.tests + +: test-file-contents ( -- string ) + "Files are so boring anymore." ; + +: create-test-file ( -- path ) + test-file-contents + "ftp.server" "test" make-unique-file + [ ascii set-file-contents ] keep canonicalize-path ; + +: test-ftp-server ( quot -- ) + '[ + current-temporary-directory get 0 + + [ start-server* ] + [ + sockets>> first addr>> port>> + + swap >>port + "ftp" >>protocol + "localhost" >>host + create-test-file >>path + _ call + ] + [ stop-server ] tri + ] with-unique-directory drop ; inline + +[ t ] +[ + + [ + unique-directory [ + [ ftp-get ] [ path>> file-name ascii file-contents ] bi + ] with-directory + ] test-ftp-server test-file-contents = +] unit-test + +[ + + [ + "/" >>path + unique-directory [ + [ ftp-get ] [ path>> file-name ascii file-contents ] bi + ] with-directory + ] test-ftp-server test-file-contents = +] must-fail diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index ffe16b2f4c..5247b824fa 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -61,11 +61,9 @@ C: ftp-disconnect normalize-path server get serving-directory>> head? ; : can-serve-directory? ( path -- ? ) - canonicalize-path { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; : can-serve-file? ( path -- ? ) - canonicalize-path { [ exists? ] [ file-info type>> +regular-file+ = ] @@ -351,7 +349,7 @@ M: ftp-server handle-client* ( server -- ) : ( directory port -- server ) ftp-server new-threaded-server swap >>insecure - swap >>serving-directory + swap canonicalize-path >>serving-directory "ftp.server" >>name 5 minutes >>timeout latin1 >>encoding ; From 1ed6c013a2adc8ce2fa2474ae0ec070e5047c017 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 15:49:18 -0600 Subject: [PATCH 19/29] call canonicalize-path when determining if we can serve a path --- basis/ftp/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 5247b824fa..2eeeac714a 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -58,7 +58,7 @@ C: ftp-disconnect send-response ; : serving? ( path -- ? ) - normalize-path server get serving-directory>> head? ; + canonicalize-path server get serving-directory>> head? ; : can-serve-directory? ( path -- ? ) { [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ; From b8445b3432c331ad693b4c953763e609ceea6ab1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 15:51:03 -0600 Subject: [PATCH 20/29] remove dead code --- basis/ftp/server/server.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 2eeeac714a..8438aae94e 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -70,14 +70,8 @@ C: ftp-disconnect [ serving? ] } 1&& ; -: can-serve? ( path -- ? ) - [ can-serve-file? ] [ can-serve-directory? ] bi or ; - : ftp-error ( string -- ) 500 server-response ; -: ftp-syntax-error ( string -- ) 501 server-response ; : ftp-unimplemented ( string -- ) 502 server-response ; -: ftp-file-not-available ( string -- ) 550 server-response ; -: ftp-illegal-file-name ( string -- ) 553 server-response ; : send-banner ( -- ) "Welcome to " host-name append 220 server-response ; From 91b4947e1eed69f07dbf34935725acced661a235 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 16:01:53 -0600 Subject: [PATCH 21/29] with-logging should not take a DEBUG level --- basis/io/servers/connection/connection.factor | 2 +- basis/io/servers/packet/packet.factor | 1 - basis/logging/insomniac/insomniac.factor | 2 +- basis/logging/logging-docs.factor | 2 +- basis/logging/logging-tests.factor | 2 +- basis/logging/logging.factor | 6 ++---- extra/spider/spider.factor | 2 +- 7 files changed, 7 insertions(+), 10 deletions(-) diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 91fb3bfb37..589a50d2eb 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -117,7 +117,7 @@ M: threaded-server handle-client* handler>> call ; : (start-server) ( threaded-server -- ) init-server dup threaded-server [ - [ ] [ name>> ] [ log-level>> ] tri [ + [ ] [ name>> ] bi [ [ listen-on [ start-accept-loop ] parallel-each ] [ ready>> raise-flag ] bi diff --git a/basis/io/servers/packet/packet.factor b/basis/io/servers/packet/packet.factor index 3f092ab9f1..4edffa96b7 100644 --- a/basis/io/servers/packet/packet.factor +++ b/basis/io/servers/packet/packet.factor @@ -20,5 +20,4 @@ LOG: received-datagram NOTICE PRIVATE> : with-datagrams ( seq service quot -- ) - [ DEBUG ] dip '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 935326da2d..91baae631f 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -30,7 +30,7 @@ SYMBOL: insomniac-recipients \ (email-log-report) NOTICE add-error-logging : email-log-report ( service word-names -- ) - "logging.insomniac" DEBUG [ (email-log-report) ] with-logging ; + "logging.insomniac" [ (email-log-report) ] with-logging ; : schedule-insomniac ( service word-names -- ) [ [ email-log-report ] assoc-each rotate-logs ] 2curry diff --git a/basis/logging/logging-docs.factor b/basis/logging/logging-docs.factor index 64956493c6..a4b3f3f019 100644 --- a/basis/logging/logging-docs.factor +++ b/basis/logging/logging-docs.factor @@ -94,7 +94,7 @@ HELP: close-logs { $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ; HELP: with-logging -{ $values { "service" "a log service name" } { "level" "a log level" } { "quot" quotation } } +{ $values { "service" "a log service name" } { "quot" quotation } } { $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ; ARTICLE: "logging.rotation" "Log rotation" diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor index 63eecc7319..796c8769fc 100644 --- a/basis/logging/logging-tests.factor +++ b/basis/logging/logging-tests.factor @@ -13,7 +13,7 @@ USING: tools.test logging math ; \ error-logging-test ERROR add-error-logging -"logging-test" DEBUG [ +"logging-test" [ [ 4 ] [ 1 3 input-logging-test ] unit-test [ 4 ] [ 1 3 output-logging-test ] unit-test diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index 496dae2c61..ff1baa4ebb 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -55,10 +55,8 @@ ERROR: bad-log-message-parameters msg word level ; : close-logs ( -- ) { } "close-logs" send-to-log-server ; -: with-logging ( service level quot -- ) - '[ - _ log-service [ _ log-level _ with-variable ] with-variable - ] call ; inline +: with-logging ( service quot -- ) + [ log-service ] dip with-variable ; inline ! Aspect-oriented programming idioms diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 0f702d7d22..bd5b2668be 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -88,7 +88,7 @@ links processing-time timestamp ; PRIVATE> : run-spider ( spider -- spider ) - "spider" DEBUG [ + "spider" [ dup spider [ queue-initial-links [ todo>> ] [ max-depth>> ] bi From ddce0e0a107ffdb295b02363c553d562641b72b9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 18 Feb 2009 16:57:20 -0600 Subject: [PATCH 22/29] change literals so that $ works with constants in same compilation unit --- extra/literals/literals-docs.factor | 8 ++++---- extra/literals/literals-tests.factor | 5 +++-- extra/literals/literals.factor | 4 ++-- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/literals/literals-docs.factor b/extra/literals/literals-docs.factor index ae25c75495..6525264f6a 100644 --- a/extra/literals/literals-docs.factor +++ b/extra/literals/literals-docs.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax multiline ; +USING: help.markup help.syntax kernel multiline ; IN: literals HELP: $ { $syntax "$ word" } { $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." } -{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." } +{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples { $example <" USING: kernel literals prettyprint ; IN: scratchpad -<< : five 5 ; >> +CONSTANT: five 5 { $ five } . "> "{ 5 }" } @@ -30,7 +30,7 @@ IN: scratchpad HELP: $[ { $syntax "$[ code ]" } { $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." } -{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." } +{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." } { $examples { $example <" diff --git a/extra/literals/literals-tests.factor b/extra/literals/literals-tests.factor index 34ea4d6415..0e933d5209 100644 --- a/extra/literals/literals-tests.factor +++ b/extra/literals/literals-tests.factor @@ -2,11 +2,12 @@ USING: kernel literals math tools.test ; IN: literals.tests << -: five 5 ; -: seven-eleven 7 11 ; : six-six-six 6 6 6 ; >> +: five 5 ; +: seven-eleven 7 11 ; + [ { 5 } ] [ { $ five } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test diff --git a/extra/literals/literals.factor b/extra/literals/literals.factor index 6df51a35ef..d3cfcaae23 100644 --- a/extra/literals/literals.factor +++ b/extra/literals/literals.factor @@ -1,6 +1,6 @@ ! (c) Joe Groff, see license for details -USING: continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations vectors ; IN: literals -: $ scan-word [ execute ] curry with-datastack >vector ; parsing +: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing : $[ \ ] parse-until >quotation with-datastack >vector ; parsing From 67d2da40404752979a9c07d75f0ba6c8aa84318b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 16:59:23 -0600 Subject: [PATCH 23/29] set a default log level --- basis/logging/logging.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index ff1baa4ebb..e295960baa 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -11,6 +11,8 @@ SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; SYMBOL: log-level +log-level [ DEBUG ] initialize + : log-levels ( -- assoc ) H{ { DEBUG 0 } From adb6b216832979de9e7af2a6a544b6e5c3b830d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 17:25:58 -0600 Subject: [PATCH 24/29] fix load error --- basis/io/servers/packet/packet.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/servers/packet/packet.factor b/basis/io/servers/packet/packet.factor index 4edffa96b7..2a346b4d13 100644 --- a/basis/io/servers/packet/packet.factor +++ b/basis/io/servers/packet/packet.factor @@ -1,6 +1,6 @@ USING: concurrency.combinators destructors fry -io.servers.datagram.private io.sockets kernel logging ; -IN: io.servers.datagram +io.sockets kernel logging ; +IN: io.servers.packet Date: Thu, 19 Feb 2009 01:33:47 +0100 Subject: [PATCH 25/29] FUEL: Don't load vocabs in USING: form by default. --- extra/fuel/fuel.factor | 2 ++ extra/fuel/help/help.factor | 6 ++++++ misc/fuel/README | 1 + misc/fuel/fuel-autodoc.el | 21 +++++++++++++++++++-- misc/fuel/fuel-eval.el | 2 +- misc/fuel/fuel-mode.el | 15 ++++++++++++++- 6 files changed, 43 insertions(+), 4 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 2bf8f1b98d..403708e880 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -99,6 +99,8 @@ PRIVATE> : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ; +: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ; + : fuel-vocab-summary ( name -- ) (fuel-vocab-summary) fuel-eval-set-result ; diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor index 55183734b3..bf637fd0b3 100644 --- a/extra/fuel/help/help.factor +++ b/extra/fuel/help/help.factor @@ -90,6 +90,12 @@ PRIVATE> : (fuel-word-help) ( name -- elem ) fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ; +: (fuel-word-synopsis) ( word usings -- str/f ) + [ + [ vocab ] filter interactive-vocabs get append interactive-vocabs set + fuel-find-word [ synopsis ] when* + ] with-scope ; + : (fuel-word-see) ( word -- elem ) [ name>> \ article swap ] [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline diff --git a/misc/fuel/README b/misc/fuel/README index d712560b03..79b8f49f9a 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -111,6 +111,7 @@ beast. | C-cC-ev | edit vocabulary (fuel-edit-vocabulary) | | C-cC-ew | edit word (fuel-edit-word-at-point) | | C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) | + | C-cC-el | load vocabs in USING: form | |-----------------+------------------------------------------------------------| | C-cC-er | eval region | | C-M-r, C-cC-ee | eval region, extending it to definition boundaries | diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 76919702bb..d02e4fcfb9 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -32,6 +32,22 @@ :type 'boolean) +(defcustom fuel-autodoc-eval-using-form-p nil + "When enabled, automatically load vocabularies in USING: form +to display autodoc messages. + +In order to show autodoc messages for words in a Factor buffer, +the used vocabularies must be loaded in the Factor image. Setting +this variable to `t' will do that automatically for you, +asynchronously. That means that you'll be able to move around +while the vocabs are being loaded, but no other FUEL +functionality will be available until loading finishes (and it +may take a while). Thus, this functionality is disabled by +default. You can force loading the vocabs in a Factor buffer +USING: form with \\[fuel-load-usings]." + :group 'fuel-autodoc + :type 'boolean) + ;;; Eldoc function: @@ -41,9 +57,10 @@ (let ((word (or word (fuel-syntax-symbol-at-point))) (fuel-log--inhibit-p t)) (when word - (let* ((cmd (if (fuel-syntax--in-using) + (let* ((usings (if fuel-autodoc-eval-using-form-p :usings t)) + (cmd (if (fuel-syntax--in-using) `(:fuel* (,word fuel-vocab-summary) :in t) - `(:fuel* (((:quote ,word) synopsis :get)) :in))) + `(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings))) (ret (fuel-eval--send/wait cmd fuel-autodoc--timeout)) (res (fuel-eval--retort-result ret))) (when (and ret (not (fuel-eval--retort-error ret)) (stringp res)) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 9e8210a3e3..985722854f 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -77,7 +77,7 @@ (t (error "Invalid 'in' (%s)" in)))) (defsubst factor--fuel-usings (usings) - (cond ((null usings) :usings) + (cond ((or (null usings) (eq usings :usings)) :usings) ((eq usings t) nil) ((listp usings) `(:array ,@usings)) (t (error "Invalid 'usings' (%s)" usings)))) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 504308fccd..c4f08f3c62 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -132,6 +132,18 @@ With prefix argument, ask for the file name." (let ((file (car (fuel-mode--read-file arg)))) (when file (fuel-debug--uses-for-file file)))) +(defun fuel-load-usings () + "Loads all vocabularies in the current buffer's USING: from. +Useful to activate autodoc help messages in a vocabulary not yet +loaded. See documentation for `fuel-autodoc-eval-using-form-p' +for details." + (interactive) + (message "Loading all vocabularies in USING: form ...") + (let ((err (fuel-eval--retort-error + (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (message (if err "Warning: some vocabularies failed to load" + "All vocabularies loaded")))) + ;;; Minor mode definition: @@ -191,7 +203,8 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point) (fuel-mode--key ?e ?e 'fuel-eval-extended-region) -(fuel-mode--key ?e ?l 'fuel-run-file) +(fuel-mode--key ?e ?k 'fuel-run-file) +(fuel-mode--key ?e ?l 'fuel-load-usings) (fuel-mode--key ?e ?r 'fuel-eval-region) (fuel-mode--key ?e ?u 'fuel-update-usings) (fuel-mode--key ?e ?v 'fuel-edit-vocabulary) From 8968093623a2bc7087527fcce6cc7c324148e3af Mon Sep 17 00:00:00 2001 From: Jason Merrill Date: Wed, 18 Feb 2009 21:28:48 -0500 Subject: [PATCH 26/29] Added dual versions of a few more words to math.dual. --- extra/math/derivatives/derivatives.factor | 23 +++++++++++-- extra/math/dual/dual-docs.factor | 42 +++++++++++++++++++++++ extra/math/dual/dual-tests.factor | 4 ++- extra/math/dual/dual.factor | 26 ++++++++++---- 4 files changed, 85 insertions(+), 10 deletions(-) diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index 8e69cec129..c6a9d1a357 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,8 +1,15 @@ ! Copyright (C) 2009 Jason W. Merrill. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.derivatives.syntax ; +USING: kernel math math.functions math.derivatives.syntax + math.order math.parser summary accessors make combinators ; IN: math.derivatives +ERROR: undefined-derivative point word ; +M: undefined-derivative summary + [ dup "Derivative of " % word>> name>> % + " is undefined at " % point>> # "." % ] + "" make ; + DERIVATIVE: + [ 2drop ] [ 2drop ] DERIVATIVE: - [ 2drop ] [ 2drop neg ] DERIVATIVE: * [ nip * ] [ drop * ] @@ -12,6 +19,15 @@ DERIVATIVE: / [ nip / ] [ sq / neg * ] DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ] [ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ] +DERIVATIVE: abs + [ 0 <=> + { + { +lt+ [ neg ] } + { +eq+ [ 0 \ abs undefined-derivative ] } + { +gt+ [ ] } + } case + ] + DERIVATIVE: sqrt [ sqrt 2 * / ] DERIVATIVE: exp [ exp * ] @@ -31,4 +47,7 @@ DERIVATIVE: atan [ sq 1 + / ] DERIVATIVE: asinh [ sq 1 + sqrt / ] DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ] -DERIVATIVE: atanh [ sq neg 1 + / ] \ No newline at end of file +DERIVATIVE: atanh [ sq neg 1 + / ] + +DERIVATIVE: neg [ drop neg ] +DERIVATIVE: recip [ sq recip neg * ] diff --git a/extra/math/dual/dual-docs.factor b/extra/math/dual/dual-docs.factor index de3b0749a5..6c287a8f1e 100644 --- a/extra/math/dual/dual-docs.factor +++ b/extra/math/dual/dual-docs.factor @@ -46,6 +46,48 @@ HELP: d^ } { $description "Raise a dual number to a (possibly dual) power" } ; +HELP: dabs +{ $values + { "x" dual } + { "|x|" dual } +} +{ $description "Absolute value of a dual number." } ; + +HELP: dacosh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic cosine of a dual number." } ; + +HELP: dasinh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic sine of a dual number." } ; + +HELP: datanh +{ $values + { "x" dual } + { "y" dual } +} +{ $description "Inverse hyberbolic tangent of a dual number." } ; + +HELP: dneg +{ $values + { "x" dual } + { "-x" dual } +} +{ $description "Negative of a dual number." } ; + +HELP: drecip +{ $values + { "x" dual } + { "1/x" dual } +} +{ $description "Reciprocal of a dual number." } ; + HELP: define-dual-method { $values { "word" word } diff --git a/extra/math/dual/dual-tests.factor b/extra/math/dual/dual-tests.factor index 2fe751dd63..ea46c46124 100644 --- a/extra/math/dual/dual-tests.factor +++ b/extra/math/dual/dual-tests.factor @@ -11,4 +11,6 @@ IN: math.dual.tests [ 2 1 ] [ 2 3 1 -1 d* unpack-dual ] unit-test [ 1/2 -1/4 ] [ 2 1 1 swap d/ unpack-dual ] unit-test [ 2 ] [ 1 1 2 d^ epsilon-part>> ] unit-test -[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test \ No newline at end of file +[ 2.0 .25 ] [ 4 1 sqrt unpack-dual ] unit-test +[ 2 -1 ] [ -2 1 dabs unpack-dual ] unit-test +[ -2 -1 ] [ 2 1 dneg unpack-dual ] unit-test \ No newline at end of file diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor index 214db9b678..36d684bc6d 100644 --- a/extra/math/dual/dual.factor +++ b/extra/math/dual/dual.factor @@ -51,9 +51,9 @@ MACRO: chain-rule ( word -- e ) PRIVATE> MACRO: dual-op ( word -- ) - [ '[ _ ordinary-op ] ] - [ input-length '[ _ nkeep ] ] - [ '[ _ chain-rule ] ] + [ '[ _ ordinary-op ] ] + [ input-length '[ _ nkeep ] ] + [ '[ _ chain-rule ] ] tri '[ _ @ @ ] ; @@ -64,17 +64,29 @@ MACRO: dual-op ( word -- ) [ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan } [ define-dual-method ] each ] with-compilation-unit -! Inverse methods { asinh, acosh, atanh } are not generic, so +! Inverse methods { asinh, acosh, atanh } are not generic, so ! there is no way to specialize them for dual numbers. However, ! they are defined in terms of functions that can operate on ! dual numbers and arithmetic methods, so if it becomes ! possible to make arithmetic operators work directly on dual ! numbers, we will get these for free. -! Arithmetic methods are not generic (yet?), so we have to +! Arithmetic words are not generic (yet?), so we have to ! define special versions of them to operate on dual numbers. : d+ ( x y -- x+y ) \ + dual-op ; -: d- ( x y -- x-y ) \ - dual-op ; +: d- ( x y -- x-y ) \ - dual-op ; : d* ( x y -- x*y ) \ * dual-op ; : d/ ( x y -- x/y ) \ / dual-op ; -: d^ ( x y -- x^y ) \ ^ dual-op ; \ No newline at end of file +: d^ ( x y -- x^y ) \ ^ dual-op ; + +: dabs ( x -- |x| ) \ abs dual-op ; + +! The following words are also not generic, but are defined in +! terms of words that can operate on dual numbers and +! arithmetic. If it becomes possible to implement arithmetic on +! dual numbers directly, these functions can be deleted. +: dneg ( x -- -x ) \ neg dual-op ; +: drecip ( x -- 1/x ) \ recip dual-op ; +: dasinh ( x -- y ) \ asinh dual-op ; +: dacosh ( x -- y ) \ acosh dual-op ; +: datanh ( x -- y ) \ atanh dual-op ; \ No newline at end of file From 318533e1870d7b3d15b892bcbb7e0c92e0dd8246 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Feb 2009 21:13:46 -0600 Subject: [PATCH 27/29] fix load error --- extra/annotations/annotations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index 1effdf4067..bf8aef3a07 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -10,7 +10,7 @@ IN: annotations PRIVATE> : $annotation ( element -- ) - P first + first [ "!" " your comment here" surround 1array $syntax ] [ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ] [ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ] From 9c44c87b054140abd20a422d22151242e854184c Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Wed, 18 Feb 2009 21:32:31 -0600 Subject: [PATCH 28/29] Merged interfaces between v1 and v2 (id3-info); added textual genre names instead of numbers --- extra/id3/id3-docs.factor | 10 +- extra/id3/id3-tests.factor | 195 +++++-------------------------------- extra/id3/id3.factor | 185 +++++++++++++++++++++++++++++++---- 3 files changed, 196 insertions(+), 194 deletions(-) diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index da69c2ced3..a54bba1629 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,13 +1,19 @@ ! Copyright (C) 2008 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences kernel ; +USING: help.markup help.syntax sequences kernel accessors ; IN: id3 HELP: file-id3-tags { $values { "path" "a path string" } { "object/f" "a tuple storing ID3 metadata or f" } } -{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; + { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: " + $nl { $link title>> } + $nl { $link artist>> } + $nl { $link album>> } + $nl { $link year>> } + $nl { $link genre>> } + $nl { $link comment>> } } ; ARTICLE: "id3" "ID3 tags" "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index fdbaf69f03..bcdc312440 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -1,182 +1,35 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test id3 ; +USING: tools.test id3 id3.private ; IN: id3.tests -[ T{ mp3v2-file - { header T{ header f t 0 502 } } - { frames - { - T{ frame - { frame-id "COMM" } - { flags B{ 0 0 } } - { size 19 } - { data "eng, AG# 08E1C12E" } - } - T{ frame - { frame-id "TIT2" } - { flags B{ 0 0 } } - { size 15 } - { data "Stormy Weather" } - } - T{ frame - { frame-id "TRCK" } - { flags B{ 0 0 } } - { size 3 } - { data "32" } - } - T{ frame - { frame-id "TCON" } - { flags B{ 0 0 } } - { size 5 } - { data "(96)" } - } - T{ frame - { frame-id "TALB" } - { flags B{ 0 0 } } - { size 28 } - { data "Night and Day Frank Sinatra" } - } - T{ frame - { frame-id "PRIV" } - { flags B{ 0 0 } } - { size 39 } - { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } - } - T{ frame - { frame-id "PRIV" } - { flags B{ 0 0 } } - { size 41 } - { data "WM/MediaClassSecondaryID" } - } - T{ frame - { frame-id "TPE1" } - { flags B{ 0 0 } } - { size 14 } - { data "Frank Sinatra" } - } - } - } -} -] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test +[ + T{ id3-info + { title "BLAH" } + { artist "ARTIST" } + { album "ALBUM" } + { year "2009" } + { comment "COMMENT" } + { genre "Bluegrass" } + } +] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test [ - T{ mp3v2-file - { header - T{ header { version t } { flags 0 } { size 1405 } } + T{ id3-info + { title "Anthem of the Trinity" } + { artist "Terry Riley" } + { album "Shri Camel" } + { genre "Classical" } } - { frames - { - T{ frame - { frame-id "TIT2" } - { flags B{ 0 0 } } - { size 22 } - { data "Anthem of the Trinity" } - } - T{ frame - { frame-id "TPE1" } - { flags B{ 0 0 } } - { size 12 } - { data "Terry Riley" } - } - T{ frame - { frame-id "TALB" } - { flags B{ 0 0 } } - { size 11 } - { data "Shri Camel" } - } - T{ frame - { frame-id "TCON" } - { flags B{ 0 0 } } - { size 10 } - { data "Classical" } - } - T{ frame - { frame-id "UFID" } - { flags B{ 0 0 } } - { size 23 } - { data "http://musicbrainz.org" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 23 } - { data "MusicBrainz Artist Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 22 } - { data "musicbrainz_artistid" } - } - T{ frame - { frame-id "TRCK" } - { flags B{ 0 0 } } - { size 2 } - { data "1" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 22 } - { data "MusicBrainz Album Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 21 } - { data "musicbrainz_albumid" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 29 } - { data "MusicBrainz Album Artist Id" } - } - T{ frame - { frame-id "TXXX" } - { flags B{ 0 0 } } - { size 27 } - { data "musicbrainz_albumartistid" } - } - T{ frame - { frame-id "TPOS" } - { flags B{ 0 0 } } - { size 2 } - { data "1" } - } - T{ frame - { frame-id "TSOP" } - { flags B{ 0 0 } } - { size 1 } - } - T{ frame - { frame-id "TMED" } - { flags B{ 0 0 } } - { size 4 } - { data "DIG" } - } - } - } -} ] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test [ - T{ mp3v1-file - { title - "BLAH" - } - { artist - "ARTIST" - } - { album - "ALBUM" - } - { year "2009" } - { comment - "COMMENT" - } - { genre 89 } - } -] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test + T{ id3-info + { title "Stormy Weather" } + { artist "Frank Sinatra" } + { album "Night and Day Frank Sinatra" } + { comment "eng, AG# 08E1C12E" } + { genre "Big Band" } + } +] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 5b0d3f373e..f2bbd08996 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -1,28 +1,159 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ; IN: id3 + ( -- object ) mp3v1-file new ; +: ( -- object ) id3-info new ; -: ( header frames -- object ) mp3v2-file boa ; +: ( header frames -- object ) id3v2-info boa ; :
( -- object ) header new ; : ( -- object ) frame new ; - ] dip { - [ read-frame-id ascii decode >>frame-id ] + [ read-frame-id utf8 decode >>frame-id ] [ read-frame-flags >byte-array >>flags ] [ read-frame-size >28bitword >>size ] - [ read-frame-data ascii decode >>data ] + [ read-frame-data utf8 decode >>data ] } cleave ; : read-frame ( mmap -- frame/f ) @@ -98,9 +229,21 @@ TUPLE: mp3v1-file title artist album year comment genre ; : drop-header ( mmap -- seq1 seq2 ) dup 10 tail-slice swap ; -: read-v2-tag-data ( seq -- mp3v2-file ) - drop-header read-v2-header swap read-frames ; +: parse-frames ( id3v2-info -- id3-info ) + [ ] dip frames>> + { + [ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ] + [ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ] + [ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ] + [ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when* + >>genre ] when* ] + [ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ] + [ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ] + } cleave ; +: read-v2-tag-data ( seq -- id3-info ) + drop-header read-v2-header swap read-frames parse-frames ; + ! v1 information : skip-to-v1-data ( seq -- seq ) @@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ; [ 124 ] dip nth ; : (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip + [ ] dip { - [ read-title ascii decode filter-text-data >>title ] - [ read-artist ascii decode filter-text-data >>artist ] - [ read-album ascii decode filter-text-data >>album ] - [ read-year ascii decode filter-text-data >>year ] - [ read-comment ascii decode filter-text-data >>comment ] - [ read-genre >fixnum >>genre ] + [ read-title utf8 decode filter-text-data >>title ] + [ read-artist utf8 decode filter-text-data >>artist ] + [ read-album utf8 decode filter-text-data >>album ] + [ read-year utf8 decode filter-text-data >>year ] + [ read-comment utf8 decode filter-text-data >>comment ] + [ read-genre >fixnum genres at >>genre ] } cleave ; : read-v1-tag-data ( seq -- mp3-file ) @@ -140,13 +283,13 @@ TUPLE: mp3v1-file title artist album year comment genre ; PRIVATE> -! main stuff +! public interface : file-id3-tags ( path -- object/f ) [ { - { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) - { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info ) [ drop f ] ! ( mmap -- f ) } cond ] with-mapped-uchar-file ; From bdb790010a029adfcf2b3a5a5360067e6ef1af0d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Feb 2009 04:08:32 -0600 Subject: [PATCH 29/29] Add bytes-per-pixel word to images vocab --- basis/images/images.factor | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index c2dc33608e..5ac0da7a28 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -9,6 +9,24 @@ IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; +: bytes-per-pixel ( component-order -- n ) + { + { BGR [ 3 ] } + { RGB [ 3 ] } + { BGRA [ 4 ] } + { RGBA [ 4 ] } + { ABGR [ 4 ] } + { ARGB [ 4 ] } + { RGBX [ 4 ] } + { XRGB [ 4 ] } + { BGRX [ 4 ] } + { XBGR [ 4 ] } + { R16G16B16 [ 6 ] } + { R32G32B32 [ 12 ] } + { R16G16B16A16 [ 8 ] } + { R32G32B32A32 [ 16 ] } + } case ; + TUPLE: image dim component-order bitmap ; : ( -- image ) image new ; inline @@ -63,4 +81,4 @@ M: image normalize-scan-line-order ; : normalize-image ( image -- image ) [ >byte-array ] change-bitmap normalize-component-order - normalize-scan-line-order ; + normalize-scan-line-order ; \ No newline at end of file