Merge branch 'master' of factorcode.org:/git/factor
Eduardo Cavazos
commit
141ff8334a
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
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
|
||||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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" } ")."
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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" } ")."
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -52,7 +52,6 @@ IN: db.postgresql.ffi
|
|||
|
||||
: InvalidOid 0 ; inline
|
||||
|
||||
TYPEDEF: int size_t
|
||||
TYPEDEF: int ConnStatusType
|
||||
TYPEDEF: int ExecStatusType
|
||||
TYPEDEF: int PostgresPollingStatusType
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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>
|
||||
|
|
@ -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) ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
! ===============================================
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
Loading…
Reference in New Issue