steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
erg 2008-05-12 19:32:46 -05:00
parent bece1fdae5 707e6bf142
commit 17c95bcec6
68 changed files with 1615 additions and 1802 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/c-types/c-types.factor
View File

@ -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

5
core/checksums/checksums-docs.factor
View File

@ -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"

2
core/continuations/continuations-tests.factor
View File

@ -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

12
core/continuations/continuations.factor
View File

@ -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 -- )

2
core/debugger/debugger.factor
View File

@ -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 ( -- )

2
core/inference/known-words/known-words.factor
View File

@ -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
core/io/files/files-tests.factor
View File

@ -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

1
core/io/io.factor
View File

@ -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 ;

13
core/kernel/kernel-docs.factor
View File

@ -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:"

4
core/kernel/kernel.factor
View File

@ -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

3
core/libc/libc.factor
View File

@ -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 ;

7
extra/cairo/cairo-tests.factor
View File

@ -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

984
extra/cairo/cairo.factor Normal file → Executable file
View File

@ -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

1080
extra/cairo/ffi/ffi.factor
View File

File diff suppressed because it is too large Load Diff

2
extra/cairo/gadgets/gadgets.factor
View File

@ -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 ;

36
extra/cairo/lib/lib.factor
View File

@ -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

11
extra/cairo/samples/samples.factor
View File

@ -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
extra/checksums/adler-32/adler-32-docs.factor
View File

@ -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
extra/checksums/md5/md5-docs.factor
View File

@ -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" } ")."

35
extra/checksums/openssl/openssl-docs.factor Normal file
View File

@ -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"

28
extra/checksums/openssl/openssl-tests.factor Normal file
View File

@ -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

63
extra/checksums/openssl/openssl.factor Normal file
View File

@ -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
extra/checksums/sha1/sha1-docs.factor
View File

@ -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
extra/checksums/sha2/sha2-docs.factor
View File

@ -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."

1
extra/db/postgresql/ffi/ffi.factor
View File

@ -52,7 +52,6 @@ IN: db.postgresql.ffi
: InvalidOid 0 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
TYPEDEF: int PostgresPollingStatusType

48
extra/destructors/destructors.factor
View File

@ -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 io.nonblocking 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,19 +27,28 @@ M: destructor dispose
[ do-error-destructors ] cleanup
] with-scope ; inline
TUPLE: only-once object destroyed ;
M: only-once dispose
dup destroyed>> [ drop ] [
[ object>> dispose ] [ t >>destroyed drop ] bi
] if ;
: <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 ;
<memory-destructor> <only-once> add-error-destructor ;
! Handles
TUPLE: handle-destructor alien ;
@ -60,13 +56,13 @@ TUPLE: handle-destructor alien ;
C: <handle-destructor> handle-destructor
M: handle-destructor dispose ( obj -- )
handle-destructor-alien close-handle ;
alien>> close-handle ;
: close-always ( handle -- )
<handle-destructor> add-always-destructor ;
<handle-destructor> <only-once> add-always-destructor ;
: close-later ( handle -- )
<handle-destructor> add-error-destructor ;
<handle-destructor> <only-once> add-error-destructor ;
! Sockets
TUPLE: socket-destructor alien ;
@ -76,10 +72,10 @@ C: <socket-destructor> socket-destructor
HOOK: destruct-socket io-backend ( obj -- )
M: socket-destructor dispose ( obj -- )
socket-destructor-alien destruct-socket ;
alien>> destruct-socket ;
: close-socket-always ( handle -- )
<socket-destructor> add-always-destructor ;
<socket-destructor> <only-once> add-always-destructor ;
: close-socket-later ( handle -- )
<socket-destructor> add-error-destructor ;
<socket-destructor> <only-once> add-error-destructor ;

2
extra/http/http.factor
View File

@ -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?

6
extra/io/launcher/launcher.factor
View File

@ -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 ;

8
extra/io/nonblocking/nonblocking-docs.factor
View File

@ -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 ;

22
extra/io/nonblocking/nonblocking.factor
View File

@ -3,7 +3,8 @@
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
dlists assocs io.encodings.binary inspector accessors ;
dlists assocs io.encodings.binary inspector accessors
destructors ;
IN: io.nonblocking
SYMBOL: default-buffer-size
@ -29,16 +30,19 @@ GENERIC: close-handle ( handle -- )
TUPLE: input-port < port ;
: <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 +61,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 +130,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

8
extra/io/pipes/pipes.factor
View File

@ -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 )

5
extra/io/sockets/secure/secure-tests.factor Normal file
View File

@ -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

38
extra/io/sockets/secure/secure.factor Normal file
View File

@ -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>

28
extra/io/sockets/sockets.factor
View File

@ -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) ;

49
extra/io/unix/backend/backend.factor
View File

@ -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 ;

4
extra/io/unix/epoll/epoll.factor
View File

@ -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 ;

6
extra/io/unix/files/files.factor
View File

@ -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

4
extra/io/unix/kqueue/kqueue.factor
View File

@ -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

12
extra/io/unix/select/select.factor
View File

@ -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 ;

95
extra/io/unix/sockets/secure/secure.factor Normal file
View File

@ -0,0 +1,95 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
continuations destructors
openssl openssl.libcrypto openssl.libssl
io.files io.nonblocking io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix.ffi ;
IN: io.unix.sockets.secure
! todo: SSL_pending, rehandshake
! do we call write twice, wth 0 bytes at the end?
M: ssl-handle 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 ;

62
extra/io/unix/sockets/sockets.factor
View File

@ -12,15 +12,11 @@ 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 -- )
@ -71,10 +66,7 @@ TUPLE: accept-task < input-task ;
dup <c-object> [ swap heap-size <int> accept ] keep ; inline
: do-accept ( port fd sockaddr -- )
rot
[ server-port-addr parse-sockaddr ] keep
[ set-server-port-client-addr ] keep
set-server-port-client ;
swapd over addr>> parse-sockaddr >>client-addr (>>client) ;
M: accept-task do-io-task
io-task-port dup accept-sockaddr
@ -83,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.
@ -102,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

15
extra/io/unix/unix.factor
View File

@ -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

2
extra/io/windows/ce/backend/backend.factor
View File

@ -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 ;

4
extra/io/windows/ce/sockets/sockets.factor
View File

@ -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 )

4
extra/io/windows/nt/files/files.factor
View File

@ -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 ;

19
extra/io/windows/nt/sockets/sockets.factor
View File

@ -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 ;

14
extra/io/windows/windows.factor
View File

@ -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 ;

5
extra/jamshred/tunnel/tunnel-tests.factor
View File

@ -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

8
extra/jamshred/tunnel/tunnel.factor
View File

@ -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
extra/lisp/lisp-tests.factor
View File

@ -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

24
extra/lisp/lisp.factor
View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

0
unmaintained/openssl/authors.txt → extra/openssl/authors.txt
View File

45
unmaintained/openssl/libcrypto/libcrypto.factor → extra/openssl/libcrypto/libcrypto.factor
View File

@ -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
! ===============================================

67
unmaintained/openssl/libssl/libssl.factor → extra/openssl/libssl/libssl.factor
View File

@ -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

20
extra/openssl/openssl-tests.factor Executable file
View File

@ -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

172
extra/openssl/openssl.factor Executable file
View File

@ -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

0
unmaintained/openssl/summary.txt → extra/openssl/summary.txt
View File

0
unmaintained/openssl/tags.txt → extra/openssl/tags.txt
View File

0
unmaintained/openssl/test/dh1024.pem → extra/openssl/test/dh1024.pem
View File

0
unmaintained/openssl/test/errors.txt → extra/openssl/test/errors.txt
View File

0
unmaintained/openssl/test/root.pem → extra/openssl/test/root.pem
View File

0
unmaintained/openssl/test/server.pem → extra/openssl/test/server.pem
View File

1
extra/oracle/liboci/liboci.factor
View File

@ -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)

1
extra/unix/unix.factor
View File

@ -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

1
extra/windows/types/types.factor
View File

@ -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

10
unmaintained/openssl/openssl-docs.factor
View File

@ -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" } ;

146
unmaintained/openssl/openssl-tests.factor
View File

@ -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

154
unmaintained/openssl/openssl.factor
View File

@ -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 ;