From 2ddc0028f08740af704f5b47c46f43ea142e61f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 11 May 2008 17:41:54 -0500 Subject: [PATCH 01/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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/19] 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 0c83995f62ade144ef56a20ba17a35028d3b1ec3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 12 May 2008 18:39:45 -0500 Subject: [PATCH 16/19] io.unix.sockets: cleanup do-accept --- extra/io/unix/sockets/sockets.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index c9fc9905a8..741e10f7a6 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -71,10 +71,7 @@ TUPLE: accept-task < input-task ; dup [ swap heap-size accept ] keep ; inline : do-accept ( port fd sockaddr -- ) - rot - [ server-port-addr parse-sockaddr ] keep - [ set-server-port-client-addr ] keep - set-server-port-client ; + swapd over addr>> parse-sockaddr >>client-addr (>>client) ; M: accept-task do-io-task io-task-port dup accept-sockaddr From 881739eda7426554ae20d5c81f120a91983b69dd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 12 May 2008 18:40:20 -0500 Subject: [PATCH 17/19] And indent... --- extra/io/unix/sockets/sockets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 741e10f7a6..ba0dedf0cc 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -71,7 +71,7 @@ TUPLE: accept-task < input-task ; dup [ swap heap-size accept ] keep ; inline : do-accept ( port fd sockaddr -- ) - swapd over addr>> parse-sockaddr >>client-addr (>>client) ; + swapd over addr>> parse-sockaddr >>client-addr (>>client) ; M: accept-task do-io-task io-task-port dup accept-sockaddr From 1260c1ba51c0af13953017f046537f03a96efa79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 May 2008 18:53:22 -0500 Subject: [PATCH 18/19] 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 19/19] 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 ;