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/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/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/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" ;
+
<PRIVATE
: init-debugger ( -- )
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 } { } <effect> set-primitive-effect
-\ exists? { string } { object } <effect> set-primitive-effect
+\ (exists?) { string } { object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> 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
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 ;
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/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 ;
diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor
index 46aca6cc6b..c2e80fee9a 100644
--- a/extra/bootstrap/image/download/download.factor
+++ b/extra/bootstrap/image/download/download.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
-USING: http.client checksums checksums.md5 splitting assocs
+USING: http.client checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
@@ -12,8 +12,11 @@ kernel io.files bootstrap.image sequences io ;
: need-new-image? ( image -- ? )
dup exists?
- [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
- [ drop t ] if ;
+ [
+ [ openssl-md5 checksum-file hex-string ]
+ [ download-checksums at ]
+ bi = not
+ ] [ drop t ] if ;
: download-image ( arch -- )
boot-image-name dup need-new-image? [
diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor
index 30d0428744..e78c3541d4 100755
--- a/extra/bootstrap/image/upload/upload.factor
+++ b/extra/bootstrap/image/upload/upload.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: http.client checksums checksums.md5 splitting assocs
+USING: http.client checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
@@ -19,7 +19,9 @@ SYMBOL: upload-images-destination
: compute-checksums ( -- )
checksums ascii [
boot-image-names [
- [ write bl ] [ md5 checksum-file hex-string print ] bi
+ [ write bl ]
+ [ openssl-md5 checksum-file hex-string print ]
+ bi
] each
] with-file-writer ;
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..077152a3c2
--- 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 ;
-
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cairo.ffi kernel accessors sequences
+namespaces fry continuations ;
IN: cairo
-<< "cairo" {
- { [ os winnt? ] [ "libcairo-2.dll" ] }
- { [ os macosx? ] [ "libcairo.dylib" ] }
- { [ os unix? ] [ "libcairo.so.2" ] }
-} cond "cdecl" add-library >>
-LIBRARY: cairo
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-FUNCTION: int cairo_version ( ) ;
-FUNCTION: char* cairo_version_string ( ) ;
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
-TYPEDEF: int cairo_bool_t
+: check-cairo ( cairo_status_t -- )
+ dup CAIRO_STATUS_SUCCESS = [ drop ]
+ [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
-! I am leaving these and other void* types as opaque structures
-TYPEDEF: void* cairo_t
-TYPEDEF: void* cairo_surface_t
+SYMBOL: cairo
+: cr ( -- cairo ) cairo get ;
-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" } ;
-
-: <cairo-rect> ( x y width height -- cairo_rectangle_t )
- "cairo_rectangle_t" <c-object> dup
- {
- [ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ]
- [ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ]
- } cleave ;
+: (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@
- <cairo-rect> ;
+: with-cairo ( cairo quot -- )
+ >r <cairo-t> 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@ <rect> ;
-
-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 <cairo-surface-t> 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..451806c0a7 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: system combinators alien alien.syntax kernel
+alien.c-types accessors sequences arrays ui.gadgets ;
-USING: alien alien.syntax combinators system ;
IN: cairo.ffi
-
<< "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,326 @@ 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" } ;
+
+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 +395,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 +403,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/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/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> cairo-t
-M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-
-TUPLE: cairo-surface-t alien ;
-C: <cairo-surface-t> 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 <cairo-t> 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 <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
-
-: with-cairo-from-surface ( cairo_surface quot -- )
- '[ cairo_create , with-cairo ] with-surface ; inline
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 <cached-cairo> gadget. ] each ;
+
+ MAIN: samples
\ No newline at end of file
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/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: <openssl-checksum> ( 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 <openssl-checksum> }
+"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" <openssl-checksum> 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" <openssl-checksum> checksum-bytes
+] unit-test
+
+[
+ "Bad checksum test" >byte-array
+ "no such checksum" <openssl-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> openssl-checksum
+
+<PRIVATE
+
+TUPLE: evp-md-context handle ;
+
+: <evp-md-context> ( -- ctx )
+ "EVP_MD_CTX" <c-object>
+ 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 <evp-md-context> 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 <byte-array> 0 <int>
+ [ 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 ;
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."
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index ee5ba622e5..3686afa80c 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -52,7 +52,6 @@ IN: db.postgresql.ffi
: InvalidOid 0 ; inline
-TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
TYPEDEF: int PostgresPollingStatusType
diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor
index f96931c412..e9f6002efa 100755
--- a/extra/destructors/destructors-docs.factor
+++ b/extra/destructors/destructors-docs.factor
@@ -11,16 +11,6 @@ HELP: free-later
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
{ $see-also free-always } ;
-HELP: close-always
-{ $values { "handle" "an OS-dependent handle" } }
-{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." }
-{ $see-also close-later } ;
-
-HELP: close-later
-{ $values { "handle" "an OS-dependent handle" } }
-{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." }
-{ $see-also close-always } ;
-
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor
index 6fc7ab249f..3d5e19520f 100755
--- a/extra/destructors/destructors.factor
+++ b/extra/destructors/destructors.factor
@@ -1,30 +1,17 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations io.backend io.nonblocking libc kernel
-namespaces sequences system vectors ;
+USING: accessors continuations io.backend libc
+kernel namespaces sequences system vectors ;
IN: destructors
SYMBOL: error-destructors
SYMBOL: always-destructors
-TUPLE: destructor object destroyed? ;
-
-M: destructor dispose
- dup destructor-destroyed? [
- drop
- ] [
- dup destructor-object dispose
- t swap set-destructor-destroyed?
- ] if ;
-
-: <destructor> ( obj -- newobj )
- f destructor boa ;
-
: add-error-destructor ( obj -- )
- <destructor> error-destructors get push ;
+ error-destructors get push ;
: add-always-destructor ( obj -- )
- <destructor> always-destructors get push ;
+ always-destructors get push ;
: do-always-destructors ( -- )
always-destructors get <reversed> dispose-each ;
@@ -40,46 +27,25 @@ 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 ;
+
+: <only-once> f only-once boa ;
+
! Memory allocations
TUPLE: memory-destructor alien ;
C: <memory-destructor> memory-destructor
M: memory-destructor dispose ( obj -- )
- memory-destructor-alien free ;
+ alien>> free ;
: free-always ( alien -- )
- <memory-destructor> add-always-destructor ;
+ <memory-destructor> <only-once> add-always-destructor ;
: free-later ( alien -- )
- <memory-destructor> add-error-destructor ;
-
-! Handles
-TUPLE: handle-destructor alien ;
-
-C: <handle-destructor> handle-destructor
-
-M: handle-destructor dispose ( obj -- )
- handle-destructor-alien close-handle ;
-
-: close-always ( handle -- )
- <handle-destructor> add-always-destructor ;
-
-: close-later ( handle -- )
- <handle-destructor> add-error-destructor ;
-
-! Sockets
-TUPLE: socket-destructor alien ;
-
-C: <socket-destructor> socket-destructor
-
-HOOK: destruct-socket io-backend ( obj -- )
-
-M: socket-destructor dispose ( obj -- )
- socket-destructor-alien destruct-socket ;
-
-: close-socket-always ( handle -- )
- <socket-destructor> add-always-destructor ;
-
-: close-socket-later ( handle -- )
- <socket-destructor> add-error-destructor ;
+ <memory-destructor> <only-once> add-error-destructor ;
diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index fc70f279ed..13cb21d7e4 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -3,18 +3,10 @@
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.ascii
io.files io.sockets kernel io.streams.duplex math
-math.parser sequences splitting namespaces strings fry ;
+math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client
TUPLE: ftp-client host port user password mode ;
-TUPLE: ftp-response n strings parsed ;
-
-SINGLETON: active
-SINGLETON: passive
-
-: <ftp-response> ( -- ftp-response )
- ftp-response new
- V{ } clone >>strings ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
@@ -23,6 +15,12 @@ SINGLETON: passive
"anonymous" >>user
"ftp@my.org" >>password ;
+TUPLE: ftp-response n strings parsed ;
+
+: <ftp-response> ( -- ftp-response )
+ ftp-response new
+ V{ } clone >>strings ;
+
: add-response-line ( ftp-response string -- ftp-response )
over strings>> push ;
@@ -44,12 +42,10 @@ SINGLETON: passive
[ fourth CHAR: - = ] tri
[ read-response-loop ] when ;
-: ftp-send ( string -- )
- write "\r\n" write flush ;
-
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
+
: ftp-user ( ftp-client -- ftp-response )
user>> "USER " prepend ftp-command ;
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
new file mode 100644
index 0000000000..565f5ce2ff
--- /dev/null
+++ b/extra/ftp/ftp.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io kernel math.parser sequences ;
+IN: ftp
+
+SINGLETON: active
+SINGLETON: passive
+
+: ftp-send ( string -- ) write "\r\n" write flush ;
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
new file mode 100644
index 0000000000..9165fa08bd
--- /dev/null
+++ b/extra/ftp/server/server.factor
@@ -0,0 +1,83 @@
+USING: accessors combinators io io.encodings.8-bit
+io.server io.sockets kernel sequences ftp
+io.unix.launcher.parser unicode.case ;
+IN: ftp.server
+
+TUPLE: ftp-server port ;
+
+: <ftp-server> ( -- ftp-server )
+ ftp-server new
+ 21 >>port ;
+
+TUPLE: ftp-client-command string tokenized ;
+: <ftp-client-command> ( -- obj )
+ ftp-client-command new ;
+
+: read-client-command ( -- ftp-client-command )
+ <ftp-client-command> readln
+ [ >>string ] [ tokenize-command >>tokenized ] bi ;
+
+: server>client ( string -- ftp-client-command )
+ ftp-send read-client-command ;
+
+: send-banner ( -- ftp-client-command )
+ "220 Welcome to " host-name append server>client ;
+
+: handle-client-loop ( ftp-client-command -- )
+ <ftp-client-command> readln
+ [ >>string ] [ tokenize-command >>tokenized ] bi
+ first >upper {
+ ! { "USER" [ ] }
+ ! { "PASS" [ ] }
+ ! { "ACCT" [ ] }
+ ! { "CWD" [ ] }
+ ! { "CDUP" [ ] }
+ ! { "SMNT" [ ] }
+
+ ! { "REIN" [ ] }
+ ! { "QUIT" [ ] }
+
+ ! { "PORT" [ ] }
+ ! { "PASV" [ ] }
+ ! { "MODE" [ ] }
+ ! { "TYPE" [ ] }
+ ! { "STRU" [ ] }
+
+ ! { "ALLO" [ ] }
+ ! { "REST" [ ] }
+ ! { "STOR" [ ] }
+ ! { "STOU" [ ] }
+ ! { "RETR" [ ] }
+ ! { "LIST" [ ] }
+ ! { "NLST" [ ] }
+ ! { "LIST" [ ] }
+ ! { "APPE" [ ] }
+ ! { "RNFR" [ ] }
+ ! { "RNTO" [ ] }
+ ! { "DELE" [ ] }
+ ! { "RMD" [ ] }
+ ! { "MKD" [ ] }
+ ! { "PWD" [ ] }
+ ! { "ABOR" [ ] }
+
+ ! { "SYST" [ ] }
+ ! { "STAT" [ ] }
+ ! { "HELP" [ ] }
+
+ ! { "SITE" [ ] }
+ ! { "NOOP" [ ] }
+ } case ;
+
+: handle-client ( -- ftp-response )
+ "" [
+ send-banner handle-client-loop
+ ] with-directory ;
+
+: ftpd ( port -- )
+ internet-server "ftp.server"
+ latin1 [ handle-client ] with-server ;
+
+: ftpd-main ( -- )
+ 2100 ftpd ;
+
+MAIN: ftpd-main
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/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>> <reader> ]
+ [ in>> <input-port> ]
} cleave r> <decoder>
] with-destructors ;
@@ -182,7 +182,7 @@ M: object run-pipeline-element
run-detached
]
[ in>> close-handle ]
- [ out>> <writer> ]
+ [ out>> <output-port> ]
} cleave r> <encoder>
] with-destructors ;
@@ -200,7 +200,7 @@ M: object run-pipeline-element
run-detached
]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
- [ [ in>> <reader> ] [ out>> <writer> ] bi* ]
+ [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
] 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 <buffered-port> }
"Input ports:"
{ $subsection input-port }
-{ $subsection <reader> }
+{ $subsection <input-port> }
"Output ports:"
{ $subsection output-port }
-{ $subsection <writer> }
+{ $subsection <output-port> }
"Global native I/O protocol:"
{ $subsection io-backend }
{ $subsection init-io }
@@ -62,12 +62,12 @@ HELP: <buffered-port>
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
$low-level-note ;
-HELP: <reader>
+HELP: <input-port>
{ $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: <writer>
+HELP: <output-port>
{ $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 d25d4b7050..74133e5abb 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
@@ -19,6 +20,19 @@ GENERIC: init-handle ( handle -- )
GENERIC: close-handle ( handle -- )
+TUPLE: handle-destructor handle ;
+
+C: <handle-destructor> handle-destructor
+
+M: handle-destructor dispose ( obj -- )
+ handle>> close-handle ;
+
+: close-always ( handle -- )
+ <handle-destructor> <only-once> add-always-destructor ;
+
+: close-later ( handle -- )
+ <handle-destructor> <only-once> add-error-destructor ;
+
: <port> ( handle class -- port )
new
swap dup init-handle >>handle ; inline
@@ -29,16 +43,19 @@ GENERIC: close-handle ( handle -- )
TUPLE: input-port < port ;
-: <reader> ( handle -- input-port )
+: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
TUPLE: output-port < port ;
-: <writer> ( handle -- output-port )
+: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
-: <reader&writer> ( read-handle write-handle -- input-port output-port )
- swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
+: <ports> ( read-handle write-handle -- input-port output-port )
+ [
+ [ <input-port> dup add-error-destructor ]
+ [ <output-port> dup add-error-destructor ] bi*
+ ] with-destructors ;
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
@@ -57,7 +74,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 +143,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/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>> <reader> ]
- [ out>> <writer> ]
+ [ in>> <input-port> ]
+ [ out>> <output-port> ]
tri
r> <encoder-duplex>
] with-destructors ;
<PRIVATE
-: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
-: ?writer [ <writer> dup add-always-destructor ] [ output-stream get ] if* ;
+: ?reader [ <input-port> dup add-always-destructor ] [ input-stream get ] if* ;
+: ?writer [ <output-port> 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-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 ;
+
+\ <ssl-config> 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..6cd711da81
--- /dev/null
+++ b/extra/io/sockets/secure/secure.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel symbols namespaces continuations
+io.sockets sequences ;
+IN: io.sockets.secure
+
+SYMBOL: ssl-backend
+
+SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
+
+TUPLE: ssl-config method key-file ca-file ca-path password ;
+
+: <ssl-config> ( -- config )
+ ssl-config new
+ SSLv23 >>method ;
+
+TUPLE: ssl-context config handle ;
+
+HOOK: <ssl-context> ssl-backend ( config -- context )
+
+: with-ssl-context ( config quot -- )
+ [
+ [ <ssl-context> ] [ [ ssl-context set ] prepose ] bi*
+ with-disposal
+ ] with-scope ; inline
+
+TUPLE: ssl addrspec ;
+
+C: <ssl> ssl
+
+<PRIVATE
+
+PREDICATE: ssl-inet < ssl addrspec>> inet? ;
+
+M: ssl-inet (client)
+ addrspec>> resolve-client-addr [ <ssl> ] 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> 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 <ports>
+ 2dup [ add-error-destructor ] bi@
+ dup dup handle>> wait-to-connect
+ ] with-destructors ;
: <client> ( addrspec encoding -- stream )
>r (client) r> <encoder-duplex> ;
@@ -42,7 +52,7 @@ HOOK: (server) io-backend ( addrspec -- handle )
HOOK: (accept) io-backend ( server -- addrspec handle )
: accept ( server -- client addrspec )
- [ (accept) dup <reader&writer> ] [ encoding>> ] bi
+ [ (accept) dup <ports> ] [ encoding>> ] bi
<encoder-duplex> swap ;
HOOK: <datagram> 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 08ff526f14..652d4e77b3 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 ;
: <io-task> ( 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,33 +132,36 @@ 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 ;
-: <read-task> ( port continuation -- task )
- read-task <io-task> ;
+: <read-task> ( port continuation -- task ) read-task <io-task> ;
M: read-task do-io-task
- io-task-port dup refill
+ port>> dup dup handle>> refill
[ [ reader-eof ] [ drop ] if ] keep ;
-M: input-port (wait-to-read)
+M: unix (wait-to-read)
[ <read-task> add-io-task ] with-port-continuation
pending-error ;
! Writers
-: write-step ( port -- ? )
+GENERIC: drain ( port handle -- ? )
+
+M: integer drain
+ drop
dup
[ handle>> ]
[ buffer>> buffer@ ]
@@ -164,12 +172,11 @@ M: input-port (wait-to-read)
TUPLE: write-task < output-task ;
-: <write-task> ( port continuation -- task )
- write-task <io-task> ;
+: <write-task> ( port continuation -- task ) write-task <io-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*
@@ -179,16 +186,16 @@ 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 -- )
mx get-global wait-for-events ;
M: unix (init-stdio) ( -- )
- 0 <reader>
- 1 <writer>
- 2 <writer> ;
+ 0 <input-port>
+ 1 <output-port>
+ 2 <output-port> ;
! 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 e1da20be46..835b14e66d 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 <reader> ;
+ open-read <input-port> ;
: 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 <writer> ;
+ open-write <output-port> ;
: 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 <writer> ;
+ open-append <output-port> ;
: 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 8e8fb0ec74..ad5240e548 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..e8bcd0e0f0
--- /dev/null
+++ b/extra/io/unix/sockets/secure/secure.factor
@@ -0,0 +1,97 @@
+! 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 ;
+IN: io.unix.sockets.secure
+
+! todo: SSL_pending, rehandshake
+! do we call write twice, wth 0 bytes at the end?
+! check-certificate at some point
+! test on windows
+
+M: ssl-handle handle-fd file>> ;
+
+: 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)) <ssl-socket> ] 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>> ! ssl
+ SSL_connect
+ check-connect-response ;
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index ba0dedf0cc..fee4821f50 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -3,24 +3,20 @@
USING: alien alien.c-types alien.strings generic kernel math
namespaces threads sequences byte-arrays io.nonblocking
io.binary io.unix.backend io.streams.duplex io.sockets.impl
-io.backend io.files io.files.private io.encodings.utf8
-math.parser continuations libc combinators system accessors
-qualified unix ;
+io.backend io.nonblocking io.files io.files.private
+io.encodings.utf8 math.parser continuations libc combinators
+system accessors qualified destructors unix ;
EXCLUDE: io => read write close ;
EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets
-: pending-init-error ( port -- )
- #! We close it here to avoid a resource leak; callers of
- #! <client> don't set up error handlers until after <client>
- #! 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> "int" heap-size setsockopt io-error ;
@@ -37,25 +33,24 @@ TUPLE: connect-task < output-task ;
: <connect-task> ( port continuation -- task )
connect-task <io-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 -- )
- [ <connect-task> add-io-task ] with-port-continuation drop ;
+M: object wait-to-connect ( client-out fd -- )
+ drop
+ [ <connect-task> 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 <reader&writer>
- 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 -- )
@@ -80,15 +75,17 @@ M: accept-task do-io-task
: wait-to-accept ( server -- )
[ <accept-task> 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.
@@ -99,7 +96,9 @@ M: unix (accept) ( server -- addrspec handle )
! Datagram sockets - UDP and Unix domain
M: unix <datagram>
- [ SOCK_DGRAM server-fd ] keep <datagram-port> ;
+ [
+ [ SOCK_DGRAM server-socket-fd ] keep <datagram-port>
+ ] 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 <win32-file> ] 3apply
- rot <reader> -rot [ <writer> ] bi@
+ [ <input-port> ] [ <output-port> ] [ <output-port> ] 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 <win32-socket> dup <reader&writer> ;
+ do-connect <win32-socket> dup <ports> ;
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
- <win32-socket> <reader&writer>
+ <win32-socket> <ports>
] with-timeout ;
M: wince <datagram> ( addrspec -- datagram )
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 ;
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* <win32-socket> dup <reader&writer>
- >r [ connect-continuation ] keep [ pending-error ] keep r>
+ dup [ ConnectEx-args-s* ] [ ConnectEx-args-lpOverlapped* ] bi <win32-socket>
] 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* <win32-socket> ;
+ [ AcceptEx-args-sAcceptSocket* ] [ AcceptEx-args-lpOverlapped* ] bi <win32-socket> ;
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
- <win32-socket>
+ f <win32-socket>
] with-destructors ;
M: winnt <datagram> ( addrspec -- datagram )
@@ -143,7 +146,7 @@ M: winnt <datagram> ( addrspec -- datagram )
[
SOCK_DGRAM server-fd
dup add-completion
- <win32-socket>
+ f <win32-socket>
] keep <datagram-port>
] with-destructors ;
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 85c448bdbd..6f793bc939 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -123,13 +123,13 @@ C: <FileArgs> FileArgs
FileArgs-lpOverlapped ;
M: windows (file-reader) ( path -- stream )
- open-read <win32-file> <reader> ;
+ open-read <win32-file> <input-port> ;
M: windows (file-writer) ( path -- stream )
- open-write <win32-file> <writer> ;
+ open-write <win32-file> <output-port> ;
M: windows (file-appender) ( path -- stream )
- open-append <win32-file> <writer> ;
+ open-append <win32-file> <output-port> ;
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 ;
-: <win32-socket> ( handle -- win32-socket )
- f win32-file boa ;
+: <win32-socket> ( 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 ;
@@ -173,6 +175,18 @@ USE: windows.winsock
[ server-sockaddr ] keep
sockaddr-type heap-size bind socket-error ;
+TUPLE: socket-destructor alien ;
+
+C: <socket-destructor> socket-destructor
+
+HOOK: destruct-socket io-backend ( obj -- )
+
+M: socket-destructor dispose ( obj -- )
+ alien>> destruct-socket ;
+
+: close-socket-later ( handle -- )
+ <socket-destructor> <only-once> add-error-destructor ;
+
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket
dup close-socket-later
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> 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 )
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
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 7d4b9af02a..52faf59c17 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 <lambda> ] dip
+ [ , cut swap [ % , ] bake , compose ] bake ;
+
+: normal-lambda ( body vars -- quot )
+ localize-lambda <lambda> [ , compose ] bake ;
: convert-lambda ( s-exp -- quot )
- split-lambda dup "&rest" swap member? [ rest-lambda-vars ] [ dup length ] if
- [ localize-lambda <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,12 +67,11 @@ 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 ;
+ lisp-expr parse-result-ast convert-form lambda-rewrite call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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/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 [
+ [ ] [
+ <ssl-config>
+ "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
+
+ [
+ <ssl-config>
+ "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..3b58a606a0
--- /dev/null
+++ b/extra/openssl/openssl.factor
@@ -0,0 +1,172 @@
+! 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 debugger inspector
+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-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-string throw ] 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 <ssl-context> ( 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-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* ;
+
+: <ssl-handle> ( fd -- ssl )
+ current-ssl-context handle>> SSL_new dup ssl-error
+ f ssl-handle boa ;
+
+: <ssl-socket> ( fd -- ssl )
+ [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
+ <ssl-handle>
+ [ handle>> swap dup SSL_set_bio ] keep ;
+
+M: ssl-handle init-handle drop ;
+
+M: ssl-handle close-handle
+ dup disposed>> [ drop ] [
+ [ t >>disposed drop ]
+ [ file>> close-handle ]
+ [ handle>> SSL_free ] tri
+ ] if ;
+
+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 <byte-array>
+ [ 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/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 3458819ba8..71e8dba8e6 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
diff --git a/unmaintained/openssl/openssl-docs.factor b/unmaintained/openssl/openssl-docs.factor
deleted file mode 100644
index dd31bfd001..0000000000
--- a/unmaintained/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
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 )
-! <enum> >alist [ nip ] assoc-filter >hashtable keys ;
-!
-! ! 1234 server-socket sock set
-! "127.0.0.1" 1234 <inet4> SOCK_STREAM server-fd sock set
-!
-! FD_SETSIZE 8 * <bit-array> fdset set
-!
-! FD_SETSIZE 8 * <bit-array> 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" <c-array> [ MD5 ] keep nip ;
-
-: >sha1 ( str -- byte-array )
- dup length 20 "uchar" <c-array> [ SHA1 ] keep nip ;
-