Merge branch 'master' into new_ui
Slava Pestov
commit
25340e881b
|
|
@ -181,6 +181,7 @@ ARTICLE: "io" "Input and output"
|
|||
{ $subsection "io.streams.plain" }
|
||||
{ $subsection "io.streams.string" }
|
||||
{ $subsection "io.streams.byte-array" }
|
||||
{ $subsection "io.streams.limited" }
|
||||
{ $heading "Utilities" }
|
||||
{ $subsection "stream-binary" }
|
||||
{ $subsection "io.styles" }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,79 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel math io ;
|
||||
IN: io.streams.limited
|
||||
|
||||
HELP: <limited-stream>
|
||||
{ $values
|
||||
{ "stream" "an input stream" } { "limit" integer }
|
||||
{ "stream'" "an input stream" }
|
||||
}
|
||||
{ $description "Constructs a new " { $link limited-stream } " from an existing stream. Upon exhaustion, the stream will throw an error by default." }
|
||||
{ $examples "Throwing an exception:"
|
||||
{ $example
|
||||
"USING: continuations io io.streams.limited io.streams.string"
|
||||
"kernel prettyprint ;"
|
||||
"["
|
||||
" \"123456\" <string-reader> 3 <limited-stream>"
|
||||
" 100 swap stream-read ."
|
||||
"] [ ] recover ."
|
||||
"T{ limit-exceeded }"
|
||||
}
|
||||
"Returning " { $link f } " on exhaustion:"
|
||||
{ $example
|
||||
"USING: accessors continuations io io.streams.limited"
|
||||
"io.streams.string kernel prettyprint ;"
|
||||
"\"123456\" <string-reader> 3 <limited-stream>"
|
||||
"stream-eofs >>mode"
|
||||
"100 swap stream-read ."
|
||||
"\"123\""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: limit
|
||||
{ $values
|
||||
{ "stream" "a stream" } { "limit" integer }
|
||||
{ "stream'" "a stream" }
|
||||
}
|
||||
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." } ;
|
||||
|
||||
HELP: limited-stream
|
||||
{ $values
|
||||
{ "value" "a limited-stream class" }
|
||||
}
|
||||
{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion. The default behavior is to throw an exception." } ;
|
||||
|
||||
HELP: limit-input
|
||||
{ $values
|
||||
{ "limit" integer }
|
||||
}
|
||||
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
|
||||
|
||||
HELP: stream-eofs
|
||||
{ $values
|
||||
{ "value" "a " { $link limited-stream } " mode singleton" }
|
||||
}
|
||||
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
|
||||
|
||||
HELP: stream-throws
|
||||
{ $values
|
||||
{ "value" "a " { $link limited-stream } " mode singleton" }
|
||||
}
|
||||
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
|
||||
|
||||
{ stream-eofs stream-throws } related-words
|
||||
|
||||
ARTICLE: "io.streams.limited" "Limited input streams"
|
||||
"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. The default behavior is to throw an error." $nl
|
||||
"Wrap an existing stream in a limited stream:"
|
||||
{ $subsection <limited-stream> }
|
||||
"Wrap a stream in a limited stream:"
|
||||
{ $subsection limit }
|
||||
"Wrap the current " { $link input-stream } " in a limited stream:"
|
||||
{ $subsection limit-input }
|
||||
"Make a limited stream throw an exception on exhaustion:"
|
||||
{ $subsection stream-throws }
|
||||
"Make a limited stream return " { $link f } " on exhaustion:"
|
||||
{ $subsection stream-eofs } ;
|
||||
|
||||
ABOUT: "io.streams.limited"
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
IN: io.streams.limited.tests
|
||||
USING: io io.streams.limited io.encodings io.encodings.string
|
||||
io.encodings.ascii io.encodings.binary io.streams.byte-array
|
||||
namespaces tools.test strings kernel ;
|
||||
namespaces tools.test strings kernel io.streams.string accessors ;
|
||||
IN: io.streams.limited.tests
|
||||
|
||||
[ ] [
|
||||
"hello world\nhow are you today\nthis is a very long line indeed"
|
||||
|
|
@ -38,3 +38,18 @@ namespaces tools.test strings kernel ;
|
|||
"l" read-until
|
||||
] with-input-stream
|
||||
] unit-test
|
||||
|
||||
[ CHAR: a ]
|
||||
[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
|
||||
|
||||
[ "abc" ]
|
||||
[
|
||||
"abc" <string-reader> 3 <limited-stream> stream-eofs >>mode
|
||||
4 swap stream-read
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"abc" <string-reader> 3 <limited-stream> stream-eofs >>mode
|
||||
4 over stream-read drop 10 swap stream-read
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,16 +1,20 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math io io.encodings destructors accessors
|
||||
sequences namespaces byte-vectors ;
|
||||
sequences namespaces byte-vectors fry combinators ;
|
||||
IN: io.streams.limited
|
||||
|
||||
TUPLE: limited-stream stream count limit ;
|
||||
TUPLE: limited-stream stream count limit mode ;
|
||||
|
||||
SINGLETONS: stream-throws stream-eofs ;
|
||||
|
||||
: <limited-stream> ( stream limit -- stream' )
|
||||
limited-stream new
|
||||
swap >>limit
|
||||
swap >>stream
|
||||
0 >>count ;
|
||||
0 >>count
|
||||
stream-throws >>mode ;
|
||||
|
||||
GENERIC# limit 1 ( stream limit -- stream' )
|
||||
|
||||
|
|
@ -22,24 +26,48 @@ M: object limit <limited-stream> ;
|
|||
|
||||
ERROR: limit-exceeded ;
|
||||
|
||||
: check-limit ( n stream -- )
|
||||
[ + ] change-count
|
||||
[ count>> ] [ limit>> ] bi >=
|
||||
[ limit-exceeded ] when ; inline
|
||||
ERROR: bad-stream-mode mode ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: adjust-limit ( n stream -- n' stream )
|
||||
2dup [ + ] change-count
|
||||
[ count>> ] [ limit>> ] bi >
|
||||
[
|
||||
dup mode>> {
|
||||
{ stream-throws [ limit-exceeded ] }
|
||||
{ stream-eofs [
|
||||
dup [ count>> ] [ limit>> ] bi -
|
||||
'[ _ - ] dip
|
||||
] }
|
||||
[ bad-stream-mode ]
|
||||
} case
|
||||
] when ; inline
|
||||
|
||||
: maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
|
||||
[ adjust-limit ] dip
|
||||
pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: limited-stream stream-read1
|
||||
1 over check-limit stream>> stream-read1 ;
|
||||
1 swap
|
||||
[ nip stream-read1 ] maybe-read ;
|
||||
|
||||
M: limited-stream stream-read
|
||||
2dup check-limit stream>> stream-read ;
|
||||
[ stream-read ] maybe-read ;
|
||||
|
||||
M: limited-stream stream-read-partial
|
||||
2dup check-limit stream>> stream-read-partial ;
|
||||
[ stream-read-partial ] maybe-read ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (read-until) ( stream seps buf -- stream seps buf sep/f )
|
||||
3dup [ [ stream-read1 dup ] dip memq? ] dip
|
||||
swap [ drop ] [ push (read-until) ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: limited-stream stream-read-until
|
||||
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,105 +1,150 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io kernel locals math multiline
|
||||
sequences splitting prettyprint namespaces http.parsers
|
||||
ascii assocs unicode.case io.files.unique io.files io.encodings.binary
|
||||
byte-arrays io.encodings make fry ;
|
||||
USING: multiline kernel sequences io splitting fry namespaces
|
||||
http.parsers hashtables assocs combinators ascii io.files.unique
|
||||
accessors io.encodings.binary io.files byte-arrays math
|
||||
io.streams.string combinators.short-circuit strings ;
|
||||
IN: mime.multipart
|
||||
|
||||
TUPLE: multipart-stream stream n leftover separator ;
|
||||
CONSTANT: buffer-size 65536
|
||||
CONSTANT: separator-prefix "\r\n--"
|
||||
|
||||
: <multipart-stream> ( stream separator -- multipart-stream )
|
||||
multipart-stream new
|
||||
swap >>separator
|
||||
swap >>stream
|
||||
16 2^ >>n ;
|
||||
TUPLE: multipart
|
||||
end-of-stream?
|
||||
current-separator mime-separator
|
||||
header
|
||||
content-disposition bytes
|
||||
filename temp-file
|
||||
name name-content
|
||||
uploaded-files
|
||||
form-variables ;
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: mime-file headers filename temporary-path ;
|
||||
TUPLE: mime-variable headers key value ;
|
||||
|
||||
: ?append ( seq1 seq2 -- newseq/seq2 )
|
||||
over [ append ] [ nip ] if ;
|
||||
: <multipart> ( mime-separator -- multipart )
|
||||
multipart new
|
||||
swap >>mime-separator
|
||||
H{ } clone >>uploaded-files
|
||||
H{ } clone >>form-variables ;
|
||||
|
||||
: ?cut* ( seq n -- before after )
|
||||
over length over <= [ drop f swap ] [ cut* ] if ;
|
||||
ERROR: bad-header bytes ;
|
||||
|
||||
: read-n ( stream -- bytes end-stream? )
|
||||
[ f ] change-leftover
|
||||
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
|
||||
: mime-write ( sequence -- )
|
||||
>byte-array write ;
|
||||
|
||||
: multipart-split ( bytes separator -- before after seq=? )
|
||||
2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
|
||||
: parse-headers ( string -- sequence )
|
||||
string-lines harvest [ parse-header-line ] map ;
|
||||
|
||||
:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
|
||||
bytes [ quot unless-empty ]
|
||||
[ stream (>>leftover) quot unless-empty ] if-empty f ; inline
|
||||
ERROR: end-of-stream multipart ;
|
||||
|
||||
:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
|
||||
bytes end-stream? [
|
||||
quot unless-empty f
|
||||
: fill-bytes ( multipart -- multipart )
|
||||
buffer-size read
|
||||
[ '[ _ append ] change-bytes ]
|
||||
[ t >>end-of-stream? ] if* ;
|
||||
|
||||
: maybe-fill-bytes ( multipart -- multipart )
|
||||
dup bytes>> [ fill-bytes ] unless ;
|
||||
|
||||
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
|
||||
2dup [ length ] [ length 1- ] bi* < [
|
||||
drop f
|
||||
] [
|
||||
separator length 1- ?cut* stream (>>leftover)
|
||||
quot unless-empty t
|
||||
] if ; inline
|
||||
|
||||
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
|
||||
#! return t to loop again
|
||||
bytes separator multipart-split
|
||||
[ 2drop f ]
|
||||
[
|
||||
[ stream quot multipart-step-found ]
|
||||
[ stream end-stream? separator quot multipart-step-not-found ] if*
|
||||
] if stream leftover>> end-stream? not or >boolean ;
|
||||
|
||||
|
||||
:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
|
||||
stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
|
||||
swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
|
||||
|
||||
SYMBOL: header
|
||||
SYMBOL: parsed-header
|
||||
SYMBOL: magic-separator
|
||||
|
||||
: trim-blanks ( str -- str' ) [ blank? ] trim ;
|
||||
|
||||
: trim-quotes ( str -- str' )
|
||||
[ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
|
||||
|
||||
: parse-content-disposition ( str -- content-disposition hash )
|
||||
";" split [ first ] [ rest-slice ] bi [ "=" split ] map
|
||||
[ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
|
||||
|
||||
: parse-multipart-header ( string -- headers )
|
||||
"\r\n" split harvest
|
||||
[ parse-header-line first2 ] H{ } map>assoc ;
|
||||
|
||||
ERROR: expected-file ;
|
||||
|
||||
TUPLE: uploaded-file path filename name ;
|
||||
|
||||
: (parse-multipart) ( stream -- ? )
|
||||
"\r\n\r\n" >>separator
|
||||
header off
|
||||
dup [ header [ prepend ] change ] multipart-step-loop drop
|
||||
header get dup magic-separator get [ length ] bi@ < [
|
||||
2drop f
|
||||
] [
|
||||
parse-multipart-header
|
||||
parsed-header set
|
||||
"\r\n" magic-separator get append >>separator
|
||||
"factor-upload" "httpd" make-unique-file tuck
|
||||
binary [ [ write ] multipart-step-loop ] with-file-writer swap
|
||||
"content-disposition" parsed-header get at parse-content-disposition
|
||||
nip [ "filename" swap at ] [ "name" swap at ] bi
|
||||
uploaded-file boa ,
|
||||
length 1- cut-slice swap
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
: dump-until-separator ( multipart -- multipart )
|
||||
dup [ current-separator>> ] [ bytes>> ] bi tuck start [
|
||||
cut-slice
|
||||
[ mime-write ]
|
||||
[ over current-separator>> length tail-slice >>bytes ] bi*
|
||||
] [
|
||||
drop
|
||||
dup [ bytes>> ] [ current-separator>> ] bi split-bytes
|
||||
[ mime-write ] when*
|
||||
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
|
||||
] if* ;
|
||||
|
||||
: parse-multipart ( stream -- array )
|
||||
[
|
||||
"\r\n" <multipart-stream>
|
||||
magic-separator off
|
||||
dup [ magic-separator [ prepend ] change ]
|
||||
multipart-step-loop drop
|
||||
'[ [ _ (parse-multipart) ] loop ] { } make
|
||||
] with-scope ;
|
||||
: dump-string ( multipart separator -- multipart string )
|
||||
>>current-separator
|
||||
[ dump-until-separator ] with-string-writer ;
|
||||
|
||||
: read-header ( multipart -- multipart )
|
||||
"\r\n\r\n" dump-string dup "--\r" = [
|
||||
drop
|
||||
] [
|
||||
parse-headers >hashtable >>header
|
||||
] if ;
|
||||
|
||||
: save-uploaded-file ( multipart -- )
|
||||
dup filename>> empty? [
|
||||
drop
|
||||
] [
|
||||
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
|
||||
[ filename>> ]
|
||||
[ uploaded-files>> set-at ] tri
|
||||
] if ;
|
||||
|
||||
: save-form-variable ( multipart -- )
|
||||
[ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
|
||||
[ name>> ]
|
||||
[ form-variables>> set-at ] tri ;
|
||||
|
||||
: dump-mime-file ( multipart filename -- multipart )
|
||||
binary <file-writer> [
|
||||
dup mime-separator>> >>current-separator dump-until-separator
|
||||
] with-output-stream ;
|
||||
|
||||
: dump-file ( multipart -- multipart )
|
||||
"factor-" "-upload" make-unique-file
|
||||
[ >>temp-file ] [ dump-mime-file ] bi ;
|
||||
|
||||
: parse-content-disposition-form-data ( string -- hashtable )
|
||||
";" split
|
||||
[ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
|
||||
|
||||
: lookup-disposition ( multipart string -- multipart value/f )
|
||||
over content-disposition>> at ;
|
||||
|
||||
ERROR: unknown-content-disposition multipart ;
|
||||
|
||||
: parse-form-data ( multipart -- multipart )
|
||||
"filename" lookup-disposition [
|
||||
>>filename
|
||||
[ dump-file ] [ save-uploaded-file ] bi
|
||||
] [
|
||||
"name" lookup-disposition [
|
||||
[ dup mime-separator>> dump-string >>name-content ] dip
|
||||
>>name dup save-form-variable
|
||||
] [
|
||||
unknown-content-disposition
|
||||
] if*
|
||||
] if* ;
|
||||
|
||||
ERROR: no-content-disposition multipart ;
|
||||
|
||||
: process-header ( multipart -- multipart )
|
||||
"content-disposition" over header>> at ";" split1 swap {
|
||||
{ "form-data" [
|
||||
parse-content-disposition-form-data >>content-disposition
|
||||
parse-form-data
|
||||
] }
|
||||
[ no-content-disposition ]
|
||||
} case ;
|
||||
|
||||
: read-assert= ( string -- )
|
||||
[ length read ] keep assert= ;
|
||||
|
||||
: parse-beginning ( multipart -- multipart )
|
||||
"--" read-assert=
|
||||
dup mime-separator>>
|
||||
[ read-assert= ]
|
||||
[ separator-prefix prepend >>mime-separator ] bi ;
|
||||
|
||||
: parse-multipart-loop ( multipart -- multipart )
|
||||
read-header
|
||||
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
|
||||
|
||||
: parse-multipart ( sep -- uploaded-files form-variables )
|
||||
<multipart> parse-beginning parse-multipart-loop
|
||||
[ uploaded-files>> ] [ form-variables>> ] bi ;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@ regexp.transition-tables words sets regexp.classes unicode.case.private ;
|
|||
! before processing starts
|
||||
IN: regexp.nfa
|
||||
|
||||
ERROR: feature-is-broken feature ;
|
||||
|
||||
SYMBOL: negation-mode
|
||||
: negated? ( -- ? ) negation-mode get 0 or odd? ;
|
||||
|
||||
|
|
@ -181,6 +183,7 @@ M: character-class-range nfa-node ( node -- )
|
|||
] if ;
|
||||
|
||||
M: capture-group nfa-node ( node -- )
|
||||
"capture-groups" feature-is-broken
|
||||
eps literal-transition add-simple-entry
|
||||
capture-group-on add-traversal-flag
|
||||
term>> nfa-node
|
||||
|
|
@ -201,6 +204,7 @@ M: negation nfa-node ( node -- )
|
|||
negation-mode dec ;
|
||||
|
||||
M: lookahead nfa-node ( node -- )
|
||||
"lookahead" feature-is-broken
|
||||
eps literal-transition add-simple-entry
|
||||
lookahead-on add-traversal-flag
|
||||
term>> nfa-node
|
||||
|
|
@ -209,6 +213,7 @@ M: lookahead nfa-node ( node -- )
|
|||
2 [ concatenate-nodes ] times ;
|
||||
|
||||
M: lookbehind nfa-node ( node -- )
|
||||
"lookbehind" feature-is-broken
|
||||
eps literal-transition add-simple-entry
|
||||
lookbehind-on add-traversal-flag
|
||||
term>> nfa-node
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: regexp tools.test kernel sequences regexp.parser
|
||||
regexp.traversal eval strings ;
|
||||
regexp.traversal eval strings multiline ;
|
||||
IN: regexp-tests
|
||||
|
||||
\ <regexp> must-infer
|
||||
|
|
@ -76,6 +76,8 @@ IN: regexp-tests
|
|||
[ t ] [ "bar" "foo|bar" <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "foo|bar" <regexp> matches? ] unit-test
|
||||
|
||||
/*
|
||||
! FIXME
|
||||
[ f ] [ "" "(a)" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "(a)" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aa" "(a)" <regexp> matches? ] unit-test
|
||||
|
|
@ -83,6 +85,7 @@ IN: regexp-tests
|
|||
|
||||
[ f ] [ "aababaaabbac" "(a|b)+" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ababaaabba" "(a|b)+" <regexp> matches? ] unit-test
|
||||
*/
|
||||
|
||||
[ f ] [ "" "a{1}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "a{1}" <regexp> matches? ] unit-test
|
||||
|
|
@ -165,9 +168,12 @@ IN: regexp-tests
|
|||
[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
|
||||
|
||||
/*
|
||||
! FIXME
|
||||
[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" <regexp> matches? ] unit-test
|
||||
*/
|
||||
|
||||
[ t ] [ "1000" "\\d{4,6}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "1000" "[0-9]{4,6}" <regexp> matches? ] unit-test
|
||||
|
|
@ -238,7 +244,7 @@ IN: regexp-tests
|
|||
|
||||
[ t ] [ "abc" <reversed> R/ abc/r matches? ] unit-test
|
||||
[ t ] [ "abc" <reversed> R/ a[bB][cC]/r matches? ] unit-test
|
||||
[ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test
|
||||
! [ t ] [ "adcbe" R/ a(?r)(bcd)(?-r)e/ matches? ] unit-test ! FIXME
|
||||
|
||||
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
|
|
@ -247,6 +253,8 @@ IN: regexp-tests
|
|||
[ t ] [ "abc*" "[^\\*]*\\*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "bca" "[^a]*a" <regexp> matches? ] unit-test
|
||||
|
||||
/*
|
||||
! FIXME
|
||||
[ ] [
|
||||
"(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
|
||||
<regexp> drop
|
||||
|
|
@ -270,6 +278,7 @@ IN: regexp-tests
|
|||
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
|
||||
|
||||
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
|
||||
*/
|
||||
|
||||
! [ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
|
||||
|
||||
|
|
@ -293,6 +302,8 @@ IN: regexp-tests
|
|||
[ "1.2.3.4" ]
|
||||
[ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test
|
||||
|
||||
/*
|
||||
! FIXME
|
||||
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
|
||||
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
|
||||
! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
|
|
@ -303,6 +314,7 @@ IN: regexp-tests
|
|||
|
||||
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
*/
|
||||
|
||||
! Bug in parsing word
|
||||
[ t ] [ "a" R' a' matches? ] unit-test
|
||||
|
|
|
|||
|
|
@ -8,8 +8,6 @@ QUALIFIED: ascii
|
|||
IN: unicode.case
|
||||
|
||||
<PRIVATE
|
||||
: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
|
||||
|
||||
: ch>lower ( ch -- lower ) simple-lower at-default ; inline
|
||||
: ch>upper ( ch -- upper ) simple-upper at-default ; inline
|
||||
: ch>title ( ch -- title ) simple-title at-default ; inline
|
||||
|
|
|
|||
|
|
@ -118,3 +118,15 @@ unit-test
|
|||
{ "nachos" "cheese" }
|
||||
} extract-keys
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"a" H{ { "a" f } } at-default
|
||||
] unit-test
|
||||
|
||||
[ "b" ] [
|
||||
"b" H{ { "a" f } } at-default
|
||||
] unit-test
|
||||
|
||||
[ "x" ] [
|
||||
"a" H{ { "a" "x" } } at-default
|
||||
] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
|
||||
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays math sequences.private vectors
|
||||
accessors ;
|
||||
|
|
@ -41,8 +41,7 @@ GENERIC: >alist ( assoc -- newassoc )
|
|||
over assoc-map-as ; inline
|
||||
|
||||
: assoc-push-if ( key value quot accum -- )
|
||||
[ 2keep rot ] dip swap
|
||||
[ [ 2array ] dip push ] [ 3drop ] if ; inline
|
||||
[ 2keep ] dip [ [ 2array ] dip push ] 3curry when ; inline
|
||||
|
||||
: assoc-pusher ( quot -- quot' accum )
|
||||
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
|
||||
|
|
@ -62,9 +61,12 @@ GENERIC: >alist ( assoc -- newassoc )
|
|||
: at ( key assoc -- value/f )
|
||||
at* drop ; inline
|
||||
|
||||
: at-default ( key assoc -- value/key )
|
||||
2dup at* [ 2nip ] [ 2drop ] if ; inline
|
||||
|
||||
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||
over assoc-size swap new-assoc
|
||||
swap [ swap pick set-at ] assoc-each ;
|
||||
[ [ swapd set-at ] curry assoc-each ] keep ;
|
||||
|
||||
: keys ( assoc -- keys )
|
||||
[ drop ] { } assoc>map ;
|
||||
|
|
@ -76,7 +78,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
[ at* ] 2keep delete-at ;
|
||||
|
||||
: rename-at ( newkey key assoc -- )
|
||||
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
|
||||
[ delete-at* ] keep [ swapd set-at ] curry [ 2drop ] if ;
|
||||
|
||||
: assoc-empty? ( assoc -- ? )
|
||||
assoc-size zero? ;
|
||||
|
|
@ -132,14 +134,16 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
substituter map ;
|
||||
|
||||
: cache ( key assoc quot -- value )
|
||||
2over at* [
|
||||
[ 3drop ] dip
|
||||
] [
|
||||
drop pick rot [ call dup ] 2dip set-at
|
||||
] if ; inline
|
||||
[ [ at* ] 2keep ] dip
|
||||
[ [ nip call dup ] [ drop ] 3bi set-at ] 3curry
|
||||
[ drop ] prepose
|
||||
unless ; inline
|
||||
|
||||
: 2cache ( key1 key2 assoc quot -- value )
|
||||
[ 2array ] 2dip [ first2 ] prepose cache ; inline
|
||||
|
||||
: change-at ( key assoc quot -- )
|
||||
[ [ at ] dip call ] 3keep drop set-at ; inline
|
||||
[ [ at ] dip call ] [ drop ] 3bi set-at ; inline
|
||||
|
||||
: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -17,9 +17,6 @@ TUPLE: anonymous-complement class ;
|
|||
|
||||
C: <anonymous-complement> anonymous-complement
|
||||
|
||||
: 2cache ( key1 key2 assoc quot -- value )
|
||||
[ 2array ] 2dip [ first2 ] prepose cache ; inline
|
||||
|
||||
GENERIC: valid-class? ( obj -- ? )
|
||||
|
||||
M: class valid-class? drop t ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math make strings arrays vectors sequences
|
||||
sets math.order accessors ;
|
||||
|
|
@ -16,19 +16,23 @@ IN: splitting
|
|||
: ?tail-slice ( seq end -- newseq ? )
|
||||
2dup tail? [ length head-slice* t ] [ drop f ] if ;
|
||||
|
||||
: (split1) ( seq subseq -- start end ? )
|
||||
tuck swap start dup
|
||||
[ swap [ drop ] [ length + ] 2bi t ]
|
||||
[ 2drop f f f ]
|
||||
if ;
|
||||
|
||||
: split1 ( seq subseq -- before after )
|
||||
dup pick start dup [
|
||||
[ [ over ] dip head -rot length ] keep + tail
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
[ drop ] [ (split1) ] 2bi
|
||||
[ [ over ] dip [ head ] [ tail ] 2bi* ]
|
||||
[ 2drop f ]
|
||||
if ;
|
||||
|
||||
: split1-slice ( seq subseq -- before-slice after-slice )
|
||||
dup pick start dup [
|
||||
[ [ over ] dip head-slice -rot length ] keep + tail-slice
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
[ drop ] [ (split1) ] 2bi
|
||||
[ [ over ] dip [ head-slice ] [ tail-slice ] 2bi* ]
|
||||
[ 2drop f ]
|
||||
if ;
|
||||
|
||||
: split1-last ( seq subseq -- before after )
|
||||
[ <reversed> ] bi@ split1 [ reverse ] bi@
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ;
|
|||
] unit-test
|
||||
|
||||
[ B{ 133 6 97 98 99 100 101 102 } ] [
|
||||
5 "abcdef" >ber-contextspecific
|
||||
5 "abcdef" >ber-contextspecific-string
|
||||
] unit-test
|
||||
|
||||
! triggers array
|
||||
|
|
@ -45,7 +45,7 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ;
|
|||
] unit-test
|
||||
|
||||
[ B{ 160 4 49 50 51 52 } ] [
|
||||
{ 1 2 3 4 } >ber-contextspecific
|
||||
{ 1 2 3 4 } >ber-contextspecific-array
|
||||
] unit-test
|
||||
|
||||
] with-ber
|
||||
|
|
|
|||
|
|
@ -7,6 +7,24 @@ math.parser namespaces make pack strings sequences accessors ;
|
|||
|
||||
IN: asn1
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (>128-ber) ( n -- )
|
||||
dup 0 > [
|
||||
[ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift
|
||||
(>128-ber)
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >128-ber ( n -- str )
|
||||
[
|
||||
[ HEX: 7f bitand , ] keep -7 shift
|
||||
(>128-ber)
|
||||
] { } make reverse ;
|
||||
|
||||
: tag-classes ( -- seq )
|
||||
{ "universal" "application" "context_specific" "private" } ;
|
||||
|
||||
|
|
@ -191,8 +209,7 @@ M: string >ber ( str -- byte-array )
|
|||
: >ber-application-string ( n str -- byte-array )
|
||||
[ HEX: 40 + set-tag ] dip >ber ;
|
||||
|
||||
GENERIC: >ber-contextspecific ( n obj -- byte-array )
|
||||
M: string >ber-contextspecific ( n str -- byte-array )
|
||||
: >ber-contextspecific-string ( n str -- byte-array )
|
||||
[ HEX: 80 + set-tag ] dip >ber ;
|
||||
|
||||
! =========================================================
|
||||
|
|
@ -215,5 +232,5 @@ M: array >ber ( array -- byte-array )
|
|||
: >ber-appsequence ( array -- byte-array )
|
||||
HEX: 60 >ber-seq-internal ;
|
||||
|
||||
M: array >ber-contextspecific ( array -- byte-array )
|
||||
: >ber-contextspecific-array ( array -- byte-array )
|
||||
HEX: A0 >ber-seq-internal ;
|
||||
|
|
|
|||
|
|
@ -16,6 +16,9 @@ SYMBOLS: base-dir filename ;
|
|||
|
||||
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
|
||||
|
||||
: read-c-string* ( n -- str/f )
|
||||
read [ zero? ] trim-right [ f ] when-empty ;
|
||||
|
||||
: read-tar-header ( -- obj )
|
||||
\ tar-header new
|
||||
100 read-c-string* >>name
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel furnace.actions html.forms
|
||||
http.server.dispatchers db db.tuples db.types urls
|
||||
furnace.redirection multiline http namespaces ;
|
||||
IN: webapps.imagebin
|
||||
|
||||
TUPLE: imagebin < dispatcher ;
|
||||
|
||||
TUPLE: image id path ;
|
||||
|
||||
image "IMAGE" {
|
||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||
{ "path" "PATH" { VARCHAR 256 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: <uploaded-image-action> ( -- action )
|
||||
<page-action>
|
||||
{ imagebin "uploaded-image" } >>template ;
|
||||
|
||||
SYMBOL: my-post-data
|
||||
: <upload-image-action> ( -- action )
|
||||
<page-action>
|
||||
{ imagebin "upload-image" } >>template
|
||||
[
|
||||
request get post-data>> my-post-data set-global
|
||||
! image new
|
||||
! "file" value
|
||||
! insert-tuple
|
||||
! "uploaded-image" <redirect>
|
||||
] >>submit ;
|
||||
|
||||
: <imagebin> ( -- responder )
|
||||
imagebin new-dispatcher
|
||||
<upload-image-action> "" add-responder
|
||||
<upload-image-action> "upload-image" add-responder
|
||||
<uploaded-image-action> "uploaded-image" add-responder ;
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
<?xml version='1.0' ?>
|
||||
<html>
|
||||
<head><title>Upload</title></head>
|
||||
<body>
|
||||
<form action="upload-image" method="post" enctype="multipart/form-data" name="upload">
|
||||
|
||||
<table>
|
||||
<tr><th class="field-label">Image: </th><td><input type="file" name="file1" /></td></tr>
|
||||
<tr><th class="field-label">Image: </th><td><input type="file" name="file2" /></td></tr>
|
||||
<tr><th class="field-label">Image: </th><td><input type="file" name="file3" /></td></tr>
|
||||
<tr><th class="field-label">Text: </th><td><input type="text" name="text1" /></td></tr>
|
||||
</table>
|
||||
|
||||
<p> <button type="submit">Submit</button> </p>
|
||||
</form>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
<?xml version='1.0' ?>
|
||||
<html>
|
||||
<head><title>Uploaded</title></head>
|
||||
<body>
|
||||
hi from uploaded-image
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -53,8 +53,10 @@ INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
|
|||
void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
|
||||
{
|
||||
default_parameters(p);
|
||||
const F_CHAR *executable_path = vm_executable_path();
|
||||
p->executable_path = executable_path ? executable_path : argv[0];
|
||||
|
||||
int i;
|
||||
int i = 0;
|
||||
|
||||
for(i = 1; i < argc; i++)
|
||||
{
|
||||
|
|
@ -107,10 +109,6 @@ void init_factor(F_PARAMETERS *p)
|
|||
if(p->image_path == NULL)
|
||||
p->image_path = default_image_path();
|
||||
|
||||
const F_CHAR *executable_path = vm_executable_path();
|
||||
if(executable_path)
|
||||
p->executable_path = executable_path;
|
||||
|
||||
srand(current_micros());
|
||||
init_ffi();
|
||||
init_stacks(p->ds_size,p->rs_size);
|
||||
|
|
|
|||
Loading…
Reference in New Issue