From 2ddc0028f08740af704f5b47c46f43ea142e61f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:41:54 -0500 Subject: [PATCH 01/21] Working on OpenSSL --- {unmaintained => extra}/openssl/authors.txt | 0 .../openssl/libcrypto/libcrypto.factor | 45 ++++- .../openssl/libssl/libssl.factor | 67 +++++++- .../openssl/openssl-docs.factor | 0 extra/openssl/openssl-tests.factor | 20 +++ extra/openssl/openssl.factor | 151 +++++++++++++++++ {unmaintained => extra}/openssl/summary.txt | 0 {unmaintained => extra}/openssl/tags.txt | 0 .../openssl/test/dh1024.pem | 0 .../openssl/test/errors.txt | 0 {unmaintained => extra}/openssl/test/root.pem | 0 .../openssl/test/server.pem | 0 extra/openssl/unix/unix.factor | 11 ++ unmaintained/openssl/openssl-tests.factor | 146 ----------------- unmaintained/openssl/openssl.factor | 154 ------------------ 15 files changed, 282 insertions(+), 312 deletions(-) rename {unmaintained => extra}/openssl/authors.txt (100%) rename {unmaintained => extra}/openssl/libcrypto/libcrypto.factor (73%) rename {unmaintained => extra}/openssl/libssl/libssl.factor (67%) rename {unmaintained => extra}/openssl/openssl-docs.factor (100%) create mode 100755 extra/openssl/openssl-tests.factor create mode 100755 extra/openssl/openssl.factor rename {unmaintained => extra}/openssl/summary.txt (100%) rename {unmaintained => extra}/openssl/tags.txt (100%) rename {unmaintained => extra}/openssl/test/dh1024.pem (100%) rename {unmaintained => extra}/openssl/test/errors.txt (100%) rename {unmaintained => extra}/openssl/test/root.pem (100%) rename {unmaintained => extra}/openssl/test/server.pem (100%) create mode 100644 extra/openssl/unix/unix.factor delete mode 100755 unmaintained/openssl/openssl-tests.factor delete mode 100755 unmaintained/openssl/openssl.factor diff --git a/unmaintained/openssl/authors.txt b/extra/openssl/authors.txt similarity index 100% rename from unmaintained/openssl/authors.txt rename to extra/openssl/authors.txt diff --git a/unmaintained/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor similarity index 73% rename from unmaintained/openssl/libcrypto/libcrypto.factor rename to extra/openssl/libcrypto/libcrypto.factor index 312c7b04b3..20b606db66 100755 --- a/unmaintained/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -88,6 +88,8 @@ FUNCTION: int BIO_puts ( void* bp, char* buf ) ; FUNCTION: ulong ERR_get_error ( ) ; +FUNCTION: void ERR_clear_error ( ) ; + FUNCTION: char* ERR_error_string ( ulong e, void* buf ) ; FUNCTION: void* BIO_f_buffer ( ) ; @@ -96,6 +98,17 @@ FUNCTION: void* BIO_f_buffer ( ) ; ! evp.h ! =============================================== +: EVP_MAX_MD_SIZE 64 ; + +C-STRUCT: EVP_MD_CTX + { "EVP_MD*" "digest" } + { "ENGINE*" "engine" } + { "ulong" "flags" } + { "void*" "md_data" } ; + +TYPEDEF: void* EVP_MD* +TYPEDEF: void* ENGINE* + ! Initialize ciphers and digest tables FUNCTION: void OpenSSL_add_all_ciphers ( ) ; @@ -104,19 +117,35 @@ FUNCTION: void OpenSSL_add_all_digests ( ) ; ! Clean them up before exiting FUNCTION: void EVP_cleanup ( ) ; -FUNCTION: void* EVP_get_digestbyname ( char* name ) ; +FUNCTION: EVP_MD* EVP_get_digestbyname ( char* name ) ; -FUNCTION: void EVP_MD_CTX_init ( void* ctx ) ; +FUNCTION: void EVP_MD_CTX_init ( EVP_MD* ctx ) ; + +FUNCTION: int EVP_MD_CTX_cleanup ( EVP_MD_CTX* ctx ) ; + +FUNCTION: EVP_MD_CTX* EVP_MD_CTX_create ( ) ; + +FUNCTION: void EVP_MD_CTX_destroy ( EVP_MD_CTX* ctx ) ; + +FUNCTION: int EVP_MD_CTX_copy_ex ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; + +FUNCTION: int EVP_DigestInit_ex ( EVP_MD_CTX* ctx, EVP_MD* type, ENGINE* impl ) ; + +FUNCTION: int EVP_DigestUpdate ( EVP_MD_CTX* ctx, void* d, uint cnt ) ; + +FUNCTION: int EVP_DigestFinal_ex ( EVP_MD_CTX* ctx, void* md, uint* s ) ; + +FUNCTION: int EVP_Digest ( void* data, uint count, void* md, uint* size, EVP_MD* type, ENGINE* impl ) ; + +FUNCTION: int EVP_MD_CTX_copy ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; + +FUNCTION: int EVP_DigestInit ( EVP_MD_CTX* ctx, EVP_MD* type ) ; + +FUNCTION: int EVP_DigestFinal ( EVP_MD_CTX* ctx, void* md, uint* s ) ; FUNCTION: void* PEM_read_bio_DHparams ( void* bp, void* x, void* cb, void* u ) ; -! =============================================== -! md5.h -! =============================================== - -FUNCTION: uchar* MD5 ( uchar* d, ulong n, uchar* md ) ; - ! =============================================== ! rsa.h ! =============================================== diff --git a/unmaintained/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor similarity index 67% rename from unmaintained/openssl/libssl/libssl.factor rename to extra/openssl/libssl/libssl.factor index 0f2e7b3184..d1c53c4b23 100755 --- a/unmaintained/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -97,6 +97,7 @@ FUNCTION: ssl-ctx SSL_CTX_new ( ssl-method method ) ; ! Load the certificates and private keys into the SSL_CTX FUNCTION: int SSL_CTX_use_certificate_chain_file ( ssl-ctx ctx, char* file ) ; ! PEM type + FUNCTION: ssl-pointer SSL_new ( ssl-ctx ctx ) ; FUNCTION: int SSL_set_fd ( ssl-pointer ssl, int fd ) ; @@ -121,6 +122,10 @@ FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ; +FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ; + +FUNCTION: X509* SSL_get_peer_certificate ( SSL* s ) ; + FUNCTION: void SSL_CTX_free ( ssl-ctx ctx ) ; FUNCTION: void RAND_seed ( void* buf, int num ) ; @@ -165,10 +170,64 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ; FUNCTION: void* BIO_f_ssl ( ) ; ! =============================================== -! sha.h +! x509.h ! =============================================== -! For a high level interface to message digests -! use the EVP digest routines in libcrypto.factor +TYPEDEF: void* X509_NAME* -FUNCTION: uchar* SHA1 ( uchar* d, ulong n, uchar* md ) ; +TYPEDEF: void* X509* + +FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; +FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; + +! =============================================== +! x509_vfy.h +! =============================================== + +: X509_V_OK 0 ; inline +: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT 2 ; inline +: X509_V_ERR_UNABLE_TO_GET_CRL 3 ; inline +: X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 ; inline +: X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 ; inline +: X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 ; inline +: X509_V_ERR_CERT_SIGNATURE_FAILURE 7 ; inline +: X509_V_ERR_CRL_SIGNATURE_FAILURE 8 ; inline +: X509_V_ERR_CERT_NOT_YET_VALID 9 ; inline +: X509_V_ERR_CERT_HAS_EXPIRED 10 ; inline +: X509_V_ERR_CRL_NOT_YET_VALID 11 ; inline +: X509_V_ERR_CRL_HAS_EXPIRED 12 ; inline +: X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 ; inline +: X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14 ; inline +: X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15 ; inline +: X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16 ; inline +: X509_V_ERR_OUT_OF_MEM 17 ; inline +: X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 ; inline +: X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN 19 ; inline +: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 ; inline +: X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 ; inline +: X509_V_ERR_CERT_CHAIN_TOO_LONG 22 ; inline +: X509_V_ERR_CERT_REVOKED 23 ; inline +: X509_V_ERR_INVALID_CA 24 ; inline +: X509_V_ERR_PATH_LENGTH_EXCEEDED 25 ; inline +: X509_V_ERR_INVALID_PURPOSE 26 ; inline +: X509_V_ERR_CERT_UNTRUSTED 27 ; inline +: X509_V_ERR_CERT_REJECTED 28 ; inline +: X509_V_ERR_SUBJECT_ISSUER_MISMATCH 29 ; inline +: X509_V_ERR_AKID_SKID_MISMATCH 30 ; inline +: X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH 31 ; inline +: X509_V_ERR_KEYUSAGE_NO_CERTSIGN 32 ; inline +: X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER 33 ; inline +: X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION 34 ; inline +: X509_V_ERR_KEYUSAGE_NO_CRL_SIGN 35 ; inline +: X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 ; inline +: X509_V_ERR_INVALID_NON_CA 37 ; inline +: X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED 38 ; inline +: X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 ; inline +: X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 ; inline +: X509_V_ERR_APPLICATION_VERIFICATION 50 ; inline + +! =============================================== +! obj_mac.h +! =============================================== + +: NID_commonName 13 ; inline diff --git a/unmaintained/openssl/openssl-docs.factor b/extra/openssl/openssl-docs.factor similarity index 100% rename from unmaintained/openssl/openssl-docs.factor rename to extra/openssl/openssl-docs.factor diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor new file mode 100755 index 0000000000..d06340d518 --- /dev/null +++ b/extra/openssl/openssl-tests.factor @@ -0,0 +1,20 @@ +USING: io.sockets.secure io.encodings.ascii alien.strings +openssl namespaces accessors tools.test continuations kernel ; + +openssl ssl-backend [ + [ ] [ + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/root.pem" >>ca-file + "password" ascii string>alien >>password + [ ] with-ssl-context + ] unit-test + + [ + + "resource:extra/openssl/test/server.pem" >>key-file + "resource:extra/openssl/test/root.pem" >>ca-file + "wrong password" ascii string>alien >>password + [ ] with-ssl-context + ] must-fail +] with-variable diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor new file mode 100755 index 0000000000..196ac58695 --- /dev/null +++ b/extra/openssl/openssl.factor @@ -0,0 +1,151 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors +locals unicode.case +openssl.libcrypto openssl.libssl +io.nonblocking io.files io.encodings.ascii io.sockets.secure ; +IN: openssl + +! This code is based on http://www.rtfm.com/openssl-examples/ + +SINGLETON: openssl + +GENERIC: ssl-method ( symbol -- method ) + +M: SSLv2 ssl-method drop SSLv2_client_method ; +M: SSLv23 ssl-method drop SSLv23_method ; +M: SSLv3 ssl-method drop SSLv3_method ; +M: TLSv1 ssl-method drop TLSv1_method ; + +: (ssl-error) ( num -- * ) + ERR_get_error ERR_clear_error f ERR_error_string throw ; + +: ssl-error ( obj -- ) + { f 0 } member? [ (ssl-error) ] when ; + +: init-ssl ( -- ) + SSL_library_init ssl-error + SSL_load_error_strings + OpenSSL_add_all_digests + OpenSSL_add_all_ciphers ; + +SYMBOL: ssl-initiazed? + +: maybe-init-ssl ( -- ) + ssl-initiazed? get-global [ + init-ssl + t ssl-initiazed? set-global + ] unless ; + +[ f ssl-initiazed? set-global ] "openssl" add-init-hook + +TUPLE: openssl-context < ssl-context aliens ; + +: load-certificate-chain ( ctx -- ) + dup config>> key-file>> [ + [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + SSL_CTX_use_certificate_chain_file + ssl-error + ] [ drop ] if ; + +: password-callback ( -- alien ) + "int" { "void*" "int" "bool" "void*" } "cdecl" + [| buf size rwflag password! | + password [ B{ 0 } password! ] unless + + [let | len [ password strlen ] | + buf password len 1+ size min memcpy + len + ] + ] alien-callback ; + +: default-pasword ( ctx -- alien ) + [ config>> password>> malloc-byte-array ] [ aliens>> ] bi + [ push ] [ drop ] 2bi ; + +: set-default-password ( ctx -- ) + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi ; + +: use-private-key-file ( ctx -- ) + dup config>> key-file>> [ + [ handle>> ] [ config>> key-file>> (normalize-path) ] bi + SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file + ssl-error + ] [ drop ] if ; + +: load-verify-locations ( ctx -- ) + dup config>> [ ca-file>> ] [ ca-path>> ] bi or [ + [ handle>> ] + [ + config>> + [ ca-file>> dup [ (normalize-path) ] when ] + [ ca-path>> dup [ (normalize-path) ] when ] bi + ] bi + SSL_CTX_load_verify_locations ssl-error + ] [ drop ] if ; + +: set-verify-depth ( ctx -- ) + handle>> 1 SSL_CTX_set_verify_depth ; + +M: openssl ( config -- context ) + maybe-init-ssl + [ + dup method>> ssl-method SSL_CTX_new + dup ssl-error V{ } clone openssl-context boa + dup add-error-destructor + { + [ load-certificate-chain ] + [ set-default-password ] + [ use-private-key-file ] + [ load-verify-locations ] + [ set-verify-depth ] + [ ] + } cleave + ] with-destructors ; + +M: openssl-context dispose + dup aliens>> [ free ] each f >>aliens + dup handle>> [ SSL_CTX_free ] when* f >>handle + drop ; + +TUPLE: ssl file handle ; + +: ( file -- ssl ) + ssl-context get handle>> SSL_new dup ssl-error ssl boa ; + +M: ssl init-handle drop ; + +M: ssl close-handle + [ file>> close-handle ] [ handle>> SSL_free ] bi ; + +ERROR: certificate-verify-error result ; + +: check-verify-result ( ssl-handle -- ) + SSL_get_verify_result dup X509_V_OK = + [ certificate-verify-error ] [ drop ] if ; + +: common-name ( certificate -- host ) + X509_get_subject_name + NID_commonName 256 + [ 256 X509_NAME_get_text_by_NID ] keep + swap -1 = [ drop f ] [ ascii alien>string ] if ; + +ERROR: common-name-verify-error expected got ; + +: check-common-name ( host ssl-handle -- ) + SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ = + [ 2drop ] [ common-name-verify-error ] if ; + +: check-certificate ( host ssl -- ) + handle>> + [ nip check-verify-result ] + [ check-common-name ] + 2bi ; + +openssl ssl-backend set-global diff --git a/unmaintained/openssl/summary.txt b/extra/openssl/summary.txt similarity index 100% rename from unmaintained/openssl/summary.txt rename to extra/openssl/summary.txt diff --git a/unmaintained/openssl/tags.txt b/extra/openssl/tags.txt similarity index 100% rename from unmaintained/openssl/tags.txt rename to extra/openssl/tags.txt diff --git a/unmaintained/openssl/test/dh1024.pem b/extra/openssl/test/dh1024.pem similarity index 100% rename from unmaintained/openssl/test/dh1024.pem rename to extra/openssl/test/dh1024.pem diff --git a/unmaintained/openssl/test/errors.txt b/extra/openssl/test/errors.txt similarity index 100% rename from unmaintained/openssl/test/errors.txt rename to extra/openssl/test/errors.txt diff --git a/unmaintained/openssl/test/root.pem b/extra/openssl/test/root.pem similarity index 100% rename from unmaintained/openssl/test/root.pem rename to extra/openssl/test/root.pem diff --git a/unmaintained/openssl/test/server.pem b/extra/openssl/test/server.pem similarity index 100% rename from unmaintained/openssl/test/server.pem rename to extra/openssl/test/server.pem diff --git a/extra/openssl/unix/unix.factor b/extra/openssl/unix/unix.factor new file mode 100644 index 0000000000..d84a46e085 --- /dev/null +++ b/extra/openssl/unix/unix.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors +locals unicode.case +openssl.libcrypto openssl.libssl +io.files io.encodings.ascii io.sockets.secure ; +IN: openssl.unix + + diff --git a/unmaintained/openssl/openssl-tests.factor b/unmaintained/openssl/openssl-tests.factor deleted file mode 100755 index 2b840bdb9c..0000000000 --- a/unmaintained/openssl/openssl-tests.factor +++ /dev/null @@ -1,146 +0,0 @@ -USING: alien alien.c-types alien.strings assocs bit-arrays -hashtables io io.files io.encodings.ascii io.sockets kernel -mirrors openssl.libcrypto openssl.libssl namespaces math -math.parser openssl prettyprint sequences tools.test ; - -! ========================================================= -! Some crypto functions (still to be turned into words) -! ========================================================= - -[ - B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 } -] -[ "Hello world from the openssl binding" >md5 ] unit-test - -! Not found on netbsd, windows -- why? -! [ - ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 - ! 82 115 0 } -! ] -! [ "Hello world from the openssl binding" >sha1 ] unit-test - -! ========================================================= -! Initialize context -! ========================================================= - -[ ] [ init load-error-strings ] unit-test - -[ ] [ ssl-v23 new-ctx ] unit-test - -[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test - -! TODO: debug 'Memory protection fault at address 6c' -! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd - -[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test - -! Enter PEM pass phrase: password -[ ] [ get-ctx "resource:extra/openssl/test/server.pem" -SSL_FILETYPE_PEM use-private-key ] unit-test - -[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f -verify-load-locations ] unit-test - -[ ] [ get-ctx 1 set-verify-depth ] unit-test - -! ========================================================= -! Load Diffie-Hellman parameters -! ========================================================= - -[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test - -[ ] [ get-bio f f f read-pem-dh-params ] unit-test - -[ ] [ get-bio bio-free ] unit-test - -! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol' -[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test - -! Workaround (this function should never be called directly) -! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test - -! ========================================================= -! Generate ephemeral RSA key -! ========================================================= - -[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test - -! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol' -! get-ctx get-rsa set-tmp-rsa-callback - -! Workaround (this function should never be called directly) -[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test - -[ ] [ get-rsa free-rsa ] unit-test - -! ========================================================= -! Listen and accept on socket -! ========================================================= - -! SYMBOL: sock -! SYMBOL: fdset -! SYMBOL: acset -! SYMBOL: sbio -! SYMBOL: ssl -! -! : is-set ( seq -- newseq ) -! >alist [ nip ] assoc-filter >hashtable keys ; -! -! ! 1234 server-socket sock set -! "127.0.0.1" 1234 SOCK_STREAM server-fd sock set -! -! FD_SETSIZE 8 * fdset set -! -! FD_SETSIZE 8 * t 8 rot [ set-nth ] keep fdset set -! -! fdset get is-set . - -! : loop ( -- ) -! sock get f f accept -! dup -1 = [ drop ] [ -! dup number>string print flush -! ! BIO_NOCLOSE bio-new-socket sbio set -! [ get-ctx new-ssl ssl set ] keep -! ssl get swap set-ssl-fd -! ! ssl get sbio get dup set-ssl-bio -! ! ssl get ssl-accept -! ! dup 0 <= [ -! ! ssl get swap ssl-get-error -! ! ] [ drop ] if -! ] if -! loop ; - -! { } acset set -! -! : loop ( -- ) -! ! FD_SETSIZE fdset get f f f select . flush -! FD_SETSIZE fdset get f f 10000 make-timeval select -! 0 <= [ acset get [ close ] each "timeout" print ] [ -! fdset get is-set sock get swap member? [ -! sock get f f accept dup . flush -! acset get swap add acset set -! ] [ ] if -! loop -! ] if ; -! -! loop -! -! sock get close - -! ========================================================= -! Dump errors to file -! ========================================================= - -[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test - -[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test - -[ ] [ get-bio bio-free ] unit-test - -! ========================================================= -! Clean-up -! ========================================================= - -! sock get close - -get-ctx destroy-ctx diff --git a/unmaintained/openssl/openssl.factor b/unmaintained/openssl/openssl.factor deleted file mode 100755 index 9b23774598..0000000000 --- a/unmaintained/openssl/openssl.factor +++ /dev/null @@ -1,154 +0,0 @@ -! Copyright (C) 2007 Elie CHAFTARI -! See http://factorcode.org/license.txt for BSD license. -! -! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC - -USING: alien alien.c-types alien.strings assocs kernel libc -namespaces openssl.libcrypto openssl.libssl sequences -io.encodings.ascii ; - -IN: openssl - -SYMBOL: bio -SYMBOL: ssl-bio - -SYMBOL: ctx -SYMBOL: dh -SYMBOL: rsa - -! ========================================================= -! Callback routines -! ========================================================= - -: password-cb ( -- alien ) - "int" { "char*" "int" "int" "void*" } "cdecl" - [ 3drop "password" ascii string>alien 1023 memcpy - "password" length ] alien-callback ; - -! ========================================================= -! Error-handling routines -! ========================================================= - -: get-error ( -- num ) - ERR_get_error ; - -: error-string ( num -- str ) - f ERR_error_string ; - -: check-result ( result -- ) - 1 = [ ] [ - get-error error-string throw - ] if ; - -: ssl-get-error ( ssl ret -- ) - SSL_get_error error-messages at throw ; - -! Write errors to a file -: bio-new-file ( path mode -- ) - BIO_new_file bio set ; - -: bio-print ( bio str -- n ) - BIO_printf ; - -: bio-free ( bio -- ) - BIO_free check-result ; - -! ========================================================= -! Initialization routines -! ========================================================= - -: init ( -- ) - SSL_library_init drop ; ! always returns 1 - -: load-error-strings ( -- ) - SSL_load_error_strings ; - -: ssl-v23 ( -- method ) - SSLv23_method ; - -: new-ctx ( method -- ) - SSL_CTX_new ctx set ; - -: use-cert-chain ( ctx file -- ) - SSL_CTX_use_certificate_chain_file check-result ; - -: set-default-passwd ( ctx cb -- ) - SSL_CTX_set_default_passwd_cb ; - -: set-default-passwd-userdata ( ctx passwd -- ) - SSL_CTX_set_default_passwd_cb_userdata ; - -: use-private-key ( ctx file type -- ) - SSL_CTX_use_PrivateKey_file check-result ; - -: verify-load-locations ( ctx file path -- ) - SSL_CTX_load_verify_locations check-result ; - -: set-verify-depth ( ctx depth -- ) - SSL_CTX_set_verify_depth ; - -: read-pem-dh-params ( bio x cb u -- ) - PEM_read_bio_DHparams dh set ; - -: set-tmp-dh-callback ( ctx dh -- ) - SSL_CTX_set_tmp_dh_callback ; - -: set-ctx-ctrl ( ctx cmd larg parg -- ) - SSL_CTX_ctrl check-result ; - -: generate-rsa-key ( n e cb cbarg -- ) - RSA_generate_key rsa set ; - -: set-tmp-rsa-callback ( ctx rsa -- ) - SSL_CTX_set_tmp_rsa_callback ; - -: free-rsa ( rsa -- ) - RSA_free ; - -: bio-new-socket ( fd flag -- sbio ) - BIO_new_socket ; - -: new-ssl ( ctx -- ssl ) - SSL_new ; - -: set-ssl-bio ( ssl bio bio -- ) - SSL_set_bio ; - -: set-ssl-fd ( ssl fd -- ) - SSL_set_fd check-result ; - -: ssl-accept ( ssl -- result ) - SSL_accept ; - -! ========================================================= -! Clean-up and termination routines -! ========================================================= - -: destroy-ctx ( ctx -- ) - SSL_CTX_free ; - -! ========================================================= -! Public routines -! ========================================================= - -: get-bio ( -- bio ) - bio get ; - -: get-ssl-bio ( -- bio ) - ssl-bio get ; - -: get-ctx ( -- ctx ) - ctx get ; - -: get-dh ( -- dh ) - dh get ; - -: get-rsa ( -- rsa ) - rsa get ; - -: >md5 ( str -- byte-array ) - dup length 16 "uchar" [ MD5 ] keep nip ; - -: >sha1 ( str -- byte-array ) - dup length 20 "uchar" [ SHA1 ] keep nip ; - From f9db3f8b503cacb4b987bdda484871b205c0718f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:42:48 -0500 Subject: [PATCH 02/21] Documentation updates --- core/checksums/checksums-docs.factor | 5 ++++- core/kernel/kernel-docs.factor | 13 +++++++++++-- core/kernel/kernel.factor | 4 ++-- extra/checksums/adler-32/adler-32-docs.factor | 2 +- extra/checksums/md5/md5-docs.factor | 2 +- extra/checksums/sha1/sha1-docs.factor | 2 +- extra/checksums/sha2/sha2-docs.factor | 2 +- 7 files changed, 21 insertions(+), 9 deletions(-) diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index 9196008ba6..6ef0e85025 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -49,4 +49,7 @@ $nl { $vocab-subsection "MD5 checksum" "checksums.md5" } { $vocab-subsection "SHA1 checksum" "checksums.sha1" } { $vocab-subsection "SHA2 checksum" "checksums.sha2" } -{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ; +{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } +{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ; + +ABOUT: "checksums" diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 0ef8919713..d142255535 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -148,7 +148,7 @@ $nl { $subsection "spread-shuffle-equivalence" } ; ARTICLE: "apply-combinators" "Apply combinators" -"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application." +"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." $nl "Two quotations:" { $subsection bi@ } @@ -179,6 +179,7 @@ ARTICLE: "compositional-combinators" "Compositional combinators" { $subsection with } { $subsection compose } { $subsection 3compose } +{ $subsection prepose } "Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ; ARTICLE: "implementing-combinators" "Implementing combinators" @@ -835,8 +836,16 @@ HELP: compose ( quot1 quot2 -- compose ) "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations." } ; + +HELP: prepose +{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } } +{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." } +{ $notes "See " { $link compose } " for details." } ; + +{ compose prepose } related-words + HELP: 3compose -{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } } +{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } } { $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." } { $notes "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:" diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a72e25b9e0..a989d6c833 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -156,10 +156,10 @@ M: callstack clone (clone) ; : with ( param obj quot -- obj curry ) swapd [ swapd call ] 2curry ; inline -: prepose ( quot1 quot2 -- curry ) +: prepose ( quot1 quot2 -- compose ) swap compose ; inline -: 3compose ( quot1 quot2 quot3 -- curry ) +: 3compose ( quot1 quot2 quot3 -- compose ) compose compose ; inline ! Booleans diff --git a/extra/checksums/adler-32/adler-32-docs.factor b/extra/checksums/adler-32/adler-32-docs.factor index b7400cbaa0..3e4e5d8210 100755 --- a/extra/checksums/adler-32/adler-32-docs.factor +++ b/extra/checksums/adler-32/adler-32-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.adler-32 HELP: adler-32 -{ $description "Adler-32 checksum algorithm." } ; +{ $class-description "Adler-32 checksum algorithm." } ; ARTICLE: "checksums.adler-32" "Adler-32 checksum" "The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync." diff --git a/extra/checksums/md5/md5-docs.factor b/extra/checksums/md5/md5-docs.factor index dca039d1d3..4e475b18a0 100755 --- a/extra/checksums/md5/md5-docs.factor +++ b/extra/checksums/md5/md5-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.md5 HELP: md5 -{ $description "MD5 checksum algorithm." } ; +{ $class-description "MD5 checksum algorithm." } ; ARTICLE: "checksums.md5" "MD5 checksum" "The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")." diff --git a/extra/checksums/sha1/sha1-docs.factor b/extra/checksums/sha1/sha1-docs.factor index 8b8bf1cfa9..2c9093865f 100644 --- a/extra/checksums/sha1/sha1-docs.factor +++ b/extra/checksums/sha1/sha1-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.sha1 HELP: sha1 -{ $description "SHA1 checksum algorithm." } ; +{ $class-description "SHA1 checksum algorithm." } ; ARTICLE: "checksums.sha1" "SHA1 checksum" "The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")." diff --git a/extra/checksums/sha2/sha2-docs.factor b/extra/checksums/sha2/sha2-docs.factor index c39831b266..6a128552fd 100644 --- a/extra/checksums/sha2/sha2-docs.factor +++ b/extra/checksums/sha2/sha2-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: checksums.sha2 HELP: sha-256 -{ $description "SHA-256 checksum algorithm." } ; +{ $class-description "SHA-256 checksum algorithm." } ; ARTICLE: "checksums.sha2" "SHA2 checksum" "The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong." From 7f725dfa6d75e8627820cd11f2b2b4c412795218 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:43:11 -0500 Subject: [PATCH 03/21] Fix stack effect of (exists?) --- core/inference/known-words/known-words.factor | 2 +- core/io/files/files-tests.factor | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index ff5fc478ca..2d45ce0d0c 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -356,7 +356,7 @@ M: object infer-call \ setenv { object fixnum } { } set-primitive-effect -\ exists? { string } { object } set-primitive-effect +\ (exists?) { string } { object } set-primitive-effect \ (directory) { string } { array } set-primitive-effect diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 2c9d883695..20eb662fc7 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -3,6 +3,9 @@ USING: tools.test io.files io.files.private io threads kernel continuations io.encodings.ascii io.files.unique sequences strings accessors io.encodings.utf8 math ; +\ exists? must-infer +\ (exists?) must-infer + [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test [ t ] [ "blahblah" temp-file directory? ] unit-test From d682d572e2df301fc81f16d48cffedbb62413966 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:43:17 -0500 Subject: [PATCH 04/21] Add read-partial word --- core/io/io.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/io/io.factor b/core/io/io.factor index 6bad8331db..522e767f98 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -39,6 +39,7 @@ SYMBOL: error-stream : read1 ( -- ch/f ) input-stream get stream-read1 ; : read ( n -- str/f ) input-stream get stream-read ; : read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ; +: read-partial ( n -- str/f ) input-stream get stream-read-partial ; : write1 ( ch -- ) output-stream get stream-write1 ; : write ( str -- ) output-stream get stream-write ; From b7597fbd8a4dcf5e69c2f94166300b4d84d037b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:43:34 -0500 Subject: [PATCH 05/21] add strlen --- core/libc/libc.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 756d29e551..70850a2894 100755 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -73,3 +73,6 @@ PRIVATE> : with-malloc ( size quot -- ) swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline + +: strlen ( alien -- len ) + "size_t" "libc" "strlen" { "char*" } alien-invoke ; From 8a0db8eda980d5085c46e84464a2f0d60796c2bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:43:45 -0500 Subject: [PATCH 06/21] OpenSSL checksums --- extra/checksums/openssl/openssl-docs.factor | 35 +++++++++++ extra/checksums/openssl/openssl-tests.factor | 28 +++++++++ extra/checksums/openssl/openssl.factor | 63 ++++++++++++++++++++ 3 files changed, 126 insertions(+) create mode 100644 extra/checksums/openssl/openssl-docs.factor create mode 100644 extra/checksums/openssl/openssl-tests.factor create mode 100644 extra/checksums/openssl/openssl.factor diff --git a/extra/checksums/openssl/openssl-docs.factor b/extra/checksums/openssl/openssl-docs.factor new file mode 100644 index 0000000000..fd067997a7 --- /dev/null +++ b/extra/checksums/openssl/openssl-docs.factor @@ -0,0 +1,35 @@ +IN: checksums.openssl +USING: help.syntax help.markup ; + +HELP: openssl-checksum +{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ; + +HELP: ( name -- checksum ) +{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } } +{ $description "Creates a new OpenSSL checksum object." } ; + +HELP: openssl-md5 +{ $description "The OpenSSL MD5 message digest implementation." } ; + +HELP: openssl-sha1 +{ $description "The OpenSSL SHA1 message digest implementation." } ; + +HELP: unknown-digest +{ $error-description "Thrown by checksum words if they are passed an " { $link openssl-checksum } " naming a message digest not supported by OpenSSL." } ; + +ARTICLE: "checksums.openssl" "OpenSSL checksums" +"The OpenSSL library provides a large number of efficient checksum (message digest) algorithms which may be used independently of its SSL functionality." +{ $subsection openssl-checksum } +"Constructing a checksum from a known name:" +{ $subsection } +"Two utility words:" +{ $subsection openssl-md5 } +{ $subsection openssl-sha1 } +"An error thrown if the digest name is unrecognized:" +{ $subsection unknown-digest } +"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:" +{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } +"If we use the Factor implementation, we get the same result, just slightly slower:" +{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ; + +ABOUT: "checksums.openssl" diff --git a/extra/checksums/openssl/openssl-tests.factor b/extra/checksums/openssl/openssl-tests.factor new file mode 100644 index 0000000000..253069c952 --- /dev/null +++ b/extra/checksums/openssl/openssl-tests.factor @@ -0,0 +1,28 @@ +IN: checksums.openssl.tests +USING: byte-arrays checksums.openssl checksums tools.test +accessors kernel system ; + +[ + B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 } +] +[ + "Hello world from the openssl binding" >byte-array + "md5" checksum-bytes +] unit-test + +[ + B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 82 115 0 } +] +[ + "Hello world from the openssl binding" >byte-array + "sha1" checksum-bytes +] unit-test + +[ + "Bad checksum test" >byte-array + "no such checksum" + checksum-bytes +] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ] +must-fail-with + +[ ] [ image openssl-sha1 checksum-file drop ] unit-test diff --git a/extra/checksums/openssl/openssl.factor b/extra/checksums/openssl/openssl.factor new file mode 100644 index 0000000000..fe96a52277 --- /dev/null +++ b/extra/checksums/openssl/openssl.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays alien.c-types kernel continuations +sequences io openssl openssl.libcrypto checksums ; +IN: checksums.openssl + +ERROR: unknown-digest name ; + +TUPLE: openssl-checksum name ; + +: openssl-md5 T{ openssl-checksum f "md5" } ; + +: openssl-sha1 T{ openssl-checksum f "sha1" } ; + +INSTANCE: openssl-checksum checksum + +C: openssl-checksum + + ( -- ctx ) + "EVP_MD_CTX" + dup EVP_MD_CTX_init evp-md-context boa ; + +M: evp-md-context dispose + handle>> EVP_MD_CTX_cleanup drop ; + +: with-evp-md-context ( quot -- ) + maybe-init-ssl >r r> with-disposal ; inline + +: digest-named ( name -- md ) + dup EVP_get_digestbyname + [ ] [ unknown-digest ] ?if ; + +: set-digest ( name ctx -- ) + handle>> swap digest-named f EVP_DigestInit_ex ssl-error ; + +: checksum-loop ( ctx -- ) + dup handle>> + 4096 read-partial dup [ + dup length EVP_DigestUpdate ssl-error + checksum-loop + ] [ 3drop ] if ; + +: digest-value ( ctx -- value ) + handle>> + EVP_MAX_MD_SIZE 0 + [ EVP_DigestFinal_ex ssl-error ] 2keep + *int memory>byte-array ; + +PRIVATE> + +M: openssl-checksum checksum-stream + name>> swap [ + [ + [ set-digest ] + [ checksum-loop ] + [ digest-value ] + tri + ] with-evp-md-context + ] with-input-stream ; From c59e17d4836e07978a8087f5838742d3256614e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:44:14 -0500 Subject: [PATCH 07/21] Working on OpenSSL sockets --- extra/io/sockets/secure/secure-tests.factor | 5 +++++ extra/io/sockets/secure/secure.factor | 24 +++++++++++++++++++++ extra/openssl/openssl-docs.factor | 10 --------- 3 files changed, 29 insertions(+), 10 deletions(-) create mode 100644 extra/io/sockets/secure/secure-tests.factor create mode 100644 extra/io/sockets/secure/secure.factor delete mode 100644 extra/openssl/openssl-docs.factor diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor new file mode 100644 index 0000000000..a2287c28f7 --- /dev/null +++ b/extra/io/sockets/secure/secure-tests.factor @@ -0,0 +1,5 @@ +IN: io.sockets.secure.tests +USING: io.sockets.secure tools.test ; + +\ must-infer +{ 1 0 } [ [ ] with-ssl-context ] must-infer-as diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor new file mode 100644 index 0000000000..f7729233ac --- /dev/null +++ b/extra/io/sockets/secure/secure.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel symbols namespaces continuations ; +IN: io.sockets.secure + +SYMBOL: ssl-backend + +SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ; + +TUPLE: ssl-config method key-file ca-file ca-path password ; + +: ( -- config ) + ssl-config new + SSLv23 >>method ; + +TUPLE: ssl-context config handle ; + +HOOK: ssl-backend ( config -- context ) + +: with-ssl-context ( config quot -- ) + [ + [ ] [ [ ssl-context set ] prepose ] bi* + with-disposal + ] with-scope ; inline diff --git a/extra/openssl/openssl-docs.factor b/extra/openssl/openssl-docs.factor deleted file mode 100644 index dd31bfd001..0000000000 --- a/extra/openssl/openssl-docs.factor +++ /dev/null @@ -1,10 +0,0 @@ - -USING: help.syntax help.markup ; - -IN: openssl - -ARTICLE: "openssl" "OpenSSL" - -"Factor on Windows has been tested with this version of OpenSSL: " - -{ $url "http://www.openssl.org/related/binaries.html" } ; \ No newline at end of file From 18fe2d0047bf69c11a661660358f96e12d1336c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:44:39 -0500 Subject: [PATCH 08/21] Preparing io.nonblocking for SSL --- extra/io/nonblocking/nonblocking.factor | 8 ++++---- extra/io/unix/backend/backend.factor | 4 ++-- extra/io/windows/nt/files/files.factor | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index d25d4b7050..40605347b1 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -57,7 +57,7 @@ M: object cancel-io drop ; M: port timed-out cancel-io ; -GENERIC: (wait-to-read) ( port -- ) +HOOK: (wait-to-read) io-backend ( port -- ) : wait-to-read ( count port -- ) tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ; @@ -126,16 +126,16 @@ M: output-port stream-write [ buffer>> >buffer ] 2bi ] if ; -GENERIC: port-flush ( port -- ) +HOOK: flush-port io-backend ( port -- ) M: output-port stream-flush ( port -- ) check-closed - [ port-flush ] [ pending-error ] bi ; + [ flush-port ] [ pending-error ] bi ; GENERIC: close-port ( port -- ) M: output-port close-port - [ port-flush ] [ call-next-method ] bi ; + [ flush-port ] [ call-next-method ] bi ; M: port close-port dup cancel-io diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 902af8fe0d..6e738dc3e8 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -148,7 +148,7 @@ M: read-task do-io-task io-task-port dup refill [ [ reader-eof ] [ drop ] if ] keep ; -M: input-port (wait-to-read) +M: unix (wait-to-read) [ add-io-task ] with-port-continuation pending-error ; @@ -179,7 +179,7 @@ M: write-task do-io-task : (wait-to-write) ( port -- ) [ add-write-io-task ] with-port-continuation drop ; -M: output-port port-flush ( port -- ) +M: unix flush-port ( port -- ) dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: unix io-multiplex ( ms/f -- ) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 8839410d91..12fad1a2d0 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -85,7 +85,7 @@ M: winnt open-append : flush-output ( port -- ) [ [ (flush-output) ] with-timeout ] with-destructors ; -M: port port-flush +M: winnt flush-port dup buffer>> buffer-empty? [ dup flush-output ] unless drop ; : finish-read ( overlapped port -- ) @@ -106,5 +106,5 @@ M: port port-flush finish-read ] [ 2drop ] if ; -M: input-port (wait-to-read) ( port -- ) +M: winnt (wait-to-read) ( port -- ) [ [ ((wait-to-read)) ] with-timeout ] with-destructors ; From 8e3527f10b633d0722cbb86dcbd3f9a01bd62e2b Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 May 2008 19:38:22 -0400 Subject: [PATCH 09/21] Fixing tests for lisp --- extra/lisp/lisp-tests.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor index ec376569f0..f2c1f59678 100644 --- a/extra/lisp/lisp-tests.factor +++ b/extra/lisp/lisp-tests.factor @@ -4,10 +4,6 @@ USING: lisp lisp.parser tools.test sequences math kernel ; IN: lisp.test -{ [ "aoeu" 2 1 T{ lisp-symbol f "foo" } ] } [ - "(foo 1 2 \"aoeu\")" lisp-string>factor -] unit-test - init-env "+" [ first2 + ] lisp-define From 89e6869da10a1dbbca5bfc6e880330e4a337aa41 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 May 2008 19:38:38 -0400 Subject: [PATCH 10/21] Cleaning up lisp --- extra/lisp/lisp.factor | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 7d4b9af02a..48b66418cd 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -38,15 +38,18 @@ DEFER: funcall PRIVATE> : split-lambda ( s-exp -- body vars ) - first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline + first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline -: rest-lambda-vars ( seq -- n newseq ) - "&rest" swap [ remove ] [ index ] 2bi ; +: rest-lambda ( body vars -- quot ) + "&rest" swap [ remove ] [ index ] 2bi + [ localize-lambda ] dip + [ , cut swap [ % , ] bake , with-locals compose ] bake ; + +: normal-lambda ( body vars -- quot ) + localize-lambda [ , with-locals compose ] bake ; : convert-lambda ( s-exp -- quot ) - split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if - [ localize-lambda ] dip - [ , cut [ dup length firstn ] dip dup empty? [ drop ] when , ] bake ; + split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; : convert-quoted ( s-exp -- quot ) second [ , ] bake ; @@ -64,10 +67,9 @@ PRIVATE> [ drop convert-general-form ] if ; : convert-form ( lisp-form -- quot ) - { { [ dup s-exp? ] [ body>> convert-list-form ] } - [ [ , ] [ ] make ] - } cond ; - + dup s-exp? [ body>> convert-list-form ] + [ [ , ] [ ] make ] if ; + : lisp-string>factor ( str -- quot ) lisp-expr parse-result-ast convert-form ; From f88a02b5c1f0c246e70f8053af11e332abf80739 Mon Sep 17 00:00:00 2001 From: James Cash Date: Sun, 11 May 2008 20:03:36 -0400 Subject: [PATCH 11/21] Don't need with-locals anymore, removing --- extra/lisp/lisp.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 48b66418cd..79071ce619 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -43,10 +43,10 @@ PRIVATE> : rest-lambda ( body vars -- quot ) "&rest" swap [ remove ] [ index ] 2bi [ localize-lambda ] dip - [ , cut swap [ % , ] bake , with-locals compose ] bake ; + [ , cut swap [ % , ] bake , compose ] bake ; : normal-lambda ( body vars -- quot ) - localize-lambda [ , with-locals compose ] bake ; + localize-lambda [ , compose ] bake ; : convert-lambda ( s-exp -- quot ) split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ; From 866d23ff03226c4c7e314f1c4fc6a56724c578d5 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 12 May 2008 10:34:51 +1000 Subject: [PATCH 12/21] jamshred: fix failing unit test --- extra/jamshred/tunnel/tunnel-tests.factor | 5 +++-- extra/jamshred/tunnel/tunnel.factor | 8 ++++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index c6755318e6..903ff94739 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; +USING: arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ; IN: jamshred.tunnel.tests [ 0 ] [ T{ segment f { 0 0 0 } f f f 0 } @@ -41,4 +41,5 @@ IN: jamshred.tunnel.tests [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test -[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test +[ { 0 1 0 } ] +[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index f3fa9a0354..5cf1e33e64 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -126,10 +126,14 @@ C: segment : sideways-relative-location ( oint segment -- loc ) [ [ location>> ] bi@ v- ] keep forward>> proj-perp ; +: bounce-offset 0.1 ; inline + +: bounce-radius ( segment -- r ) + radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?) + : collision-vector ( oint segment -- v ) [ sideways-heading ] [ sideways-relative-location ] - [ radius>> 0.1 - ] ! bounce before we hit so that we can't see through the wall (hack?) - 2tri + [ bounce-radius ] 2tri swap [ collision-coefficient ] dip forward>> n*v ; : distance-to-collision ( oint segment -- distance ) From dcd07575d0ff90d63eb374657c994af4bf1e5e18 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 11 May 2008 20:41:32 -0700 Subject: [PATCH 13/21] rearranged cairo: binding in cairo.ffi, high-level words in extra/cairo. --- extra/cairo/cairo-tests.factor | 7 - extra/cairo/cairo.factor | 996 +---------------------------- extra/cairo/ffi/ffi.factor | 1100 +++++++++++++++++++++++--------- extra/cairo/lib/lib.factor | 36 -- 4 files changed, 836 insertions(+), 1303 deletions(-) delete mode 100644 extra/cairo/cairo-tests.factor mode change 100644 => 100755 extra/cairo/cairo.factor delete mode 100755 extra/cairo/lib/lib.factor diff --git a/extra/cairo/cairo-tests.factor b/extra/cairo/cairo-tests.factor deleted file mode 100644 index 8e0d83d092..0000000000 --- a/extra/cairo/cairo-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -USING: cairo math.parser kernel sequences tools.test ; -IN: cairo.tests - -[ t ] [ ! apply a little pressure to cairo_version - cairo_version number>string CHAR: 0 swap remove - CHAR: . cairo_version_string remove = -] unit-test \ No newline at end of file diff --git a/extra/cairo/cairo.factor b/extra/cairo/cairo.factor old mode 100644 new mode 100755 index b82191f72c..c9700e82c0 --- a/extra/cairo/cairo.factor +++ b/extra/cairo/cairo.factor @@ -1,968 +1,36 @@ -! Copyright (c) 2007 Sampo Vuori -! Copyright (c) 2008 Matthew Willis -! -! Adapted from cairo.h, version 1.5.14 -! License: http://factorcode.org/license.txt - -USING: system combinators alien alien.syntax kernel -alien.c-types accessors sequences arrays ui.gadgets ; - -IN: cairo -<< "cairo" { - { [ os winnt? ] [ "libcairo-2.dll" ] } - { [ os macosx? ] [ "libcairo.dylib" ] } - { [ os unix? ] [ "libcairo.so.2" ] } -} cond "cdecl" add-library >> - -LIBRARY: cairo - -FUNCTION: int cairo_version ( ) ; -FUNCTION: char* cairo_version_string ( ) ; - -TYPEDEF: int cairo_bool_t - -! I am leaving these and other void* types as opaque structures -TYPEDEF: void* cairo_t -TYPEDEF: void* cairo_surface_t - -C-STRUCT: cairo_matrix_t - { "double" "xx" } - { "double" "yx" } - { "double" "xy" } - { "double" "yy" } - { "double" "x0" } - { "double" "y0" } ; - -TYPEDEF: void* cairo_pattern_t - -TYPEDEF: void* cairo_destroy_func_t -: cairo-destroy-func ( quot -- callback ) - >r "void" { "void*" } "cdecl" r> alien-callback ; inline - -! See cairo.h for details -C-STRUCT: cairo_user_data_key_t - { "int" "unused" } ; - -TYPEDEF: int cairo_status_t -C-ENUM: - CAIRO_STATUS_SUCCESS - CAIRO_STATUS_NO_MEMORY - CAIRO_STATUS_INVALID_RESTORE - CAIRO_STATUS_INVALID_POP_GROUP - CAIRO_STATUS_NO_CURRENT_POINT - CAIRO_STATUS_INVALID_MATRIX - CAIRO_STATUS_INVALID_STATUS - CAIRO_STATUS_NULL_POINTER - CAIRO_STATUS_INVALID_STRING - CAIRO_STATUS_INVALID_PATH_DATA - CAIRO_STATUS_READ_ERROR - CAIRO_STATUS_WRITE_ERROR - CAIRO_STATUS_SURFACE_FINISHED - CAIRO_STATUS_SURFACE_TYPE_MISMATCH - CAIRO_STATUS_PATTERN_TYPE_MISMATCH - CAIRO_STATUS_INVALID_CONTENT - CAIRO_STATUS_INVALID_FORMAT - CAIRO_STATUS_INVALID_VISUAL - CAIRO_STATUS_FILE_NOT_FOUND - CAIRO_STATUS_INVALID_DASH - CAIRO_STATUS_INVALID_DSC_COMMENT - CAIRO_STATUS_INVALID_INDEX - CAIRO_STATUS_CLIP_NOT_REPRESENTABLE - CAIRO_STATUS_TEMP_FILE_ERROR - CAIRO_STATUS_INVALID_STRIDE ; - -TYPEDEF: int cairo_content_t -: CAIRO_CONTENT_COLOR HEX: 1000 ; -: CAIRO_CONTENT_ALPHA HEX: 2000 ; -: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; - -TYPEDEF: void* cairo_write_func_t -: cairo-write-func ( quot -- callback ) - >r "cairo_status_t" { "void*" "uchar*" "int" } - "cdecl" r> alien-callback ; inline - -TYPEDEF: void* cairo_read_func_t -: cairo-read-func ( quot -- callback ) - >r "cairo_status_t" { "void*" "uchar*" "int" } - "cdecl" r> alien-callback ; inline - -! Functions for manipulating state objects -FUNCTION: cairo_t* -cairo_create ( cairo_surface_t* target ) ; - -FUNCTION: cairo_t* -cairo_reference ( cairo_t* cr ) ; - -FUNCTION: void -cairo_destroy ( cairo_t* cr ) ; - -FUNCTION: uint -cairo_get_reference_count ( cairo_t* cr ) ; - -FUNCTION: void* -cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ; - -FUNCTION: cairo_status_t -cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; - -FUNCTION: void -cairo_save ( cairo_t* cr ) ; - -FUNCTION: void -cairo_restore ( cairo_t* cr ) ; - -FUNCTION: void -cairo_push_group ( cairo_t* cr ) ; - -FUNCTION: void -cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ; - -FUNCTION: cairo_pattern_t* -cairo_pop_group ( cairo_t* cr ) ; - -FUNCTION: void -cairo_pop_group_to_source ( cairo_t* cr ) ; - -! Modify state -TYPEDEF: int cairo_operator_t -C-ENUM: - CAIRO_OPERATOR_CLEAR - - CAIRO_OPERATOR_SOURCE - CAIRO_OPERATOR_OVER - CAIRO_OPERATOR_IN - CAIRO_OPERATOR_OUT - CAIRO_OPERATOR_ATOP - - CAIRO_OPERATOR_DEST - CAIRO_OPERATOR_DEST_OVER - CAIRO_OPERATOR_DEST_IN - CAIRO_OPERATOR_DEST_OUT - CAIRO_OPERATOR_DEST_ATOP - - CAIRO_OPERATOR_XOR - CAIRO_OPERATOR_ADD - CAIRO_OPERATOR_SATURATE ; - -FUNCTION: void -cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ; - -FUNCTION: void -cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ; - -FUNCTION: void -cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ; - -FUNCTION: void -cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ; - -FUNCTION: void -cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ; - -FUNCTION: void -cairo_set_tolerance ( cairo_t* cr, double tolerance ) ; - -TYPEDEF: int cairo_antialias_t -C-ENUM: - CAIRO_ANTIALIAS_DEFAULT - CAIRO_ANTIALIAS_NONE - CAIRO_ANTIALIAS_GRAY - CAIRO_ANTIALIAS_SUBPIXEL ; - -FUNCTION: void -cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ; - -TYPEDEF: int cairo_fill_rule_t -C-ENUM: - CAIRO_FILL_RULE_WINDING - CAIRO_FILL_RULE_EVEN_ODD ; - -FUNCTION: void -cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ; - -FUNCTION: void -cairo_set_line_width ( cairo_t* cr, double width ) ; - -TYPEDEF: int cairo_line_cap_t -C-ENUM: - CAIRO_LINE_CAP_BUTT - CAIRO_LINE_CAP_ROUND - CAIRO_LINE_CAP_SQUARE ; - -FUNCTION: void -cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ; - -TYPEDEF: int cairo_line_join_t -C-ENUM: - CAIRO_LINE_JOIN_MITER - CAIRO_LINE_JOIN_ROUND - CAIRO_LINE_JOIN_BEVEL ; - -FUNCTION: void -cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ; - -FUNCTION: void -cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ; - -FUNCTION: void -cairo_set_miter_limit ( cairo_t* cr, double limit ) ; - -FUNCTION: void -cairo_translate ( cairo_t* cr, double tx, double ty ) ; - -FUNCTION: void -cairo_scale ( cairo_t* cr, double sx, double sy ) ; - -FUNCTION: void -cairo_rotate ( cairo_t* cr, double angle ) ; - -FUNCTION: void -cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_identity_matrix ( cairo_t* cr ) ; - -FUNCTION: void -cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ; - -FUNCTION: void -cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ; - -FUNCTION: void -cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ; - -FUNCTION: void -cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ; - -! Path creation functions -FUNCTION: void -cairo_new_path ( cairo_t* cr ) ; - -FUNCTION: void -cairo_move_to ( cairo_t* cr, double x, double y ) ; - -FUNCTION: void -cairo_new_sub_path ( cairo_t* cr ) ; - -FUNCTION: void -cairo_line_to ( cairo_t* cr, double x, double y ) ; - -FUNCTION: void -cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ; - -FUNCTION: void -cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ; - -FUNCTION: void -cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ; - -FUNCTION: void -cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ; - -FUNCTION: void -cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ; - -FUNCTION: void -cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ; - -FUNCTION: void -cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ; - -FUNCTION: void -cairo_close_path ( cairo_t* cr ) ; - -FUNCTION: void -cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; - -! Painting functions -FUNCTION: void -cairo_paint ( cairo_t* cr ) ; - -FUNCTION: void -cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ; - -FUNCTION: void -cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ; - -FUNCTION: void -cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ; - -FUNCTION: void -cairo_stroke ( cairo_t* cr ) ; - -FUNCTION: void -cairo_stroke_preserve ( cairo_t* cr ) ; - -FUNCTION: void -cairo_fill ( cairo_t* cr ) ; - -FUNCTION: void -cairo_fill_preserve ( cairo_t* cr ) ; - -FUNCTION: void -cairo_copy_page ( cairo_t* cr ) ; - -FUNCTION: void -cairo_show_page ( cairo_t* cr ) ; - -! Insideness testing -FUNCTION: cairo_bool_t -cairo_in_stroke ( cairo_t* cr, double x, double y ) ; - -FUNCTION: cairo_bool_t -cairo_in_fill ( cairo_t* cr, double x, double y ) ; - -! Rectangular extents -FUNCTION: void -cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; - -FUNCTION: void -cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; - -! Clipping -FUNCTION: void -cairo_reset_clip ( cairo_t* cr ) ; - -FUNCTION: void -cairo_clip ( cairo_t* cr ) ; - -FUNCTION: void -cairo_clip_preserve ( cairo_t* cr ) ; - -FUNCTION: void -cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; - -C-STRUCT: cairo_rectangle_t - { "double" "x" } - { "double" "y" } - { "double" "width" } - { "double" "height" } ; - -: ( x y width height -- cairo_rectangle_t ) - "cairo_rectangle_t" dup - { - [ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ] - [ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ] - } cleave ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: cairo kernel accessors sequences +namespaces fry continuations ; +IN: cairo.lib + +TUPLE: cairo-t alien ; +C: cairo-t +M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ; + +TUPLE: cairo-surface-t alien ; +C: cairo-surface-t +M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ; + +: check-cairo ( cairo_status_t -- ) + dup CAIRO_STATUS_SUCCESS = [ drop ] + [ cairo_status_to_string "Cairo error: " prepend throw ] if ; + +SYMBOL: cairo +: cr ( -- cairo ) cairo get ; + +: (with-cairo) ( cairo-t quot -- ) + >r alien>> cairo r> [ cr cairo_status check-cairo ] + compose with-variable ; inline -: rect>cairo ( rect -- cairo_rectangle_t ) - [ loc>> ] [ dim>> ] bi [ [ first ] [ second ] bi ] bi@ - ; +: with-cairo ( cairo quot -- ) + >r r> [ (with-cairo) ] curry with-disposal ; inline -: cairo>rect ( cairo_rectangle_t -- rect ) - { - [ cairo_rectangle_t-x ] [ cairo_rectangle_t-y ] - [ cairo_rectangle_t-width ] [ cairo_rectangle_t-height ] - } cleave - [ 2array ] 2bi@ ; - -C-STRUCT: cairo_rectangle_list_t - { "cairo_status_t" "status" } - { "cairo_rectangle_t*" "rectangles" } - { "int" "num_rectangles" } ; +: (with-surface) ( cairo-surface-t quot -- ) + >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline -FUNCTION: cairo_rectangle_list_t* -cairo_copy_clip_rectangle_list ( cairo_t* cr ) ; +: with-surface ( cairo_surface quot -- ) + >r r> [ (with-surface) ] curry with-disposal ; inline -FUNCTION: void -cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ; - -! Font/Text functions - -TYPEDEF: void* cairo_scaled_font_t - -TYPEDEF: void* cairo_font_face_t - -C-STRUCT: cairo_glyph_t - { "ulong" "index" } - { "double" "x" } - { "double" "y" } ; - -C-STRUCT: cairo_text_extents_t - { "double" "x_bearing" } - { "double" "y_bearing" } - { "double" "width" } - { "double" "height" } - { "double" "x_advance" } - { "double" "y_advance" } ; - -C-STRUCT: cairo_font_extents_t - { "double" "ascent" } - { "double" "descent" } - { "double" "height" } - { "double" "max_x_advance" } - { "double" "max_y_advance" } ; - -TYPEDEF: int cairo_font_slant_t -C-ENUM: - CAIRO_FONT_SLANT_NORMAL - CAIRO_FONT_SLANT_ITALIC - CAIRO_FONT_SLANT_OBLIQUE ; - -TYPEDEF: int cairo_font_weight_t -C-ENUM: - CAIRO_FONT_WEIGHT_NORMAL - CAIRO_FONT_WEIGHT_BOLD ; - -TYPEDEF: int cairo_subpixel_order_t -C-ENUM: - CAIRO_SUBPIXEL_ORDER_DEFAULT - CAIRO_SUBPIXEL_ORDER_RGB - CAIRO_SUBPIXEL_ORDER_BGR - CAIRO_SUBPIXEL_ORDER_VRGB - CAIRO_SUBPIXEL_ORDER_VBGR ; - -TYPEDEF: int cairo_hint_style_t -C-ENUM: - CAIRO_HINT_STYLE_DEFAULT - CAIRO_HINT_STYLE_NONE - CAIRO_HINT_STYLE_SLIGHT - CAIRO_HINT_STYLE_MEDIUM - CAIRO_HINT_STYLE_FULL ; - -TYPEDEF: int cairo_hint_metrics_t -C-ENUM: - CAIRO_HINT_METRICS_DEFAULT - CAIRO_HINT_METRICS_OFF - CAIRO_HINT_METRICS_ON ; - -TYPEDEF: void* cairo_font_options_t - -FUNCTION: cairo_font_options_t* -cairo_font_options_create ( ) ; - -FUNCTION: cairo_font_options_t* -cairo_font_options_copy ( cairo_font_options_t* original ) ; - -FUNCTION: void -cairo_font_options_destroy ( cairo_font_options_t* options ) ; - -FUNCTION: cairo_status_t -cairo_font_options_status ( cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ; - -FUNCTION: cairo_bool_t -cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ; - -FUNCTION: ulong -cairo_font_options_hash ( cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ; - -FUNCTION: cairo_antialias_t -cairo_font_options_get_antialias ( cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ; - -FUNCTION: cairo_subpixel_order_t -cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ; - -FUNCTION: cairo_hint_style_t -cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ; - -FUNCTION: cairo_hint_metrics_t -cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ; - -! This interface is for dealing with text as text, not caring about the -! font object inside the the cairo_t. - -FUNCTION: void -cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ; - -FUNCTION: void -cairo_set_font_size ( cairo_t* cr, double size ) ; - -FUNCTION: void -cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ; - -FUNCTION: cairo_font_face_t* -cairo_get_font_face ( cairo_t* cr ) ; - -FUNCTION: void -cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: cairo_scaled_font_t* -cairo_get_scaled_font ( cairo_t* cr ) ; - -FUNCTION: void -cairo_show_text ( cairo_t* cr, char* utf8 ) ; - -FUNCTION: void -cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; - -FUNCTION: void -cairo_text_path ( cairo_t* cr, char* utf8 ) ; - -FUNCTION: void -cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; - -FUNCTION: void -cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ; - -FUNCTION: void -cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; - -FUNCTION: void -cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ; - -! Generic identifier for a font style - -FUNCTION: cairo_font_face_t* -cairo_font_face_reference ( cairo_font_face_t* font_face ) ; - -FUNCTION: void -cairo_font_face_destroy ( cairo_font_face_t* font_face ) ; - -FUNCTION: uint -cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ; - -FUNCTION: cairo_status_t -cairo_font_face_status ( cairo_font_face_t* font_face ) ; - -TYPEDEF: int cairo_font_type_t -C-ENUM: - CAIRO_FONT_TYPE_TOY - CAIRO_FONT_TYPE_FT - CAIRO_FONT_TYPE_WIN32 - CAIRO_FONT_TYPE_QUARTZ ; - -FUNCTION: cairo_font_type_t -cairo_font_face_get_type ( cairo_font_face_t* font_face ) ; - -FUNCTION: void* -cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ; - -FUNCTION: cairo_status_t -cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; - -! Portable interface to general font features. - -FUNCTION: cairo_scaled_font_t* -cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ; - -FUNCTION: cairo_scaled_font_t* -cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: void -cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: uint -cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: cairo_status_t -cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: cairo_font_type_t -cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: void* -cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ; - -FUNCTION: cairo_status_t -cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; - -FUNCTION: void -cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ; - -FUNCTION: void -cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ; - -FUNCTION: void -cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; - -FUNCTION: cairo_font_face_t* -cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ; - -FUNCTION: void -cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ; - -FUNCTION: void -cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ; - -FUNCTION: void -cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ; - -! Query functions - -FUNCTION: cairo_operator_t -cairo_get_operator ( cairo_t* cr ) ; - -FUNCTION: cairo_pattern_t* -cairo_get_source ( cairo_t* cr ) ; - -FUNCTION: double -cairo_get_tolerance ( cairo_t* cr ) ; - -FUNCTION: cairo_antialias_t -cairo_get_antialias ( cairo_t* cr ) ; - -FUNCTION: cairo_bool_t -cairo_has_current_point ( cairo_t* cr ) ; - -FUNCTION: void -cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ; - -FUNCTION: cairo_fill_rule_t -cairo_get_fill_rule ( cairo_t* cr ) ; - -FUNCTION: double -cairo_get_line_width ( cairo_t* cr ) ; - -FUNCTION: cairo_line_cap_t -cairo_get_line_cap ( cairo_t* cr ) ; - -FUNCTION: cairo_line_join_t -cairo_get_line_join ( cairo_t* cr ) ; - -FUNCTION: double -cairo_get_miter_limit ( cairo_t* cr ) ; - -FUNCTION: int -cairo_get_dash_count ( cairo_t* cr ) ; - -FUNCTION: void -cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ; - -FUNCTION: void -cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; - -FUNCTION: cairo_surface_t* -cairo_get_target ( cairo_t* cr ) ; - -FUNCTION: cairo_surface_t* -cairo_get_group_target ( cairo_t* cr ) ; - -TYPEDEF: int cairo_path_data_type_t -C-ENUM: - CAIRO_PATH_MOVE_TO - CAIRO_PATH_LINE_TO - CAIRO_PATH_CURVE_TO - CAIRO_PATH_CLOSE_PATH ; - -! NEED TO DO UNION HERE -C-STRUCT: cairo_path_data_t-point - { "double" "x" } - { "double" "y" } ; - -C-STRUCT: cairo_path_data_t-header - { "cairo_path_data_type_t" "type" } - { "int" "length" } ; - -C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ; - -C-STRUCT: cairo_path_t - { "cairo_status_t" "status" } - { "cairo_path_data_t*" "data" } - { "int" "num_data" } ; - -FUNCTION: cairo_path_t* -cairo_copy_path ( cairo_t* cr ) ; - -FUNCTION: cairo_path_t* -cairo_copy_path_flat ( cairo_t* cr ) ; - -FUNCTION: void -cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ; - -FUNCTION: void -cairo_path_destroy ( cairo_path_t* path ) ; - -! Error status queries - -FUNCTION: cairo_status_t -cairo_status ( cairo_t* cr ) ; - -FUNCTION: char* -cairo_status_to_string ( cairo_status_t status ) ; - -! Surface manipulation - -FUNCTION: cairo_surface_t* -cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ; - -FUNCTION: cairo_surface_t* -cairo_surface_reference ( cairo_surface_t* surface ) ; - -FUNCTION: void -cairo_surface_finish ( cairo_surface_t* surface ) ; - -FUNCTION: void -cairo_surface_destroy ( cairo_surface_t* surface ) ; - -FUNCTION: uint -cairo_surface_get_reference_count ( cairo_surface_t* surface ) ; - -FUNCTION: cairo_status_t -cairo_surface_status ( cairo_surface_t* surface ) ; - -TYPEDEF: int cairo_surface_type_t -C-ENUM: - CAIRO_SURFACE_TYPE_IMAGE - CAIRO_SURFACE_TYPE_PDF - CAIRO_SURFACE_TYPE_PS - CAIRO_SURFACE_TYPE_XLIB - CAIRO_SURFACE_TYPE_XCB - CAIRO_SURFACE_TYPE_GLITZ - CAIRO_SURFACE_TYPE_QUARTZ - CAIRO_SURFACE_TYPE_WIN32 - CAIRO_SURFACE_TYPE_BEOS - CAIRO_SURFACE_TYPE_DIRECTFB - CAIRO_SURFACE_TYPE_SVG - CAIRO_SURFACE_TYPE_OS2 - CAIRO_SURFACE_TYPE_WIN32_PRINTING - CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ; - -FUNCTION: cairo_surface_type_t -cairo_surface_get_type ( cairo_surface_t* surface ) ; - -FUNCTION: cairo_content_t -cairo_surface_get_content ( cairo_surface_t* surface ) ; - -FUNCTION: cairo_status_t -cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ; - -FUNCTION: cairo_status_t -cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ; - -FUNCTION: void* -cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ; - -FUNCTION: cairo_status_t -cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; - -FUNCTION: void -cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ; - -FUNCTION: void -cairo_surface_flush ( cairo_surface_t* surface ) ; - -FUNCTION: void -cairo_surface_mark_dirty ( cairo_surface_t* surface ) ; - -FUNCTION: void -cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ; - -FUNCTION: void -cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ; - -FUNCTION: void -cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ; - -FUNCTION: void -cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ; - -FUNCTION: void -cairo_surface_copy_page ( cairo_surface_t* surface ) ; - -FUNCTION: void -cairo_surface_show_page ( cairo_surface_t* surface ) ; - -! Image-surface functions - -TYPEDEF: int cairo_format_t -C-ENUM: - CAIRO_FORMAT_ARGB32 - CAIRO_FORMAT_RGB24 - CAIRO_FORMAT_A8 - CAIRO_FORMAT_A1 - CAIRO_FORMAT_RGB16_565 ; - -FUNCTION: cairo_surface_t* -cairo_image_surface_create ( cairo_format_t format, int width, int height ) ; - -FUNCTION: int -cairo_format_stride_for_width ( cairo_format_t format, int width ) ; - -FUNCTION: cairo_surface_t* -cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ; - -FUNCTION: uchar* -cairo_image_surface_get_data ( cairo_surface_t* surface ) ; - -FUNCTION: cairo_format_t -cairo_image_surface_get_format ( cairo_surface_t* surface ) ; - -FUNCTION: int -cairo_image_surface_get_width ( cairo_surface_t* surface ) ; - -FUNCTION: int -cairo_image_surface_get_height ( cairo_surface_t* surface ) ; - -FUNCTION: int -cairo_image_surface_get_stride ( cairo_surface_t* surface ) ; - -FUNCTION: cairo_surface_t* -cairo_image_surface_create_from_png ( char* filename ) ; - -FUNCTION: cairo_surface_t* -cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ; - -! Pattern creation functions - -FUNCTION: cairo_pattern_t* -cairo_pattern_create_rgb ( double red, double green, double blue ) ; - -FUNCTION: cairo_pattern_t* -cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ; - -FUNCTION: cairo_pattern_t* -cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ; - -FUNCTION: cairo_pattern_t* -cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ; - -FUNCTION: cairo_pattern_t* -cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ; - -FUNCTION: cairo_pattern_t* -cairo_pattern_reference ( cairo_pattern_t* pattern ) ; - -FUNCTION: void -cairo_pattern_destroy ( cairo_pattern_t* pattern ) ; - -FUNCTION: uint -cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ; - -FUNCTION: cairo_status_t -cairo_pattern_status ( cairo_pattern_t* pattern ) ; - -FUNCTION: void* -cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ; - -FUNCTION: cairo_status_t -cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; - -TYPEDEF: int cairo_pattern_type_t -C-ENUM: - CAIRO_PATTERN_TYPE_SOLID - CAIRO_PATTERN_TYPE_SURFACE - CAIRO_PATTERN_TYPE_LINEAR - CAIRO_PATTERN_TYPE_RADIA ; - -FUNCTION: cairo_pattern_type_t -cairo_pattern_get_type ( cairo_pattern_t* pattern ) ; - -FUNCTION: void -cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ; - -FUNCTION: void -cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ; - -FUNCTION: void -cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ; - -TYPEDEF: int cairo_extend_t -C-ENUM: - CAIRO_EXTEND_NONE - CAIRO_EXTEND_REPEAT - CAIRO_EXTEND_REFLECT - CAIRO_EXTEND_PAD ; - -FUNCTION: void -cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ; - -FUNCTION: cairo_extend_t -cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ; - -TYPEDEF: int cairo_filter_t -C-ENUM: - CAIRO_FILTER_FAST - CAIRO_FILTER_GOOD - CAIRO_FILTER_BEST - CAIRO_FILTER_NEAREST - CAIRO_FILTER_BILINEAR - CAIRO_FILTER_GAUSSIAN ; - -FUNCTION: void -cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ; - -FUNCTION: cairo_filter_t -cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ; - -FUNCTION: cairo_status_t -cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ; - -FUNCTION: cairo_status_t -cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ; - -FUNCTION: cairo_status_t -cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ; - -FUNCTION: cairo_status_t -cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ; - -FUNCTION: cairo_status_t -cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ; - -FUNCTION: cairo_status_t -cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ; - -! Matrix functions - -FUNCTION: void -cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ; - -FUNCTION: void -cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ; - -FUNCTION: void -cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ; - -FUNCTION: void -cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ; - -FUNCTION: void -cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ; - -FUNCTION: void -cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ; - -FUNCTION: void -cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ; - -FUNCTION: cairo_status_t -cairo_matrix_invert ( cairo_matrix_t* matrix ) ; - -FUNCTION: void -cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ; - -FUNCTION: void -cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ; - -FUNCTION: void -cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ; - -! Functions to be used while debugging (not intended for use in production code) -FUNCTION: void -cairo_debug_reset_static_data ( ) ; +: with-cairo-from-surface ( cairo_surface quot -- ) + '[ cairo_create , with-cairo ] with-surface ; inline diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index 200c85c929..b82191f72c 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -1,24 +1,48 @@ -! Bindings for Cairo library -! Copyright (c) 2007 Sampo Vuori -! License: http://factorcode.org/license.txt +! Copyright (c) 2007 Sampo Vuori +! Copyright (c) 2008 Matthew Willis +! +! Adapted from cairo.h, version 1.5.14 +! License: http://factorcode.org/license.txt -! Unimplemented: -! - most of the font stuff -! - most of the matrix stuff -! - most of the query functions - -USING: alien alien.syntax combinators system ; -IN: cairo.ffi +USING: system combinators alien alien.syntax kernel +alien.c-types accessors sequences arrays ui.gadgets ; +IN: cairo << "cairo" { - { [ os winnt? ] [ "libcairo-2.dll" ] } - ! { [ os macosx? ] [ "libcairo.dylib" ] } - { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] } - { [ os unix? ] [ "libcairo.so.2" ] } - } cond "cdecl" add-library >> + { [ os winnt? ] [ "libcairo-2.dll" ] } + { [ os macosx? ] [ "libcairo.dylib" ] } + { [ os unix? ] [ "libcairo.so.2" ] } +} cond "cdecl" add-library >> LIBRARY: cairo +FUNCTION: int cairo_version ( ) ; +FUNCTION: char* cairo_version_string ( ) ; + +TYPEDEF: int cairo_bool_t + +! I am leaving these and other void* types as opaque structures +TYPEDEF: void* cairo_t +TYPEDEF: void* cairo_surface_t + +C-STRUCT: cairo_matrix_t + { "double" "xx" } + { "double" "yx" } + { "double" "xy" } + { "double" "yy" } + { "double" "x0" } + { "double" "y0" } ; + +TYPEDEF: void* cairo_pattern_t + +TYPEDEF: void* cairo_destroy_func_t +: cairo-destroy-func ( quot -- callback ) + >r "void" { "void*" } "cdecl" r> alien-callback ; inline + +! See cairo.h for details +C-STRUCT: cairo_user_data_key_t + { "int" "unused" } ; + TYPEDEF: int cairo_status_t C-ENUM: CAIRO_STATUS_SUCCESS @@ -44,137 +68,344 @@ C-ENUM: CAIRO_STATUS_INVALID_DSC_COMMENT CAIRO_STATUS_INVALID_INDEX CAIRO_STATUS_CLIP_NOT_REPRESENTABLE -; + CAIRO_STATUS_TEMP_FILE_ERROR + CAIRO_STATUS_INVALID_STRIDE ; TYPEDEF: int cairo_content_t -: CAIRO_CONTENT_COLOR HEX: 1000 ; -: CAIRO_CONTENT_ALPHA HEX: 2000 ; -: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; +: CAIRO_CONTENT_COLOR HEX: 1000 ; +: CAIRO_CONTENT_ALPHA HEX: 2000 ; +: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ; +TYPEDEF: void* cairo_write_func_t +: cairo-write-func ( quot -- callback ) + >r "cairo_status_t" { "void*" "uchar*" "int" } + "cdecl" r> alien-callback ; inline + +TYPEDEF: void* cairo_read_func_t +: cairo-read-func ( quot -- callback ) + >r "cairo_status_t" { "void*" "uchar*" "int" } + "cdecl" r> alien-callback ; inline + +! Functions for manipulating state objects +FUNCTION: cairo_t* +cairo_create ( cairo_surface_t* target ) ; + +FUNCTION: cairo_t* +cairo_reference ( cairo_t* cr ) ; + +FUNCTION: void +cairo_destroy ( cairo_t* cr ) ; + +FUNCTION: uint +cairo_get_reference_count ( cairo_t* cr ) ; + +FUNCTION: void* +cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ; + +FUNCTION: cairo_status_t +cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +FUNCTION: void +cairo_save ( cairo_t* cr ) ; + +FUNCTION: void +cairo_restore ( cairo_t* cr ) ; + +FUNCTION: void +cairo_push_group ( cairo_t* cr ) ; + +FUNCTION: void +cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ; + +FUNCTION: cairo_pattern_t* +cairo_pop_group ( cairo_t* cr ) ; + +FUNCTION: void +cairo_pop_group_to_source ( cairo_t* cr ) ; + +! Modify state TYPEDEF: int cairo_operator_t C-ENUM: CAIRO_OPERATOR_CLEAR + CAIRO_OPERATOR_SOURCE CAIRO_OPERATOR_OVER CAIRO_OPERATOR_IN CAIRO_OPERATOR_OUT CAIRO_OPERATOR_ATOP + CAIRO_OPERATOR_DEST CAIRO_OPERATOR_DEST_OVER CAIRO_OPERATOR_DEST_IN CAIRO_OPERATOR_DEST_OUT CAIRO_OPERATOR_DEST_ATOP + CAIRO_OPERATOR_XOR CAIRO_OPERATOR_ADD - CAIRO_OPERATOR_SATURATE -; + CAIRO_OPERATOR_SATURATE ; -TYPEDEF: int cairo_line_cap_t -C-ENUM: - CAIRO_LINE_CAP_BUTT - CAIRO_LINE_CAP_ROUND - CAIRO_LINE_CAP_SQUARE -; +FUNCTION: void +cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ; -TYPEDEF: int cair_line_join_t -C-ENUM: - CAIRO_LINE_JOIN_MITER - CAIRO_LINE_JOIN_ROUND - CAIRO_LINE_JOIN_BEVEL -; +FUNCTION: void +cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ; -TYPEDEF: int cairo_fill_rule_t -C-ENUM: - CAIRO_FILL_RULE_WINDING - CAIRO_FILL_RULE_EVEN_ODD -; +FUNCTION: void +cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ; -TYPEDEF: int cairo_font_slant_t -C-ENUM: - CAIRO_FONT_SLANT_NORMAL - CAIRO_FONT_SLANT_ITALIC - CAIRO_FONT_SLANT_OBLIQUE -; +FUNCTION: void +cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ; -TYPEDEF: int cairo_font_weight_t -C-ENUM: - CAIRO_FONT_WEIGHT_NORMAL - CAIRO_FONT_WEIGHT_BOLD -; +FUNCTION: void +cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ; -C-STRUCT: cairo_font_t - { "int" "refcount" } - { "uint" "scale" } ; - -C-STRUCT: cairo_rectangle_t - { "short" "x" } - { "short" "y" } - { "ushort" "width" } - { "ushort" "height" } ; - -C-STRUCT: cairo_clip_rec_t - { "cairo_rectangle_t" "rect" } - { "void*" "region" } - { "void*" "surface" } ; - -C-STRUCT: cairo_matrix_t - { "void*" "m" } ; - -C-STRUCT: cairo_gstate_t - { "uint" "operator" } - { "double" "tolerance" } - { "double" "line_width" } - { "uint" "line_cap" } - { "uint" "line_join" } - { "double" "miter_limit" } - { "uint" "fill_rule" } - { "void*" "dash" } - { "int" "num_dashes" } - { "double" "dash_offset" } - { "char*" "font_family " } - { "uint" "font_slant" } - { "uint" "font_weight" } - { "void*" "font" } - { "void*" "surface" } - { "void*" "pattern " } - { "double" "alpha" } - { "cairo_clip_rec_t" "clip" } - { "double" "pixels_per_inch" } - { "cairo_matrix_t" "font_matrix" } - { "cairo_matrix_t" "ctm" } - { "cairo_matrix_t" "ctm_inverse" } - { "void*" "path" } - { "void*" "pen_regular" } - { "void*" "next" } ; - -C-STRUCT: cairo_t - { "uint" "ref_count" } - { "cairo_gstate_t*" "gstate" } - { "uint" "status ! cairo_status_t" } ; - -C-STRUCT: cairo_matrix_t - { "double" "xx" } - { "double" "yx" } - { "double" "xy" } - { "double" "yy" } - { "double" "x0" } - { "double" "y0" } ; - -TYPEDEF: int cairo_format_t -C-ENUM: - CAIRO_FORMAT_ARGB32 - CAIRO_FORMAT_RGB24 - CAIRO_FORMAT_A8 - CAIRO_FORMAT_A1 -; +FUNCTION: void +cairo_set_tolerance ( cairo_t* cr, double tolerance ) ; TYPEDEF: int cairo_antialias_t C-ENUM: CAIRO_ANTIALIAS_DEFAULT CAIRO_ANTIALIAS_NONE CAIRO_ANTIALIAS_GRAY - CAIRO_ANTIALIAS_SUBPIXEL -; + CAIRO_ANTIALIAS_SUBPIXEL ; + +FUNCTION: void +cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ; + +TYPEDEF: int cairo_fill_rule_t +C-ENUM: + CAIRO_FILL_RULE_WINDING + CAIRO_FILL_RULE_EVEN_ODD ; + +FUNCTION: void +cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ; + +FUNCTION: void +cairo_set_line_width ( cairo_t* cr, double width ) ; + +TYPEDEF: int cairo_line_cap_t +C-ENUM: + CAIRO_LINE_CAP_BUTT + CAIRO_LINE_CAP_ROUND + CAIRO_LINE_CAP_SQUARE ; + +FUNCTION: void +cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ; + +TYPEDEF: int cairo_line_join_t +C-ENUM: + CAIRO_LINE_JOIN_MITER + CAIRO_LINE_JOIN_ROUND + CAIRO_LINE_JOIN_BEVEL ; + +FUNCTION: void +cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ; + +FUNCTION: void +cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ; + +FUNCTION: void +cairo_set_miter_limit ( cairo_t* cr, double limit ) ; + +FUNCTION: void +cairo_translate ( cairo_t* cr, double tx, double ty ) ; + +FUNCTION: void +cairo_scale ( cairo_t* cr, double sx, double sy ) ; + +FUNCTION: void +cairo_rotate ( cairo_t* cr, double angle ) ; + +FUNCTION: void +cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_identity_matrix ( cairo_t* cr ) ; + +FUNCTION: void +cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ; + +FUNCTION: void +cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ; + +FUNCTION: void +cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ; + +FUNCTION: void +cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ; + +! Path creation functions +FUNCTION: void +cairo_new_path ( cairo_t* cr ) ; + +FUNCTION: void +cairo_move_to ( cairo_t* cr, double x, double y ) ; + +FUNCTION: void +cairo_new_sub_path ( cairo_t* cr ) ; + +FUNCTION: void +cairo_line_to ( cairo_t* cr, double x, double y ) ; + +FUNCTION: void +cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ; + +FUNCTION: void +cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ; + +FUNCTION: void +cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ; + +FUNCTION: void +cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ; + +FUNCTION: void +cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ; + +FUNCTION: void +cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ; + +FUNCTION: void +cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ; + +FUNCTION: void +cairo_close_path ( cairo_t* cr ) ; + +FUNCTION: void +cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +! Painting functions +FUNCTION: void +cairo_paint ( cairo_t* cr ) ; + +FUNCTION: void +cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ; + +FUNCTION: void +cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ; + +FUNCTION: void +cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ; + +FUNCTION: void +cairo_stroke ( cairo_t* cr ) ; + +FUNCTION: void +cairo_stroke_preserve ( cairo_t* cr ) ; + +FUNCTION: void +cairo_fill ( cairo_t* cr ) ; + +FUNCTION: void +cairo_fill_preserve ( cairo_t* cr ) ; + +FUNCTION: void +cairo_copy_page ( cairo_t* cr ) ; + +FUNCTION: void +cairo_show_page ( cairo_t* cr ) ; + +! Insideness testing +FUNCTION: cairo_bool_t +cairo_in_stroke ( cairo_t* cr, double x, double y ) ; + +FUNCTION: cairo_bool_t +cairo_in_fill ( cairo_t* cr, double x, double y ) ; + +! Rectangular extents +FUNCTION: void +cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +FUNCTION: void +cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +! Clipping +FUNCTION: void +cairo_reset_clip ( cairo_t* cr ) ; + +FUNCTION: void +cairo_clip ( cairo_t* cr ) ; + +FUNCTION: void +cairo_clip_preserve ( cairo_t* cr ) ; + +FUNCTION: void +cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; + +C-STRUCT: cairo_rectangle_t + { "double" "x" } + { "double" "y" } + { "double" "width" } + { "double" "height" } ; + +: ( x y width height -- cairo_rectangle_t ) + "cairo_rectangle_t" dup + { + [ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ] + [ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ] + } cleave ; + +: rect>cairo ( rect -- cairo_rectangle_t ) + [ loc>> ] [ dim>> ] bi [ [ first ] [ second ] bi ] bi@ + ; + +: cairo>rect ( cairo_rectangle_t -- rect ) + { + [ cairo_rectangle_t-x ] [ cairo_rectangle_t-y ] + [ cairo_rectangle_t-width ] [ cairo_rectangle_t-height ] + } cleave + [ 2array ] 2bi@ ; + +C-STRUCT: cairo_rectangle_list_t + { "cairo_status_t" "status" } + { "cairo_rectangle_t*" "rectangles" } + { "int" "num_rectangles" } ; + +FUNCTION: cairo_rectangle_list_t* +cairo_copy_clip_rectangle_list ( cairo_t* cr ) ; + +FUNCTION: void +cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ; + +! Font/Text functions + +TYPEDEF: void* cairo_scaled_font_t + +TYPEDEF: void* cairo_font_face_t + +C-STRUCT: cairo_glyph_t + { "ulong" "index" } + { "double" "x" } + { "double" "y" } ; + +C-STRUCT: cairo_text_extents_t + { "double" "x_bearing" } + { "double" "y_bearing" } + { "double" "width" } + { "double" "height" } + { "double" "x_advance" } + { "double" "y_advance" } ; + +C-STRUCT: cairo_font_extents_t + { "double" "ascent" } + { "double" "descent" } + { "double" "height" } + { "double" "max_x_advance" } + { "double" "max_y_advance" } ; + +TYPEDEF: int cairo_font_slant_t +C-ENUM: + CAIRO_FONT_SLANT_NORMAL + CAIRO_FONT_SLANT_ITALIC + CAIRO_FONT_SLANT_OBLIQUE ; + +TYPEDEF: int cairo_font_weight_t +C-ENUM: + CAIRO_FONT_WEIGHT_NORMAL + CAIRO_FONT_WEIGHT_BOLD ; TYPEDEF: int cairo_subpixel_order_t C-ENUM: @@ -182,8 +413,7 @@ C-ENUM: CAIRO_SUBPIXEL_ORDER_RGB CAIRO_SUBPIXEL_ORDER_BGR CAIRO_SUBPIXEL_ORDER_VRGB - CAIRO_SUBPIXEL_ORDER_VBGR -; + CAIRO_SUBPIXEL_ORDER_VBGR ; TYPEDEF: int cairo_hint_style_t C-ENUM: @@ -191,270 +421,548 @@ C-ENUM: CAIRO_HINT_STYLE_NONE CAIRO_HINT_STYLE_SLIGHT CAIRO_HINT_STYLE_MEDIUM - CAIRO_HINT_STYLE_FULL -; + CAIRO_HINT_STYLE_FULL ; TYPEDEF: int cairo_hint_metrics_t C-ENUM: CAIRO_HINT_METRICS_DEFAULT CAIRO_HINT_METRICS_OFF - CAIRO_HINT_METRICS_ON -; + CAIRO_HINT_METRICS_ON ; -FUNCTION: char* cairo_status_to_string ( cairo_status_t status ) ; -FUNCTION: cairo_status_t cairo_status ( cairo_t* cr ) ; +TYPEDEF: void* cairo_font_options_t -: cairo_create ( cairo_surface_t -- cairo_t ) - "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ; +FUNCTION: cairo_font_options_t* +cairo_font_options_create ( ) ; -: cairo_reference ( cairo_t -- cairo_t ) - "cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_font_options_t* +cairo_font_options_copy ( cairo_font_options_t* original ) ; -: cairo_destroy ( cairo_t -- ) - "void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_font_options_destroy ( cairo_font_options_t* options ) ; -: cairo_save ( cairo_t -- ) - "void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_font_options_status ( cairo_font_options_t* options ) ; -: cairo_restore ( cairo_t -- ) - "void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ; -: cairo_set_operator ( cairo_t cairo_operator_t -- ) - "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: cairo_bool_t +cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ; -: cairo_set_source ( cairo_t cairo_pattern_t -- ) - "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ; +FUNCTION: ulong +cairo_font_options_hash ( cairo_font_options_t* options ) ; -: cairo_set_source_rgb ( cairo_t red green blue -- ) - "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ; -: cairo_set_source_rgba ( cairo_t red green blue alpha -- ) - "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: cairo_antialias_t +cairo_font_options_get_antialias ( cairo_font_options_t* options ) ; -: cairo_set_source_surface ( cairo_t cairo_surface_t x y -- ) - "void" "cairo" "cairo_set_source_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ; -: cairo_set_tolerance ( cairo_t tolerance -- ) - "void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: cairo_subpixel_order_t +cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ; -: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t ) - "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ; - +FUNCTION: void +cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ; -: cairo_set_antialias ( cairo_t cairo_antialias_t -- ) - "void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: cairo_hint_style_t +cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ; -: cairo_set_fill_rule ( cairo_t cairo_fill_rule_t -- ) - "void" "cairo" "cairo_set_fill_rule" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: void +cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ; -: cairo_set_line_width ( cairo_t width -- ) - "void" "cairo" "cairo_set_line_width" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: cairo_hint_metrics_t +cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ; -: cairo_set_line_cap ( cairo_t cairo_line_cap_t -- ) - "void" "cairo" "cairo_set_line_cap" [ "cairo_t*" "int" ] alien-invoke ; +! This interface is for dealing with text as text, not caring about the +! font object inside the the cairo_t. -: cairo_set_line_join ( cairo_t cairo_line_join_t -- ) - "void" "cairo" "cairo_set_line_join" [ "cairo_t*" "int" ] alien-invoke ; +FUNCTION: void +cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ; -: cairo_set_dash ( cairo_t dashes num_dashes offset -- ) - "void" "cairo" "cairo_set_dash" [ "cairo_t*" "double" "int" "double" ] alien-invoke ; +FUNCTION: void +cairo_set_font_size ( cairo_t* cr, double size ) ; -: cairo_set_miter_limit ( cairo_t limit -- ) - "void" "cairo" "cairo_set_miter_limit" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: void +cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; -: cairo_translate ( cairo_t x y -- ) - "void" "cairo" "cairo_translate" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; -: cairo_scale ( cairo_t sx sy -- ) - "void" "cairo" "cairo_scale" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ; -: cairo_rotate ( cairo_t angle -- ) - "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: void +cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ; -: cairo_transform ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: void +cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ; -: cairo_set_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: cairo_font_face_t* +cairo_get_font_face ( cairo_t* cr ) ; -: cairo_identity_matrix ( cairo_t -- ) - "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ; -! cairo path creating functions +FUNCTION: cairo_scaled_font_t* +cairo_get_scaled_font ( cairo_t* cr ) ; -: cairo_new_path ( cairo_t -- ) - "void" "cairo" "cairo_new_path" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_show_text ( cairo_t* cr, char* utf8 ) ; -: cairo_move_to ( cairo_t x y -- ) - "void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; -: cairo_new_sub_path ( cairo_t -- ) - "void" "cairo" "cairo_new_sub_path" [ "cairo_t*" ] alien-invoke ; - -: cairo_line_to ( cairo_t x y -- ) - "void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_text_path ( cairo_t* cr, char* utf8 ) ; -: cairo_curve_to ( cairo_t x1 y1 x2 y2 x3 y3 -- ) - "void" "cairo" "cairo_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; -: cairo_arc ( cairo_t xc yc radius angle1 angle2 -- ) - "void" "cairo" "cairo_arc" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ; -: cairo_arc_negative ( cairo_t xc yc radius angle1 angle2 -- ) - "void" "cairo" "cairo_arc_negative" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ; - -: cairo_rel_move_to ( cairo_t dx dy -- ) - "void" "cairo" "cairo_rel_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ; - -: cairo_rel_line_to ( cairo_t dx dy -- ) - "void" "cairo" "cairo_rel_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; -: cairo_rel_curve_to ( cairo_t dx1 dy1 dx2 dy2 dx3 dy3 -- ) - "void" "cairo" "cairo_rel_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ; -: cairo_rectangle ( cairo_t x y width height -- ) - "void" "cairo" "cairo_rectangle" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +! Generic identifier for a font style -: cairo_close_path ( cairo_t -- ) - "void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_font_face_t* +cairo_font_face_reference ( cairo_font_face_t* font_face ) ; + +FUNCTION: void +cairo_font_face_destroy ( cairo_font_face_t* font_face ) ; + +FUNCTION: uint +cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_status_t +cairo_font_face_status ( cairo_font_face_t* font_face ) ; + +TYPEDEF: int cairo_font_type_t +C-ENUM: + CAIRO_FONT_TYPE_TOY + CAIRO_FONT_TYPE_FT + CAIRO_FONT_TYPE_WIN32 + CAIRO_FONT_TYPE_QUARTZ ; + +FUNCTION: cairo_font_type_t +cairo_font_face_get_type ( cairo_font_face_t* font_face ) ; + +FUNCTION: void* +cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ; + +FUNCTION: cairo_status_t +cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +! Portable interface to general font features. + +FUNCTION: cairo_scaled_font_t* +cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ; + +FUNCTION: cairo_scaled_font_t* +cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: void +cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: uint +cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: cairo_status_t +cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: cairo_font_type_t +cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: void* +cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ; + +FUNCTION: cairo_status_t +cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +FUNCTION: void +cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ; + +FUNCTION: void +cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ; + +FUNCTION: void +cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; + +FUNCTION: cairo_font_face_t* +cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ; + +FUNCTION: void +cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ; + +FUNCTION: void +cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ; + +FUNCTION: void +cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ; + +! Query functions + +FUNCTION: cairo_operator_t +cairo_get_operator ( cairo_t* cr ) ; + +FUNCTION: cairo_pattern_t* +cairo_get_source ( cairo_t* cr ) ; + +FUNCTION: double +cairo_get_tolerance ( cairo_t* cr ) ; + +FUNCTION: cairo_antialias_t +cairo_get_antialias ( cairo_t* cr ) ; + +FUNCTION: cairo_bool_t +cairo_has_current_point ( cairo_t* cr ) ; + +FUNCTION: void +cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ; + +FUNCTION: cairo_fill_rule_t +cairo_get_fill_rule ( cairo_t* cr ) ; + +FUNCTION: double +cairo_get_line_width ( cairo_t* cr ) ; + +FUNCTION: cairo_line_cap_t +cairo_get_line_cap ( cairo_t* cr ) ; + +FUNCTION: cairo_line_join_t +cairo_get_line_join ( cairo_t* cr ) ; + +FUNCTION: double +cairo_get_miter_limit ( cairo_t* cr ) ; + +FUNCTION: int +cairo_get_dash_count ( cairo_t* cr ) ; + +FUNCTION: void +cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ; + +FUNCTION: void +cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ; + +FUNCTION: cairo_surface_t* +cairo_get_target ( cairo_t* cr ) ; + +FUNCTION: cairo_surface_t* +cairo_get_group_target ( cairo_t* cr ) ; + +TYPEDEF: int cairo_path_data_type_t +C-ENUM: + CAIRO_PATH_MOVE_TO + CAIRO_PATH_LINE_TO + CAIRO_PATH_CURVE_TO + CAIRO_PATH_CLOSE_PATH ; + +! NEED TO DO UNION HERE +C-STRUCT: cairo_path_data_t-point + { "double" "x" } + { "double" "y" } ; + +C-STRUCT: cairo_path_data_t-header + { "cairo_path_data_type_t" "type" } + { "int" "length" } ; + +C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ; + +C-STRUCT: cairo_path_t + { "cairo_status_t" "status" } + { "cairo_path_data_t*" "data" } + { "int" "num_data" } ; + +FUNCTION: cairo_path_t* +cairo_copy_path ( cairo_t* cr ) ; + +FUNCTION: cairo_path_t* +cairo_copy_path_flat ( cairo_t* cr ) ; + +FUNCTION: void +cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ; + +FUNCTION: void +cairo_path_destroy ( cairo_path_t* path ) ; + +! Error status queries + +FUNCTION: cairo_status_t +cairo_status ( cairo_t* cr ) ; + +FUNCTION: char* +cairo_status_to_string ( cairo_status_t status ) ; ! Surface manipulation -: cairo_surface_create_similar ( cairo_surface_t cairo_content_t width height -- cairo_surface_t ) - "cairo_surface_t*" "cairo" "cairo_surface_create_similar" [ "cairo_surface_t*" "uint" "int" "int" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ; -: cairo_surface_reference ( cairo_surface_t -- cairo_surface_t ) - "cairo_surface_t*" "cairo" "cairo_surface_reference" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_surface_reference ( cairo_surface_t* surface ) ; -: cairo_surface_finish ( cairo_surface_t -- ) - "void" "cairo" "cairo_surface_finish" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_finish ( cairo_surface_t* surface ) ; -: cairo_surface_destroy ( cairo_surface_t -- ) - "void" "cairo" "cairo_surface_destroy" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_destroy ( cairo_surface_t* surface ) ; -: cairo_surface_get_reference_count ( cairo_surface_t -- count ) - "uint" "cairo" "cairo_surface_get_reference_count" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: uint +cairo_surface_get_reference_count ( cairo_surface_t* surface ) ; -: cairo_surface_status ( cairo_surface_t -- cairo_status_t ) - "uint" "cairo" "cairo_surface_status" [ "cairo_surface_t*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_status ( cairo_surface_t* surface ) ; -: cairo_surface_flush ( cairo_surface_t -- ) - "void" "cairo" "cairo_surface_flush" [ "cairo_surface_t*" ] alien-invoke ; +TYPEDEF: int cairo_surface_type_t +C-ENUM: + CAIRO_SURFACE_TYPE_IMAGE + CAIRO_SURFACE_TYPE_PDF + CAIRO_SURFACE_TYPE_PS + CAIRO_SURFACE_TYPE_XLIB + CAIRO_SURFACE_TYPE_XCB + CAIRO_SURFACE_TYPE_GLITZ + CAIRO_SURFACE_TYPE_QUARTZ + CAIRO_SURFACE_TYPE_WIN32 + CAIRO_SURFACE_TYPE_BEOS + CAIRO_SURFACE_TYPE_DIRECTFB + CAIRO_SURFACE_TYPE_SVG + CAIRO_SURFACE_TYPE_OS2 + CAIRO_SURFACE_TYPE_WIN32_PRINTING + CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ; -! painting functions -: cairo_paint ( cairo_t -- ) - "void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_surface_type_t +cairo_surface_get_type ( cairo_surface_t* surface ) ; -: cairo_paint_with_alpha ( cairo_t alpha -- ) - "void" "cairo" "cairo_paint_with_alpha" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: cairo_content_t +cairo_surface_get_content ( cairo_surface_t* surface ) ; -: cairo_mask ( cairo_t cairo_pattern_t -- ) - "void" "cairo" "cairo_mask" [ "cairo_t*" "void*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ; -: cairo_mask_surface ( cairo_t cairo_pattern_t surface-x surface-y -- ) - "void" "cairo" "cairo_mask_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ; -: cairo_stroke ( cairo_t -- ) - "void" "cairo" "cairo_stroke" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void* +cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ; -: cairo_stroke_preserve ( cairo_t -- ) - "void" "cairo" "cairo_stroke_preserve" [ "cairo_t*" ] alien-invoke ; +FUNCTION: cairo_status_t +cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; -: cairo_fill ( cairo_t -- ) - "void" "cairo" "cairo_fill" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ; -: cairo_fill_preserve ( cairo_t -- ) - "void" "cairo" "cairo_fill_preserve" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_flush ( cairo_surface_t* surface ) ; -: cairo_copy_page ( cairo_t -- ) - "void" "cairo" "cairo_copy_page" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_mark_dirty ( cairo_surface_t* surface ) ; -: cairo_show_page ( cairo_t -- ) - "void" "cairo" "cairo_show_page" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ; -! insideness testing -: cairo_in_stroke ( cairo_t x y -- t/f ) - "int" "cairo" "cairo_in_stroke" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ; -: cairo_in_fill ( cairo_t x y -- t/f ) - "int" "cairo" "cairo_in_fill" [ "cairo_t*" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ; -! rectangular extents -: cairo_stroke_extents ( cairo_t x1 y1 x2 y2 -- ) - "void" "cairo" "cairo_stroke_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ; -: cairo_fill_extents ( cairo_t x1 y1 x2 y2 -- ) - "void" "cairo" "cairo_fill_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: void +cairo_surface_copy_page ( cairo_surface_t* surface ) ; -! clipping -: cairo_reset_clip ( cairo_t -- ) - "void" "cairo" "cairo_reset_clip" [ "cairo_t*" ] alien-invoke ; +FUNCTION: void +cairo_surface_show_page ( cairo_surface_t* surface ) ; -: cairo_clip ( cairo_t -- ) - "void" "cairo" "cairo_clip" [ "cairo_t*" ] alien-invoke ; +! Image-surface functions -: cairo_clip_preserve ( cairo_t -- ) - "void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ; +TYPEDEF: int cairo_format_t +C-ENUM: + CAIRO_FORMAT_ARGB32 + CAIRO_FORMAT_RGB24 + CAIRO_FORMAT_A8 + CAIRO_FORMAT_A1 + CAIRO_FORMAT_RGB16_565 ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create ( cairo_format_t format, int width, int height ) ; -: cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t ) - "void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: int +cairo_format_stride_for_width ( cairo_format_t format, int width ) ; -: cairo_pattern_create_radial ( cx0 cy0 radius0 cx1 cy1 radius1 -- cairo_pattern_t ) - "void*" "cairo" "cairo_pattern_create_radial" [ "double" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ; -: cairo_pattern_add_color_stop_rgba ( pattern offset red green blue alpha -- status ) - "uint" "cairo" "cairo_pattern_add_color_stop_rgba" [ "void*" "double" "double" "double" "double" "double" ] alien-invoke ; +FUNCTION: uchar* +cairo_image_surface_get_data ( cairo_surface_t* surface ) ; -: cairo_show_text ( cairo_t msg_utf8 -- ) - "void" "cairo" "cairo_show_text" [ "cairo_t*" "char*" ] alien-invoke ; +FUNCTION: cairo_format_t +cairo_image_surface_get_format ( cairo_surface_t* surface ) ; -: cairo_text_path ( cairo_t msg_utf8 -- ) - "void" "cairo" "cairo_text_path" [ "cairo_t*" "char*" ] alien-invoke ; +FUNCTION: int +cairo_image_surface_get_width ( cairo_surface_t* surface ) ; -: cairo_select_font_face ( cairo_t family font_slant font_weight -- ) - "void" "cairo" "cairo_select_font_face" [ "cairo_t*" "char*" "uint" "uint" ] alien-invoke ; +FUNCTION: int +cairo_image_surface_get_height ( cairo_surface_t* surface ) ; -: cairo_set_font_size ( cairo_t scale -- ) - "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ; +FUNCTION: int +cairo_image_surface_get_stride ( cairo_surface_t* surface ) ; -: cairo_set_font_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create_from_png ( char* filename ) ; -: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; +FUNCTION: cairo_surface_t* +cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ; -FUNCTION: uchar* cairo_image_surface_get_data ( cairo_surface_t* surface ) ; -FUNCTION: cairo_format_t cairo_image_surface_get_format ( cairo_surface_t* surface ) ; -FUNCTION: int cairo_image_surface_get_width ( cairo_surface_t* surface ) ; -FUNCTION: int cairo_image_surface_get_height ( cairo_surface_t* surface ) ; -FUNCTION: int cairo_image_surface_get_stride ( cairo_surface_t* surface ) ; +! Pattern creation functions -! Cairo pdf +FUNCTION: cairo_pattern_t* +cairo_pattern_create_rgb ( double red, double green, double blue ) ; -: cairo_pdf_surface_create ( filename width height -- surface ) - "void*" "cairo" "cairo_pdf_surface_create" [ "char*" "double" "double" ] alien-invoke ; +FUNCTION: cairo_pattern_t* +cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ; -! Missing: +FUNCTION: cairo_pattern_t* +cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ; -! cairo_public cairo_surface_t * -! cairo_pdf_surface_create_for_stream (cairo_write_func_t write_func, -! void *closure, -! double width_in_points, -! double height_in_points); +FUNCTION: cairo_pattern_t* +cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ; -: cairo_pdf_surface_set_size ( surface width height -- ) - "void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ; +FUNCTION: cairo_pattern_t* +cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ; -! Cairo png +FUNCTION: cairo_pattern_t* +cairo_pattern_reference ( cairo_pattern_t* pattern ) ; -TYPEDEF: void* cairo_write_func_t -TYPEDEF: void* cairo_read_func_t +FUNCTION: void +cairo_pattern_destroy ( cairo_pattern_t* pattern ) ; -FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png ( char* filename ) ; +FUNCTION: uint +cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ; -FUNCTION: cairo_surface_t* cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ; +FUNCTION: cairo_status_t +cairo_pattern_status ( cairo_pattern_t* pattern ) ; -FUNCTION: cairo_status_t cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ; +FUNCTION: void* +cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ; -FUNCTION: cairo_status_t cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ; +FUNCTION: cairo_status_t +cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ; + +TYPEDEF: int cairo_pattern_type_t +C-ENUM: + CAIRO_PATTERN_TYPE_SOLID + CAIRO_PATTERN_TYPE_SURFACE + CAIRO_PATTERN_TYPE_LINEAR + CAIRO_PATTERN_TYPE_RADIA ; + +FUNCTION: cairo_pattern_type_t +cairo_pattern_get_type ( cairo_pattern_t* pattern ) ; + +FUNCTION: void +cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ; + +FUNCTION: void +cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ; + +FUNCTION: void +cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ; + +TYPEDEF: int cairo_extend_t +C-ENUM: + CAIRO_EXTEND_NONE + CAIRO_EXTEND_REPEAT + CAIRO_EXTEND_REFLECT + CAIRO_EXTEND_PAD ; + +FUNCTION: void +cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ; + +FUNCTION: cairo_extend_t +cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ; + +TYPEDEF: int cairo_filter_t +C-ENUM: + CAIRO_FILTER_FAST + CAIRO_FILTER_GOOD + CAIRO_FILTER_BEST + CAIRO_FILTER_NEAREST + CAIRO_FILTER_BILINEAR + CAIRO_FILTER_GAUSSIAN ; + +FUNCTION: void +cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ; + +FUNCTION: cairo_filter_t +cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ; + +FUNCTION: cairo_status_t +cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ; + +! Matrix functions + +FUNCTION: void +cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ; + +FUNCTION: void +cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ; + +FUNCTION: void +cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ; + +FUNCTION: void +cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ; + +FUNCTION: void +cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ; + +FUNCTION: void +cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ; + +FUNCTION: void +cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ; + +FUNCTION: cairo_status_t +cairo_matrix_invert ( cairo_matrix_t* matrix ) ; + +FUNCTION: void +cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ; + +FUNCTION: void +cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ; + +FUNCTION: void +cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ; + +! Functions to be used while debugging (not intended for use in production code) +FUNCTION: void +cairo_debug_reset_static_data ( ) ; diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor deleted file mode 100755 index c9700e82c0..0000000000 --- a/extra/cairo/lib/lib.factor +++ /dev/null @@ -1,36 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: cairo kernel accessors sequences -namespaces fry continuations ; -IN: cairo.lib - -TUPLE: cairo-t alien ; -C: cairo-t -M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ; - -TUPLE: cairo-surface-t alien ; -C: cairo-surface-t -M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ; - -: check-cairo ( cairo_status_t -- ) - dup CAIRO_STATUS_SUCCESS = [ drop ] - [ cairo_status_to_string "Cairo error: " prepend throw ] if ; - -SYMBOL: cairo -: cr ( -- cairo ) cairo get ; - -: (with-cairo) ( cairo-t quot -- ) - >r alien>> cairo r> [ cr cairo_status check-cairo ] - compose with-variable ; inline - -: with-cairo ( cairo quot -- ) - >r r> [ (with-cairo) ] curry with-disposal ; inline - -: (with-surface) ( cairo-surface-t quot -- ) - >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline - -: with-surface ( cairo_surface quot -- ) - >r r> [ (with-surface) ] curry with-disposal ; inline - -: with-cairo-from-surface ( cairo_surface quot -- ) - '[ cairo_create , with-cairo ] with-surface ; inline From 85d2330289395ea4c2706db59c0257d95b98d3ee Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 11 May 2008 20:51:33 -0700 Subject: [PATCH 14/21] fixed bugs in cairo, added cairo.samples MAIN: word --- extra/cairo/cairo.factor | 4 ++-- extra/cairo/ffi/ffi.factor | 20 +------------------- extra/cairo/gadgets/gadgets.factor | 2 +- extra/cairo/samples/samples.factor | 11 +++++++++-- 4 files changed, 13 insertions(+), 24 deletions(-) diff --git a/extra/cairo/cairo.factor b/extra/cairo/cairo.factor index c9700e82c0..077152a3c2 100755 --- a/extra/cairo/cairo.factor +++ b/extra/cairo/cairo.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo kernel accessors sequences +USING: cairo.ffi kernel accessors sequences namespaces fry continuations ; -IN: cairo.lib +IN: cairo TUPLE: cairo-t alien ; C: cairo-t diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor index b82191f72c..451806c0a7 100644 --- a/extra/cairo/ffi/ffi.factor +++ b/extra/cairo/ffi/ffi.factor @@ -7,7 +7,7 @@ USING: system combinators alien alien.syntax kernel alien.c-types accessors sequences arrays ui.gadgets ; -IN: cairo +IN: cairo.ffi << "cairo" { { [ os winnt? ] [ "libcairo-2.dll" ] } { [ os macosx? ] [ "libcairo.dylib" ] } @@ -340,24 +340,6 @@ C-STRUCT: cairo_rectangle_t { "double" "y" } { "double" "width" } { "double" "height" } ; - -: ( x y width height -- cairo_rectangle_t ) - "cairo_rectangle_t" dup - { - [ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ] - [ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ] - } cleave ; - -: rect>cairo ( rect -- cairo_rectangle_t ) - [ loc>> ] [ dim>> ] bi [ [ first ] [ second ] bi ] bi@ - ; - -: cairo>rect ( cairo_rectangle_t -- rect ) - { - [ cairo_rectangle_t-x ] [ cairo_rectangle_t-y ] - [ cairo_rectangle_t-width ] [ cairo_rectangle_t-height ] - } cleave - [ 2array ] 2bi@ ; C-STRUCT: cairo_rectangle_list_t { "cairo_status_t" "status" } diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index 98b3c452eb..e0daefd63c 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo cairo.lib ui.render kernel opengl.gl opengl +USING: cairo cairo.ffi ui.render kernel opengl.gl opengl math byte-arrays ui.gadgets accessors arrays namespaces io.backend ; diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 2d8d34a376..402c3881f4 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -3,7 +3,7 @@ ! ! these samples are a subset of the samples on ! http://cairographics.org/samples/ -USING: cairo cairo.lib locals math.constants math +USING: cairo cairo.ffi locals math.constants math io.backend kernel alien.c-types libc namespaces ; IN: cairo.samples @@ -137,4 +137,11 @@ IN: cairo.samples cr 0 256 cairo_rel_line_to cr 0 128 cairo_move_to cr 256 0 cairo_rel_line_to - cr cairo_stroke ; \ No newline at end of file + cr cairo_stroke ; + + USING: quotations cairo.gadgets ui.gadgets.panes sequences ; + : samples ( -- ) + { arc clip clip-image dash gradient text utf8 } + [ 256 256 rot 1quotation gadget. ] each ; + + MAIN: samples \ No newline at end of file From fa1c03bf73c1cee0f37514db257bcbde93c4ebd1 Mon Sep 17 00:00:00 2001 From: James Cash Date: Mon, 12 May 2008 00:34:10 -0400 Subject: [PATCH 15/21] Need lambda-rewrite --- extra/lisp/lisp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 79071ce619..52faf59c17 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -71,7 +71,7 @@ PRIVATE> [ [ , ] [ ] make ] if ; : lisp-string>factor ( str -- quot ) - lisp-expr parse-result-ast convert-form ; + lisp-expr parse-result-ast convert-form lambda-rewrite call ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 1260c1ba51c0af13953017f046537f03a96efa79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 18:53:22 -0500 Subject: [PATCH 16/21] Working on SSL and refactoring related code to make things easier to plug in --- core/alien/c-types/c-types.factor | 2 + core/continuations/continuations.factor | 12 ++- core/debugger/debugger.factor | 2 + extra/db/postgresql/ffi/ffi.factor | 1 - extra/destructors/destructors.factor | 48 +++++----- extra/io/launcher/launcher.factor | 6 +- extra/io/nonblocking/nonblocking-docs.factor | 8 +- extra/io/nonblocking/nonblocking.factor | 14 +-- extra/io/pipes/pipes.factor | 8 +- extra/io/sockets/secure/secure.factor | 16 +++- extra/io/sockets/sockets.factor | 28 ++++-- extra/io/unix/backend/backend.factor | 45 ++++++---- extra/io/unix/epoll/epoll.factor | 4 +- extra/io/unix/files/files.factor | 6 +- extra/io/unix/kqueue/kqueue.factor | 4 +- extra/io/unix/select/select.factor | 12 +-- extra/io/unix/sockets/secure/secure.factor | 95 ++++++++++++++++++++ extra/io/unix/sockets/sockets.factor | 59 ++++++------ extra/io/unix/unix.factor | 15 +++- extra/io/windows/ce/backend/backend.factor | 2 +- extra/io/windows/ce/sockets/sockets.factor | 4 +- extra/io/windows/nt/sockets/sockets.factor | 19 ++-- extra/io/windows/windows.factor | 14 +-- extra/openssl/openssl.factor | 24 +++-- extra/openssl/unix/unix.factor | 11 --- extra/oracle/liboci/liboci.factor | 1 - extra/unix/unix.factor | 1 - extra/windows/types/types.factor | 1 - 28 files changed, 301 insertions(+), 161 deletions(-) create mode 100644 extra/io/unix/sockets/secure/secure.factor delete mode 100644 extra/openssl/unix/unix.factor diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index f67fc78259..44c0112c77 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -382,4 +382,6 @@ M: long-long-type box-return ( type -- ) "double" define-primitive-type os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef + + "ulong" "size_t" typedef ] with-compilation-unit diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 78effb043a..8b6cd1ce3a 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -139,10 +139,16 @@ SYMBOL: thread-error-hook over >r compose [ dip rethrow ] curry recover r> call ; inline +ERROR: attempt-all-error ; + : attempt-all ( seq quot -- obj ) - [ - [ [ , f ] compose [ , drop t ] recover ] curry all? - ] { } make peek swap [ rethrow ] when ; inline + over empty? [ + attempt-all-error + ] [ + [ + [ [ , f ] compose [ , drop t ] recover ] curry all? + ] { } make peek swap [ rethrow ] when + ] if ; inline GENERIC: dispose ( object -- ) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index df7d33f41c..ad74889236 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -298,6 +298,8 @@ M: immutable-slot summary drop "Slot is immutable" ; M: bad-create summary drop "Bad parameters to create" ; +M: attempt-all-error summary drop "Nothing to attempt" ; + ( obj -- newobj ) - f destructor boa ; - : add-error-destructor ( obj -- ) - error-destructors get push ; + error-destructors get push ; : add-always-destructor ( obj -- ) - always-destructors get push ; + always-destructors get push ; : do-always-destructors ( -- ) always-destructors get dispose-each ; @@ -40,19 +27,28 @@ M: destructor dispose [ do-error-destructors ] cleanup ] with-scope ; inline +TUPLE: only-once object destroyed ; + +M: only-once dispose + dup destroyed>> [ drop ] [ + [ object>> dispose ] [ t >>destroyed drop ] bi + ] if ; + +: f only-once boa ; + ! Memory allocations TUPLE: memory-destructor alien ; C: memory-destructor M: memory-destructor dispose ( obj -- ) - memory-destructor-alien free ; + alien>> free ; : free-always ( alien -- ) - add-always-destructor ; + add-always-destructor ; : free-later ( alien -- ) - add-error-destructor ; + add-error-destructor ; ! Handles TUPLE: handle-destructor alien ; @@ -60,13 +56,13 @@ TUPLE: handle-destructor alien ; C: handle-destructor M: handle-destructor dispose ( obj -- ) - handle-destructor-alien close-handle ; + alien>> close-handle ; : close-always ( handle -- ) - add-always-destructor ; + add-always-destructor ; : close-later ( handle -- ) - add-error-destructor ; + add-error-destructor ; ! Sockets TUPLE: socket-destructor alien ; @@ -76,10 +72,10 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) M: socket-destructor dispose ( obj -- ) - socket-destructor-alien destruct-socket ; + alien>> destruct-socket ; : close-socket-always ( handle -- ) - add-always-destructor ; + add-always-destructor ; : close-socket-later ( handle -- ) - add-error-destructor ; + add-error-destructor ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e8eb973e34..e28742537d 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -165,7 +165,7 @@ M: object run-pipeline-element run-detached ] [ out>> close-handle ] - [ in>> ] + [ in>> ] } cleave r> ] with-destructors ; @@ -182,7 +182,7 @@ M: object run-pipeline-element run-detached ] [ in>> close-handle ] - [ out>> ] + [ out>> ] } cleave r> ] with-destructors ; @@ -200,7 +200,7 @@ M: object run-pipeline-element run-detached ] [ [ in>> close-handle ] [ out>> close-handle ] bi* ] - [ [ in>> ] [ out>> ] bi* ] + [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor index bd2be34c9d..7a489d8606 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -11,10 +11,10 @@ $nl { $subsection } "Input ports:" { $subsection input-port } -{ $subsection } +{ $subsection } "Output ports:" { $subsection output-port } -{ $subsection } +{ $subsection } "Global native I/O protocol:" { $subsection io-backend } { $subsection init-io } @@ -62,12 +62,12 @@ HELP: { $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." } $low-level-note ; -HELP: +HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "input-port" "a new " { $link input-port } } } { $description "Creates a new " { $link input-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; -HELP: +HELP: { $values { "handle" "a native handle identifying an I/O resource" } { "output-port" "a new " { $link output-port } } } { $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." } $low-level-note ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 40605347b1..b78cfecbaf 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -3,7 +3,8 @@ USING: math kernel io sequences io.buffers io.timeouts generic byte-vectors system io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting -dlists assocs io.encodings.binary inspector accessors ; +dlists assocs io.encodings.binary inspector accessors +destructors ; IN: io.nonblocking SYMBOL: default-buffer-size @@ -29,16 +30,19 @@ GENERIC: close-handle ( handle -- ) TUPLE: input-port < port ; -: ( handle -- input-port ) +: ( handle -- input-port ) input-port ; TUPLE: output-port < port ; -: ( handle -- output-port ) +: ( handle -- output-port ) output-port ; -: ( read-handle write-handle -- input-port output-port ) - swap [ swap ] [ ] [ dispose drop ] cleanup ; +: ( read-handle write-handle -- input-port output-port ) + [ + [ dup add-error-destructor ] + [ dup add-error-destructor ] bi* + ] with-destructors ; : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index 72d27372f3..cae7ef8158 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -17,16 +17,16 @@ HOOK: (pipe) io-backend ( -- pipe ) [ >r (pipe) [ add-error-destructor ] - [ in>> ] - [ out>> ] + [ in>> ] + [ out>> ] tri r> ] with-destructors ; dup add-always-destructor ] [ input-stream get ] if* ; -: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; +: ?reader [ dup add-always-destructor ] [ input-stream get ] if* ; +: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index f7729233ac..6cd711da81 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/extra/io/sockets/secure/secure.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel symbols namespaces continuations ; +USING: accessors kernel symbols namespaces continuations +io.sockets sequences ; IN: io.sockets.secure SYMBOL: ssl-backend @@ -22,3 +23,16 @@ HOOK: ssl-backend ( config -- context ) [ ] [ [ ssl-context set ] prepose ] bi* with-disposal ] with-scope ; inline + +TUPLE: ssl addrspec ; + +C: ssl + +> inet? ; + +M: ssl-inet (client) + addrspec>> resolve-client-addr [ ] map (client) ; + +PRIVATE> diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index f835f0beb2..7b0f55cab7 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel io.backend namespaces continuations sequences arrays io.encodings io.nonblocking io.streams.duplex -accessors ; +accessors destructors ; IN: io.sockets TUPLE: local path ; @@ -22,11 +22,21 @@ TUPLE: inet host port ; C: inet -HOOK: ((client)) io-backend ( addrspec -- client-in client-out ) +GENERIC: wait-to-connect ( client-out handle -- ) + +GENERIC: ((client)) ( addrspec -- handle ) GENERIC: (client) ( addrspec -- client-in client-out ) -M: array (client) [ ((client)) 2array ] attempt-all first2 ; -M: object (client) ((client)) ; + +M: array (client) [ (client) 2array ] attempt-all first2 ; + +M: object (client) + [ + ((client)) + dup + 2dup [ add-error-destructor ] bi@ + dup dup handle>> wait-to-connect + ] with-destructors ; : ( addrspec encoding -- stream ) >r (client) r> ; @@ -42,7 +52,7 @@ HOOK: (server) io-backend ( addrspec -- handle ) HOOK: (accept) io-backend ( server -- addrspec handle ) : accept ( server -- client addrspec ) - [ (accept) dup ] [ encoding>> ] bi + [ (accept) dup ] [ encoding>> ] bi swap ; HOOK: io-backend ( addrspec -- datagram ) @@ -55,8 +65,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq ) HOOK: host-name io-backend ( -- string ) +: resolve-client-addr ( inet -- seq ) + [ host>> ] [ port>> ] bi f resolve-host ; + M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host - [ empty? [ "Host name lookup failed" throw ] when ] - [ (client) ] - bi ; + resolve-client-addr (client) ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 6e738dc3e8..d4e293b332 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -11,7 +11,11 @@ IN: io.unix.backend ! I/O tasks TUPLE: io-task port callbacks ; -: io-task-fd port>> handle>> ; +GENERIC: handle-fd ( handle -- fd ) + +M: integer handle-fd ; + +: io-task-fd port>> handle>> handle-fd ; : ( port continuation/f class -- task ) new @@ -84,9 +88,10 @@ M: integer init-handle ( fd -- ) M: integer close-handle ( fd -- ) close ; +TUPLE: unix-io-error error port ; + : report-error ( error port -- ) - [ "Error on fd " % dup handle>> # ": " % swap % ] "" make - >>error drop ; + tuck unix-io-error boa >>error drop ; : ignorable-error? ( n -- ? ) [ EAGAIN number= ] [ EINTR number= ] bi or ; @@ -100,7 +105,7 @@ M: integer close-handle ( fd -- ) dup rot unregister-io-task io-task-callbacks [ resume ] each ; -: handle-io-task ( mx task -- ) +: perform-io-task ( mx task -- ) dup do-io-task [ pop-callbacks ] [ 2drop ] if ; : handle-timeout ( port mx assoc -- ) @@ -127,25 +132,25 @@ M: unix cancel-io ( port -- ) [ buffer>> buffer-end ] [ buffer>> buffer-capacity ] tri read ; -: refill ( port -- ? ) +GENERIC: refill ( port handle -- ? ) + +M: integer refill #! Return f if there is a recoverable error + drop dup buffer>> buffer-empty? [ - dup (refill) dup 0 >= [ + dup (refill) dup 0 >= [ swap buffer>> n>buffer t ] [ drop defer-error ] if - ] [ - drop t - ] if ; + ] [ drop t ] if ; TUPLE: read-task < input-task ; -: ( port continuation -- task ) - read-task ; +: ( port continuation -- task ) read-task ; M: read-task do-io-task - io-task-port dup refill + port>> dup dup handle>> refill [ [ reader-eof ] [ drop ] if ] keep ; M: unix (wait-to-read) @@ -153,7 +158,10 @@ M: unix (wait-to-read) pending-error ; ! Writers -: write-step ( port -- ? ) +GENERIC: drain ( port handle -- ? ) + +M: integer drain + drop dup [ handle>> ] [ buffer>> buffer@ ] @@ -164,12 +172,11 @@ M: unix (wait-to-read) TUPLE: write-task < output-task ; -: ( port continuation -- task ) - write-task ; +: ( port continuation -- task ) write-task ; M: write-task do-io-task io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or - [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ; + [ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ; : add-write-io-task ( port continuation -- ) over handle>> mx get-global writes>> at* @@ -186,9 +193,9 @@ M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix (init-stdio) ( -- ) - 0 - 1 - 2 ; + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index db1e7086e0..f34a4c7009 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -43,10 +43,10 @@ M: epoll-mx unregister-io-task ( task mx -- ) r> epoll_wait dup multiplexer-error ; : epoll-read-task ( mx fd -- ) - over mx-reads at* [ handle-io-task ] [ 2drop ] if ; + over mx-reads at* [ perform-io-task ] [ 2drop ] if ; : epoll-write-task ( mx fd -- ) - over mx-writes at* [ handle-io-task ] [ 2drop ] if ; + over mx-writes at* [ perform-io-task ] [ 2drop ] if ; : handle-event ( mx kevent -- ) epoll-event-fd 2dup epoll-read-task epoll-write-task ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 28e08d4bf2..1259f658d1 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -21,7 +21,7 @@ M: unix cd ( path -- ) O_RDONLY file-mode open dup io-error ; M: unix (file-reader) ( path -- stream ) - open-read ; + open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -29,7 +29,7 @@ M: unix (file-reader) ( path -- stream ) write-flags file-mode open dup io-error ; M: unix (file-writer) ( path -- stream ) - open-write ; + open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -38,7 +38,7 @@ M: unix (file-writer) ( path -- stream ) [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; M: unix (file-appender) ( path -- stream ) - open-append ; + open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index ec82a426d3..d329853881 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -57,10 +57,10 @@ M: kqueue-mx unregister-io-task ( task mx -- ) dup multiplexer-error ; :: kevent-read-task ( mx fd kevent -- ) - mx fd mx reads>> at handle-io-task ; + mx fd mx reads>> at perform-io-task ; :: kevent-write-task ( mx fd kevent -- ) - mx fd mx writes>> at handle-io-task ; + mx fd mx writes>> at perform-io-task ; :: kevent-proc-task ( mx pid kevent -- ) pid wait-for-pid diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 74b7136823..58b8371d89 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -21,12 +21,12 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; -: handle-fd ( fd task fdset mx -- ) +: check-fd ( fd task fdset mx -- ) roll munge rot clear-nth - [ swap handle-io-task ] [ 2drop ] if ; + [ swap perform-io-task ] [ 2drop ] if ; -: handle-fdset ( tasks fdset mx -- ) - [ handle-fd ] 2curry assoc-each ; +: check-fdset ( tasks fdset mx -- ) + [ check-fd ] 2curry assoc-each ; : init-fdset ( tasks fdset -- ) [ >r drop t swap munge r> set-nth ] curry assoc-each ; @@ -52,5 +52,5 @@ TUPLE: select-mx < mx read-fdset write-fdset ; M: select-mx wait-for-events ( ms mx -- ) swap >r dup init-fdsets r> dup [ make-timeval ] when select multiplexer-error - dup read-fdset/tasks pick handle-fdset - dup write-fdset/tasks rot handle-fdset ; + dup read-fdset/tasks pick check-fdset + dup write-fdset/tasks rot check-fdset ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor new file mode 100644 index 0000000000..86abaf2e65 --- /dev/null +++ b/extra/io/unix/sockets/secure/secure.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors byte-arrays kernel debugger sequences namespaces math +math.order combinators init alien alien.c-types alien.strings libc +continuations destructors +openssl openssl.libcrypto openssl.libssl +io.files io.nonblocking io.unix.backend io.unix.sockets +io.encodings.ascii io.buffers io.sockets io.sockets.secure +unix.ffi ; +IN: io.unix.sockets.secure + +! todo: SSL_pending, rehandshake +! do we call write twice, wth 0 bytes at the end? + +M: ssl handle-fd file>> ; + +: syscall-error ( port r -- ) + ERR_get_error dup zero? [ + drop + { + { -1 [ err_no strerror ] } + { 0 [ "Premature EOF" ] } + } case + ] [ + nip (ssl-error-string) + ] if swap report-error ; + +: check-response ( port r -- port r n ) + over handle>> handle>> over SSL_get_error ; inline + +! Input ports +: report-ssl-error ( port r -- ) + drop ssl-error-string swap report-error ; + +: check-read-response ( port r -- ? ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> n>buffer t ] } + { SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] } + { SSL_ERROR_WANT_READ [ 2drop f ] } + { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX + { SSL_ERROR_SYSCALL [ syscall-error t ] } + { SSL_ERROR_SSL [ report-ssl-error t ] } + } case ; + +M: ssl-handle refill + drop + dup buffer>> buffer-empty? [ + dup + [ handle>> handle>> ] ! ssl + [ buffer>> buffer-end ] ! buf + [ buffer>> buffer-capacity ] tri ! len + SSL_read + check-read-response + ] [ drop t ] if ; + +! Output ports +: check-write-response ( port r -- ? ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } + ! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX + { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX + { SSL_ERROR_WANT_WRITE [ 2drop f ] } + { SSL_ERROR_SYSCALL [ syscall-error t ] } + { SSL_ERROR_SSL [ report-ssl-error t ] } + } case ; + +M: ssl-handle drain + drop + dup + [ handle>> handle>> ] ! ssl + [ buffer>> buffer@ ] ! buf + [ buffer>> buffer-length ] tri ! len + SSL_write + check-write-response ; + +! Client sockets +M: ssl ((client)) ( addrspec -- handle ) + [ addrspec>> ((client)) ] with-destructors ; + +: check-connect-response ( port r -- ? ) + check-response + { + { SSL_ERROR_NONE [ 2drop t ] } + { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX + { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX + { SSL_ERROR_SYSCALL [ syscall-error t ] } + { SSL_ERROR_SSL [ report-ssl-error t ] } + } case ; + +M: ssl-handle (wait-to-connect) + handle>> handle>> ! ssl + SSL_connect + check-connect-response ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 71edbc5500..187c65fac7 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -5,22 +5,18 @@ namespaces threads sequences byte-arrays io.nonblocking io.binary io.unix.backend io.streams.duplex io.sockets.impl io.backend io.files io.files.private io.encodings.utf8 math.parser continuations libc combinators system accessors -qualified unix.ffi unix ; +destructors qualified unix.ffi unix ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; IN: io.unix.sockets -: pending-init-error ( port -- ) - #! We close it here to avoid a resource leak; callers of - #! don't set up error handlers until after - #! returns (and if they did before, they wouldn't have - #! anything to close!) - dup port-error dup [ swap dispose throw ] [ 2drop ] if ; - : socket-fd ( domain type -- socket ) - 0 socket dup io-error dup init-handle ; + 0 socket + dup io-error + dup close-later + dup init-handle ; : sockopt ( fd level opt -- ) 1 "int" heap-size setsockopt io-error ; @@ -37,25 +33,24 @@ TUPLE: connect-task < output-task ; : ( port continuation -- task ) connect-task ; +GENERIC: (wait-to-connect) ( port handle -- ? ) + +M: integer (wait-to-connect) + f 0 write 0 < [ defer-error ] [ drop t ] if ; + M: connect-task do-io-task - port>> dup handle>> f 0 write - 0 < [ defer-error ] [ drop t ] if ; + port>> dup handle>> (wait-to-connect) ; -: wait-to-connect ( port -- ) - [ add-io-task ] with-port-continuation drop ; +M: integer wait-to-connect ( client-out fd -- ) + drop + [ add-io-task ] with-port-continuation + pending-error ; -M: unix ((client)) ( addrspec -- client-in client-out ) - dup make-sockaddr/size >r >r - protocol-family SOCK_STREAM socket-fd - dup r> r> connect - zero? err_no EINPROGRESS = or [ - dup init-client-socket - dup - dup wait-to-connect - dup pending-init-error - ] [ - dup close (io-error) - ] if ; +M: object ((client)) ( addrspec -- fd ) + [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi + [ 2drop ] [ connect ] 3bi + zero? err_no EINPROGRESS = or + [ dup init-client-socket ] [ (io-error) ] if ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) @@ -83,15 +78,17 @@ M: accept-task do-io-task : wait-to-accept ( server -- ) [ add-io-task ] with-port-continuation drop ; -: server-fd ( addrspec type -- fd ) - >r dup protocol-family r> socket-fd +: server-socket-fd ( addrspec type -- fd ) + >r dup protocol-family r> socket-fd dup init-server-socket dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; M: unix (server) ( addrspec -- handle ) - SOCK_STREAM server-fd - dup 10 listen zero? [ dup close (io-error) ] unless ; + [ + SOCK_STREAM server-socket-fd + dup 10 listen io-error + ] with-destructors ; M: unix (accept) ( server -- addrspec handle ) #! Wait for a client connection. @@ -102,7 +99,9 @@ M: unix (accept) ( server -- addrspec handle ) ! Datagram sockets - UDP and Unix domain M: unix - [ SOCK_DGRAM server-fd ] keep ; + [ + [ SOCK_DGRAM server-socket-fd ] keep + ] with-destructors ; SYMBOL: receive-buffer diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index e8e7135e1a..3a379de78f 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,13 @@ -USING: io.unix.backend io.unix.files io.unix.sockets -io.unix.launcher io.unix.mmap io.unix.pipes io.timeouts -io.backend combinators namespaces system vocabs.loader -sequences words init ; +USING: system words sequences vocabs.loader ; + +{ + "io.unix.backend" + "io.unix.files" + "io.unix.sockets" + "io.unix.sockets.secure" + "io.unix.launcher" + "io.unix.mmap" + "io.unix.pipes" +} [ require ] each "io.unix." os word-name append require diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index a8ff4c14e3..46564f2aec 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -46,5 +46,5 @@ M: wince (init-stdio) ( -- ) 1 _getstdfilex _fileno 2 _getstdfilex _fileno ] if [ f ] 3apply - rot -rot [ ] bi@ + [ ] [ ] [ ] tri* ] with-variable ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 0001bb5142..45c10ea258 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -32,7 +32,7 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:winsock-error!=0/f ; M: wince (client) ( addrspec -- reader writer ) - do-connect dup ; + do-connect dup ; M: wince (server) ( addrspec -- handle ) windows.winsock:SOCK_STREAM server-fd @@ -52,7 +52,7 @@ M: wince (accept) ( server -- client ) [ windows.winsock:winsock-error ] when ] keep ] keep server-port-addr parse-sockaddr swap - + ] with-timeout ; M: wince ( addrspec -- datagram ) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 79e767177d..89e1ea3277 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -45,12 +45,16 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx port -- ) - >r ConnectEx-args-lpOverlapped* r> +: connect-continuation ( overlapped port -- ) 2dup save-callback get-overlapped-result drop ; -M: winnt ((client)) ( addrspec -- client-in client-out ) +M: win32-socket wait-to-connect ( client-out handle -- ) + [ overlapped>> swap connect-continuation ] + [ drop pending-error ] + 2bi ; + +M: object ((client)) ( addrspec -- handle ) [ \ ConnectEx-args new over make-sockaddr/size pick init-connect @@ -60,8 +64,7 @@ M: winnt ((client)) ( addrspec -- client-in client-out ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* dup - >r [ connect-continuation ] keep [ pending-error ] keep r> + dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi ] with-destructors ; TUPLE: AcceptEx-args port @@ -117,7 +120,7 @@ TUPLE: AcceptEx-args port [ extract-remote-host ] keep ! addrspec AcceptEx [ AcceptEx-args-sAcceptSocket* add-completion ] keep - AcceptEx-args-sAcceptSocket* ; + [ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi ; M: winnt (accept) ( server -- addrspec handle ) [ @@ -135,7 +138,7 @@ M: winnt (server) ( addrspec -- handle ) [ SOCK_STREAM server-fd dup listen-on-socket dup add-completion - + f ] with-destructors ; M: winnt ( addrspec -- datagram ) @@ -143,7 +146,7 @@ M: winnt ( addrspec -- datagram ) [ SOCK_DGRAM server-fd dup add-completion - + f ] keep ] with-destructors ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 85c448bdbd..c2718c4189 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -123,13 +123,13 @@ C: FileArgs FileArgs-lpOverlapped ; M: windows (file-reader) ( path -- stream ) - open-read ; + open-read ; M: windows (file-writer) ( path -- stream ) - open-write ; + open-write ; M: windows (file-appender) ( path -- stream ) - open-append ; + open-append ; M: windows move-file ( from to -- ) [ normalize-path ] bi@ MoveFile win32-error=0/f ; @@ -151,10 +151,12 @@ M: windows delete-directory ( path -- ) HOOK: WSASocket-flags io-backend ( -- DWORD ) -TUPLE: win32-socket < win32-file ; +TUPLE: win32-socket < win32-file overlapped ; -: ( handle -- win32-socket ) - f win32-file boa ; +: ( handle overlapped -- win32-socket ) + win32-socket new + swap >>overlapped + swap >>handle ; : open-socket ( family type -- socket ) 0 f 0 WSASocket-flags WSASocket dup socket-error ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 196ac58695..e745616a8e 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -19,11 +19,14 @@ M: SSLv23 ssl-method drop SSLv23_method ; M: SSLv3 ssl-method drop SSLv3_method ; M: TLSv1 ssl-method drop TLSv1_method ; -: (ssl-error) ( num -- * ) - ERR_get_error ERR_clear_error f ERR_error_string throw ; +: (ssl-error-string) ( n -- string ) + ERR_clear_error f ERR_error_string ; + +: ssl-error-string ( -- string ) + ERR_get_error ERR_clear_error f ERR_error_string ; : ssl-error ( obj -- ) - { f 0 } member? [ (ssl-error) ] when ; + { f 0 } member? [ ssl-error-string throw ] when ; : init-ssl ( -- ) SSL_library_init ssl-error @@ -114,14 +117,19 @@ M: openssl-context dispose dup handle>> [ SSL_CTX_free ] when* f >>handle drop ; -TUPLE: ssl file handle ; +TUPLE: ssl-handle file handle ; -: ( file -- ssl ) - ssl-context get handle>> SSL_new dup ssl-error ssl boa ; +: ( fd -- ssl ) + ssl-context get handle>> SSL_new dup ssl-error ssl-handle boa ; -M: ssl init-handle drop ; +: ( fd -- ssl ) + [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + + [ handle>> swap dup SSL_set_bio ] keep ; -M: ssl close-handle +M: ssl-handle init-handle drop ; + +M: ssl-handle close-handle [ file>> close-handle ] [ handle>> SSL_free ] bi ; ERROR: certificate-verify-error result ; diff --git a/extra/openssl/unix/unix.factor b/extra/openssl/unix/unix.factor deleted file mode 100644 index d84a46e085..0000000000 --- a/extra/openssl/unix/unix.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel debugger sequences namespaces math -math.order combinators init alien alien.c-types alien.strings libc -continuations destructors -locals unicode.case -openssl.libcrypto openssl.libssl -io.files io.encodings.ascii io.sockets.secure ; -IN: openssl.unix - - diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor index 7af69a97bb..aa04aef39f 100644 --- a/extra/oracle/liboci/liboci.factor +++ b/extra/oracle/liboci/liboci.factor @@ -124,7 +124,6 @@ TYPEDEF: ushort ub2 TYPEDEF: short sb2 TYPEDEF: uint ub4 TYPEDEF: int sb4 -TYPEDEF: ulong size_t ! =============================================== ! Input data types (ocidfn.h) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index c68f127226..948fca219e 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -11,7 +11,6 @@ IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t -TYPEDEF: ulong size_t : PROT_NONE 0 ; inline : PROT_READ 1 ; inline diff --git a/extra/windows/types/types.factor b/extra/windows/types/types.factor index 8b4b2d98d2..3fef691741 100644 --- a/extra/windows/types/types.factor +++ b/extra/windows/types/types.factor @@ -198,7 +198,6 @@ TYPEDEF: void* MSGBOXPARAMSA TYPEDEF: void* MSGBOXPARAMSW TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE -TYPEDEF: int size_t TYPEDEF: size_t socklen_t TYPEDEF: void* WNDPROC From dfb25c3350b6557eda55dd5f9b28afaff5b479c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 19:23:32 -0500 Subject: [PATCH 17/21] SSL API fleshed out, doesn't work yet --- core/continuations/continuations-tests.factor | 2 ++ extra/http/http.factor | 2 ++ extra/io/unix/sockets/secure/secure.factor | 4 ++-- extra/io/unix/sockets/sockets.factor | 2 +- extra/openssl/openssl.factor | 21 +++++++++++++++---- 5 files changed, 24 insertions(+), 7 deletions(-) diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 28581820fd..a9adcce82f 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -119,3 +119,5 @@ T{ dispose-dummy } "b" set [ t ] [ "b" get disposed?>> ] unit-test [ ] [ [ return ] with-return ] unit-test + +[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with diff --git a/extra/http/http.factor b/extra/http/http.factor index 786210123d..968d4d88ca 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -17,6 +17,8 @@ IN: http : http-port 80 ; inline +: https-port 443 ; inline + : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without #! URL-encoding? diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 86abaf2e65..2aa0792070 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -12,7 +12,7 @@ IN: io.unix.sockets.secure ! todo: SSL_pending, rehandshake ! do we call write twice, wth 0 bytes at the end? -M: ssl handle-fd file>> ; +M: ssl-handle handle-fd file>> ; : syscall-error ( port r -- ) ERR_get_error dup zero? [ @@ -90,6 +90,6 @@ M: ssl ((client)) ( addrspec -- handle ) } case ; M: ssl-handle (wait-to-connect) - handle>> handle>> ! ssl + handle>> ! ssl SSL_connect check-connect-response ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 187c65fac7..276680034c 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -41,7 +41,7 @@ M: integer (wait-to-connect) M: connect-task do-io-task port>> dup handle>> (wait-to-connect) ; -M: integer wait-to-connect ( client-out fd -- ) +M: object wait-to-connect ( client-out fd -- ) drop [ add-io-task ] with-port-continuation pending-error ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index e745616a8e..3b58a606a0 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc -continuations destructors +continuations destructors debugger inspector locals unicode.case openssl.libcrypto openssl.libssl io.nonblocking io.files io.encodings.ascii io.sockets.secure ; @@ -117,10 +117,19 @@ M: openssl-context dispose dup handle>> [ SSL_CTX_free ] when* f >>handle drop ; -TUPLE: ssl-handle file handle ; +TUPLE: ssl-handle file handle disposed ; + +ERROR: no-ssl-context ; + +M: no-ssl-context summary + drop "SSL operations must be wrapped in calls to with-ssl-context" ; + +: current-ssl-context ( -- ctx ) + ssl-context get [ no-ssl-context ] unless* ; : ( fd -- ssl ) - ssl-context get handle>> SSL_new dup ssl-error ssl-handle boa ; + current-ssl-context handle>> SSL_new dup ssl-error + f ssl-handle boa ; : ( fd -- ssl ) [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep @@ -130,7 +139,11 @@ TUPLE: ssl-handle file handle ; M: ssl-handle init-handle drop ; M: ssl-handle close-handle - [ file>> close-handle ] [ handle>> SSL_free ] bi ; + dup disposed>> [ drop ] [ + [ t >>disposed drop ] + [ file>> close-handle ] + [ handle>> SSL_free ] tri + ] if ; ERROR: certificate-verify-error result ; From bece1fdae5cf84bd980c3b535f060a99b43ce51b Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 12 May 2008 19:31:56 -0500 Subject: [PATCH 18/21] add ftp, ftp.server TODO: ftp.server --- extra/ftp/client/client.factor | 20 ++++---- extra/ftp/ftp.factor | 9 ++++ extra/ftp/server/server.factor | 83 ++++++++++++++++++++++++++++++++++ 3 files changed, 100 insertions(+), 12 deletions(-) create mode 100644 extra/ftp/ftp.factor create mode 100644 extra/ftp/server/server.factor diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index fc70f279ed..13cb21d7e4 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -3,18 +3,10 @@ USING: accessors arrays classes.singleton combinators continuations io io.encodings.binary io.encodings.ascii io.files io.sockets kernel io.streams.duplex math -math.parser sequences splitting namespaces strings fry ; +math.parser sequences splitting namespaces strings fry ftp ; IN: ftp.client TUPLE: ftp-client host port user password mode ; -TUPLE: ftp-response n strings parsed ; - -SINGLETON: active -SINGLETON: passive - -: ( -- ftp-response ) - ftp-response new - V{ } clone >>strings ; : ( host -- ftp-client ) ftp-client new @@ -23,6 +15,12 @@ SINGLETON: passive "anonymous" >>user "ftp@my.org" >>password ; +TUPLE: ftp-response n strings parsed ; + +: ( -- ftp-response ) + ftp-response new + V{ } clone >>strings ; + : add-response-line ( ftp-response string -- ftp-response ) over strings>> push ; @@ -44,12 +42,10 @@ SINGLETON: passive [ fourth CHAR: - = ] tri [ read-response-loop ] when ; -: ftp-send ( string -- ) - write "\r\n" write flush ; - : ftp-command ( string -- ftp-response ) ftp-send read-response ; + : ftp-user ( ftp-client -- ftp-response ) user>> "USER " prepend ftp-command ; diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor new file mode 100644 index 0000000000..565f5ce2ff --- /dev/null +++ b/extra/ftp/ftp.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors io kernel math.parser sequences ; +IN: ftp + +SINGLETON: active +SINGLETON: passive + +: ftp-send ( string -- ) write "\r\n" write flush ; diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor new file mode 100644 index 0000000000..9165fa08bd --- /dev/null +++ b/extra/ftp/server/server.factor @@ -0,0 +1,83 @@ +USING: accessors combinators io io.encodings.8-bit +io.server io.sockets kernel sequences ftp +io.unix.launcher.parser unicode.case ; +IN: ftp.server + +TUPLE: ftp-server port ; + +: ( -- ftp-server ) + ftp-server new + 21 >>port ; + +TUPLE: ftp-client-command string tokenized ; +: ( -- obj ) + ftp-client-command new ; + +: read-client-command ( -- ftp-client-command ) + readln + [ >>string ] [ tokenize-command >>tokenized ] bi ; + +: server>client ( string -- ftp-client-command ) + ftp-send read-client-command ; + +: send-banner ( -- ftp-client-command ) + "220 Welcome to " host-name append server>client ; + +: handle-client-loop ( ftp-client-command -- ) + readln + [ >>string ] [ tokenize-command >>tokenized ] bi + first >upper { + ! { "USER" [ ] } + ! { "PASS" [ ] } + ! { "ACCT" [ ] } + ! { "CWD" [ ] } + ! { "CDUP" [ ] } + ! { "SMNT" [ ] } + + ! { "REIN" [ ] } + ! { "QUIT" [ ] } + + ! { "PORT" [ ] } + ! { "PASV" [ ] } + ! { "MODE" [ ] } + ! { "TYPE" [ ] } + ! { "STRU" [ ] } + + ! { "ALLO" [ ] } + ! { "REST" [ ] } + ! { "STOR" [ ] } + ! { "STOU" [ ] } + ! { "RETR" [ ] } + ! { "LIST" [ ] } + ! { "NLST" [ ] } + ! { "LIST" [ ] } + ! { "APPE" [ ] } + ! { "RNFR" [ ] } + ! { "RNTO" [ ] } + ! { "DELE" [ ] } + ! { "RMD" [ ] } + ! { "MKD" [ ] } + ! { "PWD" [ ] } + ! { "ABOR" [ ] } + + ! { "SYST" [ ] } + ! { "STAT" [ ] } + ! { "HELP" [ ] } + + ! { "SITE" [ ] } + ! { "NOOP" [ ] } + } case ; + +: handle-client ( -- ftp-response ) + "" [ + send-banner handle-client-loop + ] with-directory ; + +: ftpd ( port -- ) + internet-server "ftp.server" + latin1 [ handle-client ] with-server ; + +: ftpd-main ( -- ) + 2100 ftpd ; + +MAIN: ftpd-main From eb2cd0b06664f8a3bfc6621f586098f0ba893b1b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 22:30:11 -0500 Subject: [PATCH 19/21] Use OpenSSL MD5 for now, its faster --- extra/bootstrap/image/download/download.factor | 9 ++++++--- extra/bootstrap/image/upload/upload.factor | 6 ++++-- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index 46aca6cc6b..c2e80fee9a 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.image.download -USING: http.client checksums checksums.md5 splitting assocs +USING: http.client checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io ; : url "http://factorcode.org/images/latest/" ; @@ -12,8 +12,11 @@ kernel io.files bootstrap.image sequences io ; : need-new-image? ( image -- ? ) dup exists? - [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ] - [ drop t ] if ; + [ + [ openssl-md5 checksum-file hex-string ] + [ download-checksums at ] + bi = not + ] [ drop t ] if ; : download-image ( arch -- ) boot-image-name dup need-new-image? [ diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 30d0428744..e78c3541d4 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.client checksums checksums.md5 splitting assocs +USING: http.client checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; IN: bootstrap.image.upload @@ -19,7 +19,9 @@ SYMBOL: upload-images-destination : compute-checksums ( -- ) checksums ascii [ boot-image-names [ - [ write bl ] [ md5 checksum-file hex-string print ] bi + [ write bl ] + [ openssl-md5 checksum-file hex-string print ] + bi ] each ] with-file-writer ; From b94a20cc8aca24b88ffa8ee9deb706e485349a02 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 22:30:18 -0500 Subject: [PATCH 20/21] Fix circular dependency --- extra/destructors/destructors.factor | 32 +--------------------- extra/io/nonblocking/nonblocking.factor | 13 +++++++++ extra/io/unix/sockets/secure/secure.factor | 4 ++- extra/io/unix/sockets/sockets.factor | 6 ++-- extra/io/windows/windows.factor | 12 ++++++++ 5 files changed, 32 insertions(+), 35 deletions(-) diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 3013c44327..3d5e19520f 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors continuations io.backend io.nonblocking libc +USING: accessors continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors @@ -49,33 +49,3 @@ M: memory-destructor dispose ( obj -- ) : free-later ( alien -- ) add-error-destructor ; - -! Handles -TUPLE: handle-destructor alien ; - -C: handle-destructor - -M: handle-destructor dispose ( obj -- ) - alien>> close-handle ; - -: close-always ( handle -- ) - add-always-destructor ; - -: close-later ( handle -- ) - add-error-destructor ; - -! Sockets -TUPLE: socket-destructor alien ; - -C: socket-destructor - -HOOK: destruct-socket io-backend ( obj -- ) - -M: socket-destructor dispose ( obj -- ) - alien>> destruct-socket ; - -: close-socket-always ( handle -- ) - add-always-destructor ; - -: close-socket-later ( handle -- ) - add-error-destructor ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index b78cfecbaf..74133e5abb 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -20,6 +20,19 @@ GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) +TUPLE: handle-destructor handle ; + +C: handle-destructor + +M: handle-destructor dispose ( obj -- ) + handle>> close-handle ; + +: close-always ( handle -- ) + add-always-destructor ; + +: close-later ( handle -- ) + add-error-destructor ; + : ( handle class -- port ) new swap dup init-handle >>handle ; inline diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 2aa0792070..e8bcd0e0f0 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -6,11 +6,13 @@ continuations destructors openssl openssl.libcrypto openssl.libssl io.files io.nonblocking io.unix.backend io.unix.sockets io.encodings.ascii io.buffers io.sockets io.sockets.secure -unix.ffi ; +unix ; IN: io.unix.sockets.secure ! todo: SSL_pending, rehandshake ! do we call write twice, wth 0 bytes at the end? +! check-certificate at some point +! test on windows M: ssl-handle handle-fd file>> ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 9d02b4b151..fee4821f50 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -3,9 +3,9 @@ USING: alien alien.c-types alien.strings generic kernel math namespaces threads sequences byte-arrays io.nonblocking io.binary io.unix.backend io.streams.duplex io.sockets.impl -io.backend io.files io.files.private io.encodings.utf8 -math.parser continuations libc combinators system accessors -qualified unix ; +io.backend io.nonblocking io.files io.files.private +io.encodings.utf8 math.parser continuations libc combinators +system accessors qualified destructors unix ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index c2718c4189..6f793bc939 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -175,6 +175,18 @@ USE: windows.winsock [ server-sockaddr ] keep sockaddr-type heap-size bind socket-error ; +TUPLE: socket-destructor alien ; + +C: socket-destructor + +HOOK: destruct-socket io-backend ( obj -- ) + +M: socket-destructor dispose ( obj -- ) + alien>> destruct-socket ; + +: close-socket-later ( handle -- ) + add-error-destructor ; + : server-fd ( addrspec type -- fd ) >r dup protocol-family r> open-socket dup close-socket-later From fe456dd95720622449c5df0819230e9a6630946e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 22:30:48 -0500 Subject: [PATCH 21/21] Fix docs --- extra/destructors/destructors-docs.factor | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index f96931c412..e9f6002efa 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -11,16 +11,6 @@ HELP: free-later { $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." } { $see-also free-always } ; -HELP: close-always -{ $values { "handle" "an OS-dependent handle" } } -{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." } -{ $see-also close-later } ; - -HELP: close-later -{ $values { "handle" "an OS-dependent handle" } } -{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." } -{ $see-also close-always } ; - HELP: with-destructors { $values { "quot" "a quotation" } } { $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }