Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
061bcbb8eb
|
|
@ -89,11 +89,6 @@ set_md5sum() {
|
|||
set_gcc() {
|
||||
case $OS in
|
||||
openbsd) ensure_program_installed egcc; CC=egcc;;
|
||||
netbsd) if [[ $WORD -eq 64 ]] ; then
|
||||
CC=/usr/pkg/gcc34/bin/gcc
|
||||
else
|
||||
CC=gcc
|
||||
fi ;;
|
||||
*) CC=gcc;;
|
||||
esac
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: alarms
|
|||
USING: help.markup help.syntax calendar quotations ;
|
||||
|
||||
HELP: alarm
|
||||
{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
|
||||
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
||||
|
||||
HELP: add-alarm
|
||||
{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
|
||||
|
|
|
|||
|
|
@ -1,8 +0,0 @@
|
|||
IN: db.pooling.tests
|
||||
USING: db.pooling tools.test ;
|
||||
|
||||
\ <pool> must-infer
|
||||
|
||||
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] with-pooled-connection ] must-infer-as
|
||||
|
|
@ -1,43 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
destructors db ;
|
||||
IN: db.pooling
|
||||
|
||||
TUPLE: pool db params connections ;
|
||||
|
||||
: <pool> ( db params -- pool )
|
||||
V{ } clone pool boa ;
|
||||
|
||||
M: pool dispose [ dispose-each f ] change-connections drop ;
|
||||
|
||||
: with-db-pool ( db params quot -- )
|
||||
>r <pool> r> [ pool swap with-variable ] curry with-disposal ; inline
|
||||
|
||||
TUPLE: return-connection db pool ;
|
||||
|
||||
: return-connection ( db pool -- )
|
||||
connections>> push ;
|
||||
|
||||
: new-connection ( pool -- )
|
||||
[ [ db>> ] [ params>> ] bi make-db db-open ] keep
|
||||
return-connection ;
|
||||
|
||||
: acquire-connection ( pool -- db )
|
||||
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
|
||||
connections>> pop ;
|
||||
|
||||
: (with-pooled-connection) ( db pool quot -- )
|
||||
[ >r drop db r> with-variable ]
|
||||
[ drop return-connection ]
|
||||
3bi ; inline
|
||||
|
||||
: with-pooled-connection ( pool quot -- )
|
||||
>r [ acquire-connection ] keep r>
|
||||
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
|
||||
|
||||
M: return-connection dispose
|
||||
[ db>> ] [ pool>> ] bi return-connection ;
|
||||
|
||||
: return-connection-later ( db pool -- )
|
||||
\ return-connection boa &dispose drop ;
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
IN: db.pools.tests
|
||||
USING: db.pools tools.test ;
|
||||
|
||||
\ <db-pool> must-infer
|
||||
|
||||
{ 2 0 } [ [ ] with-db-pool ] must-infer-as
|
||||
|
||||
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
io.pools db ;
|
||||
IN: db.pools
|
||||
|
||||
TUPLE: db-pool < pool db params ;
|
||||
|
||||
: <db-pool> ( db params -- pool )
|
||||
db-pool <pool>
|
||||
swap >>params
|
||||
swap >>db ;
|
||||
|
||||
: with-db-pool ( db params quot -- )
|
||||
>r <db-pool> r> with-pool ; inline
|
||||
|
||||
M: db-pool make-connection ( pool -- )
|
||||
[ db>> ] [ params>> ] bi make-db db-open ;
|
||||
|
||||
: with-pooled-db ( pool quot -- )
|
||||
[ db swap with-variable ] curry with-pooled-connection ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien alien.c-types kernel math sequences strings
|
||||
USING: unix alien alien.c-types kernel math sequences strings
|
||||
io.unix.backend splitting ;
|
||||
IN: hardware-info.linux
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: db db.pooling http.server http.server.sessions kernel
|
||||
accessors continuations namespaces destructors ;
|
||||
USING: db db.pools io.pools http.server http.server.sessions
|
||||
kernel accessors continuations namespaces destructors ;
|
||||
IN: http.server.db
|
||||
|
||||
TUPLE: db-persistence < filter-responder pool ;
|
||||
|
||||
: <db-persistence> ( responder db params -- responder' )
|
||||
<pool> db-persistence boa ;
|
||||
<db-pool> db-persistence boa ;
|
||||
|
||||
M: db-persistence call-responder*
|
||||
[
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
IN: io.pools
|
||||
USING: help.markup help.syntax destructors quotations ;
|
||||
|
||||
HELP: pool
|
||||
{ $class-description "A connection pool. Instances of this class are not intended to be instantiated directly, only subclasses should be instantiated, for example " { $link datagram-pool } "." } ;
|
||||
|
||||
HELP: <pool>
|
||||
{ $values { "class" "a subclass of " { $link pool } } { "pool" pool } }
|
||||
{ $description "Creates a new connection pool." }
|
||||
{ $notes "To avoid resource leaks, pools must be disposed of by calling " { $link dispose } " when no longer in use." } ;
|
||||
|
||||
HELP: with-pool
|
||||
{ $values { "pool" pool } { "quot" quotation } }
|
||||
{ $description "Calls a quotation in a new dynamic scope with the " { $link pool } " variable set to " { $snippet "pool" } ". The pool is disposed of after the quotation returns, or if an error is thrown." } ;
|
||||
|
||||
HELP: acquire-connection
|
||||
{ $values { "pool" pool } { "conn" "a connection" } }
|
||||
{ $description "Outputs a connection from the pool, preferring to take an existing one, creating a new one with " { $link make-connection } " if the pool is empty." } ;
|
||||
|
||||
HELP: return-connection
|
||||
{ $values { "conn" "a connection" } { "pool" pool } }
|
||||
{ $description "Returns a connection to the pool." } ;
|
||||
|
||||
HELP: with-pooled-connection
|
||||
{ $values { "pool" pool } { "quot" "a quotation with stack effect " { $snippet "( conn -- )" } } }
|
||||
{ $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ;
|
||||
|
||||
HELP: make-connection
|
||||
{ $values { "pool" pool } { "conn" "a connection" } }
|
||||
{ $contract "Makes a connection for the pool." } ;
|
||||
|
||||
HELP: datagram-pool
|
||||
{ $class-description "A pool of datagram sockets bound to the address stored in the " { $snippet "addrspec" } " slot." } ;
|
||||
|
||||
HELP: <datagram-pool>
|
||||
{ $values { "addrspec" "an address specifier" } { "pool" datagram-pool } }
|
||||
{ $description "Creates a new " { $link datagram-pool } ". The port number of the " { $snippet "addrspec" } " should be 0, otherwise creation of more than one datagram socket will raise an error." }
|
||||
{ $examples
|
||||
{ $code "f 0 <inet4> <datagram-pool>" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "io.pools" "Connection pools"
|
||||
"Connection pools are implemented in the " { $snippet "io.pools" } " vocabulary. They are used to reuse sockets and connections which may be potentially expensive to create and destroy."
|
||||
$nl
|
||||
"The class of connection pools:"
|
||||
{ $subsection pool }
|
||||
"Creating connection pools:"
|
||||
{ $subsection <pool> }
|
||||
"A utility combinator:"
|
||||
{ $subsection with-pool }
|
||||
"Acquiring and returning connections, and a utility combinator:"
|
||||
{ $subsection acquire-connection }
|
||||
{ $subsection return-connection }
|
||||
{ $subsection with-pooled-connection }
|
||||
"Pools are not created directly, instead one uses subclasses which implement a generic word:"
|
||||
{ $subsection make-connection }
|
||||
"One example is a datagram socket pool:"
|
||||
{ $subsection datagram-pool }
|
||||
{ $subsection <datagram-pool> } ;
|
||||
|
||||
ABOUT: "io.pools"
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays namespaces sequences continuations
|
||||
destructors io.sockets ;
|
||||
IN: io.pools
|
||||
|
||||
TUPLE: pool connections disposed ;
|
||||
|
||||
: <pool> ( class -- pool )
|
||||
new V{ } clone >>connections ; inline
|
||||
|
||||
M: pool dispose* connections>> dispose-each ;
|
||||
|
||||
: with-pool ( pool quot -- )
|
||||
[ pool swap with-variable ] curry with-disposal ; inline
|
||||
|
||||
TUPLE: return-connection conn pool ;
|
||||
|
||||
: return-connection ( conn pool -- )
|
||||
dup check-disposed connections>> push ;
|
||||
|
||||
GENERIC: make-connection ( pool -- conn )
|
||||
|
||||
: new-connection ( pool -- )
|
||||
[ make-connection ] keep return-connection ;
|
||||
|
||||
: acquire-connection ( pool -- conn )
|
||||
dup check-disposed
|
||||
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
|
||||
connections>> pop ;
|
||||
|
||||
: (with-pooled-connection) ( conn pool quot -- )
|
||||
[ nip call ] [ drop return-connection ] 3bi ; inline
|
||||
|
||||
: with-pooled-connection ( pool quot -- )
|
||||
>r [ acquire-connection ] keep r>
|
||||
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
|
||||
|
||||
M: return-connection dispose
|
||||
[ conn>> ] [ pool>> ] bi return-connection ;
|
||||
|
||||
: return-connection-later ( db pool -- )
|
||||
\ return-connection boa &dispose drop ;
|
||||
|
||||
TUPLE: datagram-pool < pool addrspec ;
|
||||
|
||||
: <datagram-pool> ( addrspec -- pool )
|
||||
datagram-pool <pool> swap >>addrspec ;
|
||||
|
||||
M: datagram-pool make-connection addrspec>> <datagram> ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Abstract connection pooling
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
IN: io.sockets.secure
|
||||
USING: help.markup help.syntax calendar quotations io.sockets ;
|
||||
|
||||
HELP: secure-socket-timeout
|
||||
{ $var-description "Timeout for operations not associated with a constructed port instance, such as SSL handshake and shutdown. Represented as a " { $link duration } "." } ;
|
||||
|
||||
HELP: SSLv2
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"Note that the SSLv2 protocol is vulnerable to truncation attacks and its use is discouraged (" { $url "http://www.gnu.org/software/gnutls/manual/html_node/On-SSL-2-and-older-protocols.html" } ")." } ;
|
||||
|
||||
HELP: SSLv3
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"SSLv3 is widely used, however it is being supersceded by TLSv1." } ;
|
||||
|
||||
HELP: SSLv23
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"This value indicates that either SSLv2 or SSLv3 is acceptable." } ;
|
||||
|
||||
HELP: TLSv1
|
||||
{ $description "Possible value for the " { $snippet "method" } " slot of a " { $link secure-config } "."
|
||||
$nl
|
||||
"TLSv1 is the newest protocol for secure socket communications." } ;
|
||||
|
||||
ARTICLE: "ssl-methods" "SSL/TLS methods"
|
||||
"The " { $snippet "method" } " slot of a " { $link secure-config } " can be set to one of the following values:"
|
||||
{ $subsection SSLv2 }
|
||||
{ $subsection SSLv23 }
|
||||
{ $subsection SSLv3 }
|
||||
{ $subsection TLSv1 }
|
||||
"The default value is " { $link SSLv23 } "." ;
|
||||
|
||||
HELP: secure-config
|
||||
{ $class-description "Instances represent secure socket configurations." } ;
|
||||
|
||||
HELP: <secure-config>
|
||||
{ $values { "config" secure-config } }
|
||||
{ $description "Creates a new secure socket configration with default values." } ;
|
||||
|
||||
ARTICLE: "ssl-key-file" "The key file and password"
|
||||
"The " { $snippet "key-file" } " and " { $snippet "password" } " slots of a " { $link secure-config } " can be set to a private key file in PEM format. These slots are required for secure servers, and also for clients when client-side authentication is used." ;
|
||||
|
||||
ARTICLE: "ssl-ca-file" "The CA file and path"
|
||||
"The " { $snippet "ca-file" } " slot of a " { $link secure-config } " can contain the path of a file with a list of trusted certificates in PEM format. The " { $snippet "ca-path" } " slot can contain the path of a directory of trusted certifications."
|
||||
$nl
|
||||
"One of these slots are required to be specified so that secure client sockets can verify server certificates."
|
||||
$nl
|
||||
"See " { $url "http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html" } " for details." ;
|
||||
|
||||
ARTICLE: "ssl-dh-file" "Diffie-Hellman parameter file"
|
||||
"The " { $snippet "dh-file" } " slot of a " { $link secure-config } " can contain the path of a file with Diffie-Hellman key exchange parameters."
|
||||
$nl
|
||||
"This slot is required for secure server sockets." ;
|
||||
|
||||
ARTICLE: "ssl-ephemeral-rsa" "Ephemeral RSA key bits"
|
||||
"The " { $snippet "ephemeral-key-bits" } " slot of a " { $link secure-config } " contains the length of the empheral RSA key, in bits."
|
||||
$nl
|
||||
"The default value is 1024, and anything less than that is considered insecure. This slot is required for secure server sockets." ;
|
||||
|
||||
ARTICLE: "ssl-config" "Secure socket configuration"
|
||||
"Secure sockets require some configuration, particularly for server sockets. A class represents secure socket configuration parameters:"
|
||||
{ $subsection secure-config }
|
||||
"Creating new instances:"
|
||||
{ $subsection <secure-config> }
|
||||
"Configuration parameters:"
|
||||
{ $subsection "ssl-methods" }
|
||||
{ $subsection "ssl-key-file" }
|
||||
{ $subsection "ssl-ca-file" }
|
||||
{ $subsection "ssl-dh-file" }
|
||||
{ $subsection "ssl-ephemeral-rsa" } ;
|
||||
|
||||
HELP: <secure-context>
|
||||
{ $values { "config" secure-config } { "context" secure-context } }
|
||||
{ $description "Creates a new " { $link secure-context } ". This word should not usually be called directly, use " { $link with-secure-context } " instead." } ;
|
||||
|
||||
HELP: with-secure-context
|
||||
{ $values { "config" secure-config } { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new dynamic scope where a " { $link secure-context } " constructed from the specified configuration is available." } ;
|
||||
|
||||
ARTICLE: "ssl-contexts" "Secure socket contexts"
|
||||
"All secure socket operations must be performed in a secure socket context. A context is created from a secure socket configuration. An implicit context with the default configuration is always available, however server sockets require a certificate to be set together with other parameters, and the default configuration is insufficient, so a context must be explicitly created in that case."
|
||||
{ $subsection with-secure-context } ;
|
||||
|
||||
HELP: secure
|
||||
{ $class-description "The class of secure socket addresses." } ;
|
||||
|
||||
HELP: <secure> ( addrspec -- secure )
|
||||
{ $values { "addrspec" "an address specifier" } { "secure" secure } }
|
||||
{ $description "Creates a new secure socket address, which can then be passed to " { $link <client> } " or " { $link <server> } "." } ;
|
||||
|
||||
ARTICLE: "ssl-addresses" "Secure socket addresses"
|
||||
"Secure socket connections are established by passing a secure socket address to " { $link <client> } " or " { $link <server> } "."
|
||||
$nl
|
||||
"Secure socket addresses form a class:"
|
||||
{ $subsection secure }
|
||||
"Constructing secure socket addresses:"
|
||||
{ $subsection <secure> }
|
||||
"Instances of this class can wrap an " { $link inet } ", " { $link inet4 } " or an " { $link inet6 } ", although note that certificate validation is only performed for instances of " { $link inet } " since otherwise the host name is not available." ;
|
||||
|
||||
HELP: premature-close
|
||||
{ $error-description "Thrown if an SSL connection is closed without the proper " { $snippet "close_notify" } " sequence. This error is never reported for " { $link SSLv2 } " connections because there is no distinction between expected and unexpected connection closure in that case." } ;
|
||||
|
||||
HELP: certificate-verify-error
|
||||
{ $error-description "Thrown if certificate verification failed. The " { $snippet "result" } " slot contains an object identifying the low-level error that occurred." } ;
|
||||
|
||||
HELP: common-name-verify-error
|
||||
{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $snippet "expected" } " and " { $snippet "got" } " slots contain the mismatched host names." } ;
|
||||
|
||||
ARTICLE: "ssl-errors" "Secure socket errors"
|
||||
"Secure sockets can throw one of several errors in addition to the usual I/O errors:"
|
||||
{ $subsection premature-close }
|
||||
{ $subsection certificate-verify-error }
|
||||
{ $subsection common-name-verify-error } ;
|
||||
|
||||
ARTICLE: "io.sockets.secure" "Secure sockets (SSL, TLS)"
|
||||
"The " { $vocab-link "io.sockets.secure" } " vocabulary implements secure, encrypted sockets using the OpenSSL library."
|
||||
{ $subsection "ssl-config" }
|
||||
{ $subsection "ssl-contexts" }
|
||||
{ $subsection "ssl-addresses" }
|
||||
{ $subsection "ssl-errors" }
|
||||
"This product includes software developed by the OpenSSL Project for use in the OpenSSL Toolkit (" { $url "http://www.openssl.org/" } "), cryptographic software written by Eric Young (eay@cryptsoft.com) and software written by Tim Hudson (tjh@cryptsoft.com)." ;
|
||||
|
||||
ABOUT: "io.sockets.secure"
|
||||
|
|
@ -15,6 +15,8 @@ SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
|
|||
TUPLE: secure-config
|
||||
method
|
||||
key-file password
|
||||
verify
|
||||
verify-depth
|
||||
ca-file ca-path
|
||||
dh-file
|
||||
ephemeral-key-bits ;
|
||||
|
|
@ -22,7 +24,9 @@ ephemeral-key-bits ;
|
|||
: <secure-config> ( -- config )
|
||||
secure-config new
|
||||
SSLv23 >>method
|
||||
512 >>ephemeral-key-bits ;
|
||||
1024 >>ephemeral-key-bits
|
||||
"resource:extra/openssl/cacert.pem" >>ca-file
|
||||
t >>verify ;
|
||||
|
||||
TUPLE: secure-context config handle disposed ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Secure sockets (SSL, TLS)
|
||||
|
|
@ -0,0 +1 @@
|
|||
network
|
||||
|
|
@ -27,7 +27,8 @@ $nl
|
|||
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
|
||||
{ { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" }
|
||||
}
|
||||
"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." ;
|
||||
"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link <server> } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface."
|
||||
{ $see-also "io.sockets.secure" } ;
|
||||
|
||||
ARTICLE: "network-packet" "Packet-oriented networking"
|
||||
"A packet-oriented socket can be opened with this word:"
|
||||
|
|
@ -49,11 +50,13 @@ ARTICLE: "network-streams" "Networking"
|
|||
"Factor supports connection-oriented and packet-oriented communication over a variety of protocols:"
|
||||
{ $list
|
||||
"TCP/IP and UDP/IP, over IPv4 and IPv6"
|
||||
"Unix domain sockets"
|
||||
"Unix domain sockets (Unix only)"
|
||||
}
|
||||
{ $subsection "network-addressing" }
|
||||
{ $subsection "network-connection" }
|
||||
{ $subsection "network-packet" } ;
|
||||
{ $subsection "network-packet" }
|
||||
{ $subsection "io.sockets.secure" }
|
||||
{ $see-also "io.pipes" } ;
|
||||
|
||||
ABOUT: "network-streams"
|
||||
|
||||
|
|
|
|||
|
|
@ -24,8 +24,13 @@ TUPLE: fd fd disposed ;
|
|||
[ >>fd ]
|
||||
tri ;
|
||||
|
||||
M: fd dispose*
|
||||
[ cancel-operation ] [ fd>> close-file ] bi ;
|
||||
M: fd dispose
|
||||
dup disposed>> [ drop ] [
|
||||
[ cancel-operation ]
|
||||
[ t >>disposed drop ]
|
||||
[ fd>> close-file ]
|
||||
tri
|
||||
] if ;
|
||||
|
||||
M: fd handle-fd dup check-disposed fd>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
: with-test-context
|
||||
<secure-config>
|
||||
"resource:extra/openssl/test/server.pem" >>key-file
|
||||
"resource:extra/openssl/test/root.pem" >>ca-file
|
||||
"resource:extra/openssl/test/dh1024.pem" >>dh-file
|
||||
"password" >>password
|
||||
swap with-secure-context ;
|
||||
|
|
@ -44,8 +43,8 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
[ ] [
|
||||
[
|
||||
drop
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
"hello" write flush
|
||||
input-stream get stream>> handle>> f >>connected drop
|
||||
] server-test
|
||||
] unit-test
|
||||
|
||||
|
|
@ -55,7 +54,7 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
! actually an invalid certificate
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [ [ drop ] server-test ] unit-test
|
||||
[ ] [ [ drop "hi" write ] server-test ] unit-test
|
||||
|
||||
[
|
||||
<secure-config> [
|
||||
|
|
@ -97,54 +96,58 @@ concurrency.promises byte-arrays locals calendar io.timeouts ;
|
|||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
accept drop dup stream-read1 drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Client socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop 1 minutes sleep dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] "Silly server" spawn drop
|
||||
] unit-test
|
||||
|
||||
! Until I sort out two-stage handshaking, I can't do much here
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
||||
ascii <client> drop dispose
|
||||
] with-secure-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Server socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop 1 minutes sleep dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] "Silly server" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure>
|
||||
ascii <client> drop dispose
|
||||
] with-secure-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
|
||||
! Server socket shutdown timeout
|
||||
[ ] [ <promise> "port" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"127.0.0.1" "port" get ?promise
|
||||
<inet4> <secure> ascii <client> drop 1 minutes sleep dispose
|
||||
] with-test-context
|
||||
] "Silly client" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
[
|
||||
"127.0.0.1" "port" get ?promise
|
||||
<inet4> <secure> ascii <client> drop 1 minutes sleep dispose
|
||||
] with-test-context
|
||||
] "Silly client" spawn drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
1 seconds secure-socket-timeout [
|
||||
[
|
||||
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
|
||||
dup addr>> addrspec>> port>> "port" get fulfill
|
||||
accept drop dispose
|
||||
] with-disposal
|
||||
] with-test-context
|
||||
] with-variable
|
||||
] [ io-timeout? ] must-fail-with
|
||||
] drop
|
||||
|
|
|
|||
|
|
@ -22,6 +22,26 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
nip (ssl-error)
|
||||
] if ;
|
||||
|
||||
: check-accept-response ( handle r -- event )
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
|
||||
|
||||
: maybe-handshake ( ssl-handle -- )
|
||||
dup connected>> [ drop ] [
|
||||
t >>connected
|
||||
[ do-ssl-accept ] with-timeout
|
||||
] if ;
|
||||
|
||||
: check-response ( port r -- port r n )
|
||||
over handle>> handle>> over SSL_get_error ; inline
|
||||
|
||||
|
|
@ -38,6 +58,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
|
|||
} case ;
|
||||
|
||||
M: ssl-handle refill
|
||||
dup maybe-handshake
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer-end ] ! buf
|
||||
|
|
@ -57,6 +78,7 @@ M: ssl-handle refill
|
|||
} case ;
|
||||
|
||||
M: ssl-handle drain
|
||||
dup maybe-handshake
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer@ ] ! buf
|
||||
|
|
@ -107,52 +129,25 @@ M: secure establish-connection ( client-out remote -- )
|
|||
|
||||
M: secure (server) addrspec>> (server) ;
|
||||
|
||||
: check-accept-response ( handle r -- event )
|
||||
M: secure (accept)
|
||||
[
|
||||
addrspec>> (accept) >r |dispose <ssl-socket> r>
|
||||
] with-destructors ;
|
||||
|
||||
: check-shutdown-response ( handle r -- event )
|
||||
#! We don't do two-step shutdown here because I couldn't
|
||||
#! figure out how to do it with non-blocking BIOs. Also, it
|
||||
#! seems that SSL_shutdown always returns 0 -- this sounds
|
||||
#! like a bug
|
||||
over handle>> over SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
|
||||
|
||||
M: secure (accept)
|
||||
[
|
||||
addrspec>> (accept) >r
|
||||
|dispose <ssl-socket> t >>connected |dispose
|
||||
dup [ do-ssl-accept ] with-timeout r>
|
||||
] with-destructors ;
|
||||
|
||||
: check-shutdown-response ( handle r -- event )
|
||||
#! SSL_shutdown always returns 0 due to openssl bugs?
|
||||
{
|
||||
{ 1 [ drop f ] }
|
||||
{ 0 [
|
||||
dup handle>> dup f 0 SSL_read 2dup SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_ZERO_RETURN [ 3drop +retry+ ] }
|
||||
{ SSL_ERROR_WANT_READ [ 3drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 3drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
{ -1 [
|
||||
handle>> -1 SSL_get_error
|
||||
{
|
||||
{ SSL_ERROR_WANT_READ [ +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ -1 syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: (shutdown) ( handle -- )
|
||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||
dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.ports io.sockets io.binary
|
||||
io.sockets windows.errors strings
|
||||
io.sockets io.timeouts windows.errors strings
|
||||
kernel math namespaces sequences windows windows.kernel32
|
||||
windows.shell32 windows.types windows.winsock splitting
|
||||
continuations math.bitfields system accessors ;
|
||||
|
|
@ -24,8 +24,10 @@ TUPLE: win32-file < win32-handle ptr ;
|
|||
: <win32-file> ( handle -- win32-file )
|
||||
win32-file new-win32-handle ;
|
||||
|
||||
M: win32-file dispose*
|
||||
[ cancel-operation ] [ call-next-method ] bi ;
|
||||
M: win32-file dispose
|
||||
dup disposed>> [ drop ] [
|
||||
[ cancel-operation ] [ call-next-method ] bi
|
||||
] if ;
|
||||
|
||||
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
|
||||
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -122,6 +122,11 @@ FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
|
|||
|
||||
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
: SSL_SENT_SHUTDOWN 1 ;
|
||||
: SSL_RECEIVED_SHUTDOWN 2 ;
|
||||
|
||||
FUNCTION: int SSL_get_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: int SSL_want ( ssl-pointer ssl ) ;
|
||||
|
|
@ -151,6 +156,15 @@ FUNCTION: int SSL_use_certificate_file ( ssl-pointer ssl,
|
|||
FUNCTION: int SSL_CTX_load_verify_locations ( ssl-ctx ctx, char* CAfile,
|
||||
char* CApath ) ;
|
||||
|
||||
FUNCTION: int SSL_CTX_set_default_verify_paths ( ssl-ctx ctx ) ;
|
||||
|
||||
: SSL_VERIFY_NONE 0 ; inline
|
||||
: SSL_VERIFY_PEER 1 ; inline
|
||||
: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
|
||||
: SSL_VERIFY_CLIENT_ONCE 4 ; inline
|
||||
|
||||
FUNCTION: void SSL_CTX_set_verify ( ssl-ctx ctx, int mode, void* callback ) ;
|
||||
|
||||
FUNCTION: void SSL_CTX_set_client_CA_list ( ssl-ctx ctx, ssl-pointer list ) ;
|
||||
|
||||
FUNCTION: ssl-pointer SSL_load_client_CA_file ( char* file ) ;
|
||||
|
|
|
|||
|
|
@ -94,11 +94,14 @@ TUPLE: openssl-context < secure-context aliens ;
|
|||
[ ca-file>> dup [ (normalize-path) ] when ]
|
||||
[ ca-path>> dup [ (normalize-path) ] when ] bi
|
||||
] bi
|
||||
SSL_CTX_load_verify_locations ssl-error
|
||||
] [ drop ] if ;
|
||||
SSL_CTX_load_verify_locations
|
||||
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
|
||||
|
||||
: set-verify-depth ( ctx -- )
|
||||
handle>> 1 SSL_CTX_set_verify_depth ;
|
||||
dup config>> verify-depth>> [
|
||||
[ handle>> ] [ config>> verify-depth>> ] bi
|
||||
SSL_CTX_set_verify_depth
|
||||
] [ drop ] if ;
|
||||
|
||||
TUPLE: bio handle disposed ;
|
||||
|
||||
|
|
@ -154,11 +157,6 @@ M: openssl-context dispose*
|
|||
|
||||
TUPLE: ssl-handle file handle connected disposed ;
|
||||
|
||||
ERROR: no-secure-context ;
|
||||
|
||||
M: no-secure-context summary
|
||||
drop "Secure socket operations must be wrapped in calls to with-secure-context" ;
|
||||
|
||||
SYMBOL: default-secure-context
|
||||
|
||||
: context-expired? ( context -- ? )
|
||||
|
|
@ -195,9 +193,11 @@ M: ssl-handle dispose*
|
|||
[ 2drop ] [ common-name-verify-error ] if ;
|
||||
|
||||
M: openssl check-certificate ( host ssl -- )
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi ;
|
||||
current-secure-context config>> verify>> [
|
||||
handle>>
|
||||
[ nip check-verify-result ]
|
||||
[ check-common-name ]
|
||||
2bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
openssl secure-socket-backend set-global
|
||||
|
|
|
|||
|
|
@ -1,3 +1,2 @@
|
|||
enterprise
|
||||
network
|
||||
bindings
|
||||
|
|
|
|||
|
|
@ -131,6 +131,116 @@ IN: regexp4-tests
|
|||
[ f ] [ "\\" "[^\\\\]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\\\]" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "0" "[\\d]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "[\\d]" <regexp> matches? ] unit-test
|
||||
[ f ] [ "0" "[^\\d]" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "[^\\d]" <regexp> matches? ] unit-test
|
||||
|
||||
[ 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
|
||||
|
||||
[ t ] [ "abc" "\\p{Lower}{3}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "ABC" "\\p{Lower}{3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "\\p{Upper}{3}" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\p{Upper}{3}" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "abc" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
|
||||
[ t ] [ "ABC" "[\\p{Upper}]{3}" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "" "\\Q\\E" <regexp> matches? ] unit-test
|
||||
[ f ] [ "a" "\\Q\\E" <regexp> matches? ] unit-test
|
||||
[ t ] [ "|*+" "\\Q|*+\\E" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abc" "\\Q|*+\\E" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "S" "\\0123" <regexp> matches? ] unit-test
|
||||
[ t ] [ "SXY" "\\0123XY" <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\x78" <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\x78" <regexp> matches? ] unit-test
|
||||
[ t ] [ "x" "\\u000078" <regexp> matches? ] unit-test
|
||||
[ f ] [ "y" "\\u000078" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "ab" "a+b" <regexp> matches? ] unit-test
|
||||
[ f ] [ "b" "a+b" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aab" "a+b" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abb" "a+b" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "abbbb" "ab*" <regexp> matches? ] unit-test
|
||||
[ t ] [ "a" "ab*" <regexp> matches? ] unit-test
|
||||
[ f ] [ "abab" "ab*" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "x" "\\." <regexp> matches? ] unit-test
|
||||
[ t ] [ "." "\\." <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "aaaab" "a+ab" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
|
||||
[ f ] [ "aaaab" "a++ab" <regexp> matches? ] unit-test
|
||||
[ t ] [ "aaacb" "a++cb" <regexp> matches? ] unit-test
|
||||
|
||||
[ 3 ] [ "aaacb" "a*" <regexp> match-head ] unit-test
|
||||
[ 1 ] [ "aaacb" "a+?" <regexp> match-head ] unit-test
|
||||
[ 2 ] [ "aaacb" "aa?" <regexp> match-head ] unit-test
|
||||
[ 1 ] [ "aaacb" "aa??" <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "aacb" "aa?c" <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "aacb" "aa??c" <regexp> match-head ] unit-test
|
||||
|
||||
! [ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
|
||||
! [ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
|
||||
! [ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
|
||||
! [ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
|
||||
! [ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
|
||||
|
||||
[ ] [
|
||||
"(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
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
! [ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
|
||||
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
|
||||
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
|
||||
|
||||
! [ 3 ] [ "foo bar" "foo\\b" <regexp> match-head ] unit-test
|
||||
! [ f ] [ "fooxbar" "foo\\b" <regexp> matches? ] unit-test
|
||||
! [ t ] [ "foo" "foo\\b" <regexp> matches? ] unit-test
|
||||
! [ t ] [ "foo bar" "foo\\b bar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "fooxbar" "foo\\bxbar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foo" "foo\\bbar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ f ] [ "foo bar" "foo\\B" <regexp> matches? ] unit-test
|
||||
! [ 3 ] [ "fooxbar" "foo\\B" <regexp> match-head ] unit-test
|
||||
! [ t ] [ "foo" "foo\\B" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foo bar" "foo\\B bar" <regexp> matches? ] unit-test
|
||||
! [ t ] [ "fooxbar" "foo\\Bxbar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foo" "foo\\Bbar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
|
||||
! [ t ] [ ".o" "\\.[a-z]" <regexp> matches? ] unit-test
|
||||
|
||||
! Bug in parsing word
|
||||
[ t ] [
|
||||
"a"
|
||||
R' a'
|
||||
matches?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
! ((A)(B(C)))
|
||||
! 1. ((A)(B(C)))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors arrays assocs combinators kernel math
|
|||
sequences namespaces locals combinators.lib state-tables
|
||||
math.parser state-parser sets dlists unicode.categories
|
||||
math.order quotations shuffle math.ranges splitting
|
||||
symbols fry ;
|
||||
symbols fry parser ;
|
||||
IN: regexp4
|
||||
|
||||
SYMBOLS: eps start-state final-state beginning-of-text
|
||||
|
|
@ -544,6 +544,33 @@ ERROR: unsupported-token token ;
|
|||
<vector-table> >>nfa
|
||||
dup [ parse-raw-regexp ] [ subset-construction ] bi ;
|
||||
|
||||
! Literal syntax for regexps
|
||||
: parse-options ( string -- ? )
|
||||
#! Lame
|
||||
{
|
||||
{ "" [ f ] }
|
||||
{ "i" [ t ] }
|
||||
} case ;
|
||||
|
||||
: parse-regexp ( accum end -- accum )
|
||||
lexer get dup skip-blank
|
||||
[ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
|
||||
! lexer get dup still-parsing-line?
|
||||
! [ (parse-token) parse-options ] [ drop f ] if
|
||||
<regexp> parsed ;
|
||||
|
||||
: R! CHAR: ! parse-regexp ; parsing
|
||||
: R" CHAR: " parse-regexp ; parsing
|
||||
: R# CHAR: # parse-regexp ; parsing
|
||||
: R' CHAR: ' parse-regexp ; parsing
|
||||
: R( CHAR: ) parse-regexp ; parsing
|
||||
: R/ CHAR: / parse-regexp ; parsing
|
||||
: R@ CHAR: @ parse-regexp ; parsing
|
||||
: R[ CHAR: ] parse-regexp ; parsing
|
||||
: R` CHAR: ` parse-regexp ; parsing
|
||||
: R{ CHAR: } parse-regexp ; parsing
|
||||
: R| CHAR: | parse-regexp ; parsing
|
||||
|
||||
TUPLE: dfa-traverser
|
||||
dfa
|
||||
last-state current-state
|
||||
|
|
@ -611,6 +638,9 @@ TUPLE: dfa-traverser
|
|||
: matches? ( string regexp -- ? )
|
||||
dupd match [ [ length ] [ range-length 1- ] bi* = ] [ drop f ] if* ;
|
||||
|
||||
: match-head ( string regexp -- end )
|
||||
match length>> ;
|
||||
|
||||
! character classes
|
||||
! TUPLE: range-class from to ;
|
||||
! TUPLE: or-class left right ;
|
||||
|
|
|
|||
|
|
@ -160,6 +160,7 @@ M: stack-display tool-scroller
|
|||
{
|
||||
[ com-end ]
|
||||
[ clear-output ]
|
||||
[ input>> clear-input ]
|
||||
[ start-listener-thread ]
|
||||
[ wait-for-listener ]
|
||||
} cleave ;
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ include vm/Config.unix
|
|||
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
|
||||
CFLAGS += -export-dynamic
|
||||
LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
|
||||
LIBS = -lm $(X11_UI_LIBS)
|
||||
LIBS = -lm -lopenal -lalut $(X11_UI_LIBS)
|
||||
|
|
|
|||
Loading…
Reference in New Issue