From 0c8d14537879f577904dc7c7dbe78b8636c2cc89 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 24 May 2008 20:03:31 -0700 Subject: [PATCH 01/16] changed "cairo.pango.gadgets" run to use Japanese --- extra/cairo/pango/gadgets/gadgets.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 780881e872..48e5e683a9 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -12,8 +12,8 @@ IN: cairo.pango.gadgets USING: prettyprint sequences ui.gadgets.panes ; : hello-pango ( -- ) 50 [ 6 + ] map [ - "Sans Bold " swap unparse append - [ layout-font "Hello, Pango!" layout-text ] curry + "Sans " swap unparse append + [ layout-font "今日は、 Pango!" layout-text ] curry gadget. ] each ; From d5f6cf4d057cd4e9d9ddaa4658bbb3cfde0b594b Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 24 May 2008 20:04:12 -0700 Subject: [PATCH 02/16] Initial commit of GL texture gadgets --- extra/cairo/gadgets/gadgets.factor | 59 +++++++++++++++++++++--------- 1 file changed, 42 insertions(+), 17 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index e0daefd63c..fa5364557e 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: cairo cairo.ffi ui.render kernel opengl.gl opengl math byte-arrays ui.gadgets accessors arrays -namespaces io.backend ; +namespaces io.backend memoize ; IN: cairo.gadgets @@ -10,7 +10,7 @@ IN: cairo.gadgets ! one performs the cairo ops once and caches the bytes, the other ! performs cairo ops every refresh -TUPLE: cairo-gadget width height quot cache? bytes ; +TUPLE: cairo-gadget width height quot cache? texture ; PREDICATE: cached-cairo < cairo-gadget cache?>> ; : ( width height quot -- cairo-gadget ) cairo-gadget construct-gadget @@ -29,31 +29,54 @@ PREDICATE: cached-cairo < cairo-gadget cache?>> ; [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; -: (cairo>bytes) ( gadget -- byte-array ) +: cairo>bytes ( gadget -- byte-array ) [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; -GENERIC: cairo>bytes -M: cairo-gadget cairo>bytes ( gadget -- byte-array ) - (cairo>bytes) ; - -M: cached-cairo cairo>bytes ( gadget -- byte-array ) - dup bytes>> [ ] [ - dup (cairo>bytes) [ >>bytes drop ] keep - ] ?if ; - : cairo>png ( gadget path -- ) >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] [ height>> ] tri over width>stride cairo_image_surface_create_for_data r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; -M: cairo-gadget draw-gadget* ( gadget -- ) - origin get [ +: with-cairo-gl ( quot -- ) + >r origin get [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + ] r> compose with-translation ; + +M: cairo-gadget draw-gadget* ( gadget -- ) + [ [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] [ cairo>bytes ] tri glDrawPixels - ] with-translation ; + ] with-cairo-gl ; + +MEMO: render-to-texture ( gadget -- ) + GL_TEXTURE_BIT [ + GL_TEXTURE_2D over texture>> glBindTexture + >r GL_TEXTURE_2D 0 GL_RGBA r> + [ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ] + [ cairo>bytes ] tri glTexImage2D + init-texture + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs ; + +M: cached-cairo draw-gadget* ( gadget -- ) + GL_TEXTURE_2D [ + [ + dup render-to-texture + GL_TEXTURE_2D over texture>> glBindTexture + GL_QUADS [ + [ width>> ] [ height>> ] bi 2array four-sides + ] do-state + GL_TEXTURE_2D 0 glBindTexture + ] with-cairo-gl + ] do-enabled ; + +M: cached-cairo graft* ( gadget -- ) + gen-texture >>texture drop ; + +M: cached-cairo ungraft* ( gadget -- ) + texture>> delete-texture ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; @@ -63,11 +86,13 @@ M: cairo-gadget pref-dim* ( gadget -- rect ) cr cairo_paint ; : ( width height bytes -- cairo-gadget ) - >r [ ] r> >>bytes ; + >r [ ] r> >>texture ; : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] [ cairo_image_surface_get_height 2dup ] [ [ copy-surface ] curry copy-cairo ] tri - ; \ No newline at end of file + ; + + From 87b6cb5d404861ccbe78abbb199f1d803cc85f98 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 11:59:41 -0700 Subject: [PATCH 03/16] fixed a color issue in texture rendering --- extra/cairo/gadgets/gadgets.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index fa5364557e..bda18d04b4 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: cairo cairo.ffi ui.render kernel opengl.gl opengl math byte-arrays ui.gadgets accessors arrays -namespaces io.backend memoize ; +namespaces io.backend memoize colors ; IN: cairo.gadgets @@ -64,6 +64,7 @@ M: cached-cairo draw-gadget* ( gadget -- ) GL_TEXTURE_2D [ [ dup render-to-texture + white gl-color GL_TEXTURE_2D over texture>> glBindTexture GL_QUADS [ [ width>> ] [ height>> ] bi 2array four-sides @@ -76,7 +77,8 @@ M: cached-cairo graft* ( gadget -- ) gen-texture >>texture drop ; M: cached-cairo ungraft* ( gadget -- ) - texture>> delete-texture ; + [ texture>> delete-texture ] + [ \ render-to-texture invalidate-memoized ] bi ; M: cairo-gadget pref-dim* ( gadget -- rect ) [ width>> ] [ height>> ] bi 2array ; From e1669916f60d279ec1edd3e7edd95b960ea2840a Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 12:00:55 -0700 Subject: [PATCH 04/16] add invalidate-memoized to extra/memoize so that specific entries can be removed from the memoization cache. This is used in cached-cairo ungraft* to ensure that textures re-rendered. --- extra/memoize/memoize.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 4136f9eaff..6a223fdc7e 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -52,3 +52,6 @@ M: memoized definition "memo-quot" word-prop ; : reset-memoized ( word -- ) "memoize" word-prop clear-assoc ; + +: invalidate-memoized ! ( inputs... word ) + [ #in packer call ] [ "memoize" word-prop delete-at ] bi ; From 383784d09ed2061e9f1e8267fabc7df877d1f9d5 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 12:03:26 -0700 Subject: [PATCH 05/16] incorporate color into "cairo.pango.gadgets" run for testing purposes. --- extra/cairo/pango/gadgets/gadgets.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 48e5e683a9..0ba901d453 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -9,12 +9,16 @@ IN: cairo.pango.gadgets : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; -USING: prettyprint sequences ui.gadgets.panes ; +USING: prettyprint sequences ui.gadgets.panes +threads ; : hello-pango ( -- ) 50 [ 6 + ] map [ "Sans " swap unparse append - [ layout-font "今日は、 Pango!" layout-text ] curry - gadget. + [ + cr 0 1 0.2 0.6 cairo_set_source_rgba + layout-font "今日は、 Pango!" layout-text + ] curry + gadget. yield ] each ; MAIN: hello-pango From 03ceb011259add3a688a9550a4165b72eb080acf Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 25 May 2008 13:24:56 -0700 Subject: [PATCH 06/16] Add a larger text section example to "cairo.pango.gadgets" run --- extra/cairo/pango/gadgets/gadgets.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index 0ba901d453..fa12f96622 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -10,7 +10,7 @@ IN: cairo.pango.gadgets [ cr layout pango_cairo_show_layout ] (pango-gadget) ; USING: prettyprint sequences ui.gadgets.panes -threads ; +threads io.backend io.encodings.utf8 io.files ; : hello-pango ( -- ) 50 [ 6 + ] map [ "Sans " swap unparse append @@ -19,6 +19,10 @@ threads ; layout-font "今日は、 Pango!" layout-text ] curry gadget. yield - ] each ; + ] each + [ + "resource:extra/cairo/pango/gadgets/gadgets.factor" + normalize-path utf8 file-contents layout-text + ] gadget. ; MAIN: hello-pango From 683ba1a7634106a9ce3174d330e555c8d85da14f Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Tue, 27 May 2008 20:18:31 -0700 Subject: [PATCH 07/16] Separated out cairo.pango into extra/pango and pango.fonts --- extra/cairo/pango/pango.factor | 54 ++++------------------------------ extra/pango/fonts/fonts.factor | 40 +++++++++++++++++++++++++ extra/pango/pango.factor | 54 ++++++++++++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 49 deletions(-) create mode 100644 extra/pango/fonts/fonts.factor create mode 100644 extra/pango/pango.factor diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor index 789044f6e1..3f702769d8 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/cairo/pango/pango.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! pangocairo bindings, from pango/pangocairo.h - USING: cairo.ffi alien.c-types math -alien.syntax system combinators alien ; +alien.syntax system combinators alien +pango pango.fonts ; IN: cairo.pango << "pangocairo" { @@ -15,10 +15,6 @@ IN: cairo.pango LIBRARY: pangocairo -TYPEDEF: void* PangoCairoFont -TYPEDEF: void* PangoCairoFontMap -TYPEDEF: void* PangoFontMap - FUNCTION: PangoFontMap* pango_cairo_font_map_new ( ) ; @@ -92,49 +88,6 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ; FUNCTION: void pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Helpful functions from other parts of pango -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: PANGO_SCALE 1024 ; - -FUNCTION: void -pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; - -FUNCTION: char* -pango_layout_get_text ( PangoLayout* layout ) ; - -FUNCTION: void -pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; - -TYPEDEF: void* PangoFontDescription - -FUNCTION: PangoFontDescription* -pango_font_description_from_string ( char* str ) ; - -FUNCTION: char* -pango_font_description_to_string ( PangoFontDescription* desc ) ; - -FUNCTION: char* -pango_font_description_to_filename ( PangoFontDescription* desc ) ; - -FUNCTION: void -pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; - -FUNCTION: PangoFontDescription* -pango_layout_get_font_description ( PangoLayout* layout ) ; - -FUNCTION: void -pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; - -FUNCTION: void -pango_font_description_free ( PangoFontDescription* desc ) ; - -TYPEDEF: void* gpointer - -FUNCTION: void -g_object_unref ( gpointer object ) ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Higher level words and combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -173,3 +126,6 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; : layout-text ( str -- ) layout swap -1 pango_layout_set_text ; + +: families ( -- families ) + pango_cairo_font_map_get_default list-families ; diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor new file mode 100644 index 0000000000..6076b6a254 --- /dev/null +++ b/extra/pango/fonts/fonts.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license +USING: pango alien.syntax alien.c-types +kernel ; +IN: pango.fonts + +LIBRARY: pango + +FUNCTION: void +pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ; + +FUNCTION: char* +pango_font_family_get_name ( PangoFontFamily* family ) ; + +FUNCTION: int +pango_font_family_is_monospace ( PangoFontFamily* family ) ; + +FUNCTION: void +pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ; + +FUNCTION: char* +pango_font_face_get_face_name ( PangoFontFace* face ) ; + +FUNCTION: void +pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; + +: list-families ( PangoFontMap* -- PangoFontFamily*-seq ) + 0 0 [ pango_font_map_list_families ] 2keep + *int >r *void* r> c-void*-array> ; + +: list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) + 0 0 [ pango_font_family_list_faces ] 2keep + *int >r *void* r> c-void*-array> ; + +: list-sizes ( PangoFontFace* -- ints ) + 0 0 [ pango_font_face_list_sizes ] 2keep + *int >r *void* r> c-int-array> ; + +: monospace? ( PangoFontFamily* -- ? ) + pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor new file mode 100644 index 0000000000..3836a43e3f --- /dev/null +++ b/extra/pango/pango.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license +USING: system +alien.c-types alien.syntax alien combinators ; +IN: pango + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Helpful functions from other parts of pango +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +<< "pango" { +! { [ os winnt? ] [ "libpango-1.dll" ] } +! { [ os macosx? ] [ "libpango.dylib" ] } + { [ os unix? ] [ "libpango-1.0.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: pango + +: PANGO_SCALE 1024 ; + +FUNCTION: void +pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ; + +FUNCTION: char* +pango_layout_get_text ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: PangoFontDescription* +pango_font_description_from_string ( char* str ) ; + +FUNCTION: char* +pango_font_description_to_string ( PangoFontDescription* desc ) ; + +FUNCTION: char* +pango_font_description_to_filename ( PangoFontDescription* desc ) ; + +FUNCTION: void +pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ; + +FUNCTION: PangoFontDescription* +pango_layout_get_font_description ( PangoLayout* layout ) ; + +FUNCTION: void +pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; + +FUNCTION: void +pango_font_description_free ( PangoFontDescription* desc ) ; + +TYPEDEF: void* gpointer + +FUNCTION: void +g_object_unref ( gpointer object ) ; From 610c47eb183272b293c5069c9189277b399c5c7c Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Fri, 30 May 2008 10:42:06 -0700 Subject: [PATCH 08/16] Refactored cairo gadgets, basing them on the texture-gadget in opengl.gadgets --- extra/cairo/gadgets/gadgets.factor | 93 ++++-------------------- extra/cairo/pango/gadgets/gadgets.factor | 4 +- extra/cairo/pango/pango.factor | 6 +- extra/cairo/samples/samples.factor | 4 +- extra/opengl/gadgets/gadgets.factor | 72 ++++++++++++++++++ 5 files changed, 96 insertions(+), 83 deletions(-) create mode 100644 extra/opengl/gadgets/gadgets.factor diff --git a/extra/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor index bda18d04b4..f5f4d3e965 100644 --- a/extra/cairo/gadgets/gadgets.factor +++ b/extra/cairo/gadgets/gadgets.factor @@ -1,100 +1,39 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo cairo.ffi ui.render kernel opengl.gl opengl -math byte-arrays ui.gadgets accessors arrays -namespaces io.backend memoize colors ; +USING: sequences math opengl.gadgets kernel +byte-arrays cairo.ffi cairo io.backend +opengl.gl arrays ; IN: cairo.gadgets -! We need two kinds of gadgets: -! one performs the cairo ops once and caches the bytes, the other -! performs cairo ops every refresh - -TUPLE: cairo-gadget width height quot cache? texture ; -PREDICATE: cached-cairo < cairo-gadget cache?>> ; -: ( width height quot -- cairo-gadget ) - cairo-gadget construct-gadget - swap >>quot - swap >>height - swap >>width ; - -: ( width height quot -- cairo-gadget ) - t >>cache? ; - : width>stride ( width -- stride ) 4 * ; -: copy-cairo ( width height quot -- byte-array ) - >r over width>stride +: copy-cairo ( dim quot -- byte-array ) + >r first2 over width>stride [ * nip dup CAIRO_FORMAT_ARGB32 ] [ cairo_image_surface_create_for_data ] 3bi r> with-cairo-from-surface ; -: cairo>bytes ( gadget -- byte-array ) - [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ; +: ( dim quot -- ) + over 2^-bounds swap copy-cairo + GL_BGRA rot ; -: cairo>png ( gadget path -- ) - >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] - [ height>> ] tri over width>stride - cairo_image_surface_create_for_data - r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; - -: with-cairo-gl ( quot -- ) - >r origin get [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] r> compose with-translation ; - -M: cairo-gadget draw-gadget* ( gadget -- ) - [ - [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ] - [ cairo>bytes ] tri glDrawPixels - ] with-cairo-gl ; - -MEMO: render-to-texture ( gadget -- ) - GL_TEXTURE_BIT [ - GL_TEXTURE_2D over texture>> glBindTexture - >r GL_TEXTURE_2D 0 GL_RGBA r> - [ width>> ] [ height>> 0 GL_BGRA GL_UNSIGNED_BYTE ] - [ cairo>bytes ] tri glTexImage2D - init-texture - GL_TEXTURE_2D 0 glBindTexture - ] do-attribs ; - -M: cached-cairo draw-gadget* ( gadget -- ) - GL_TEXTURE_2D [ - [ - dup render-to-texture - white gl-color - GL_TEXTURE_2D over texture>> glBindTexture - GL_QUADS [ - [ width>> ] [ height>> ] bi 2array four-sides - ] do-state - GL_TEXTURE_2D 0 glBindTexture - ] with-cairo-gl - ] do-enabled ; - -M: cached-cairo graft* ( gadget -- ) - gen-texture >>texture drop ; - -M: cached-cairo ungraft* ( gadget -- ) - [ texture>> delete-texture ] - [ \ render-to-texture invalidate-memoized ] bi ; - -M: cairo-gadget pref-dim* ( gadget -- rect ) - [ width>> ] [ height>> ] bi 2array ; +! maybe also texture>png +! : cairo>png ( gadget path -- ) +! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ] +! [ height>> ] tri over width>stride +! cairo_image_surface_create_for_data +! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ; : copy-surface ( surface -- ) cr swap 0 0 cairo_set_source_surface cr cairo_paint ; -: ( width height bytes -- cairo-gadget ) - >r [ ] r> >>texture ; - : ( path -- gadget ) normalize-path cairo_image_surface_create_from_png [ cairo_image_surface_get_width ] - [ cairo_image_surface_get_height 2dup ] + [ cairo_image_surface_get_height 2array dup 2^-bounds ] [ [ copy-surface ] curry copy-cairo ] tri - ; + GL_BGRA rot ; diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor index fa12f96622..44ebfc30a5 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/cairo/pango/gadgets/gadgets.factor @@ -1,10 +1,12 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. USING: cairo.pango cairo cairo.ffi cairo.gadgets alien.c-types kernel math ; IN: cairo.pango.gadgets : (pango-gadget) ( setup show -- gadget ) [ drop layout-size ] - [ compose [ with-pango ] curry ] 2bi ; + [ compose [ with-pango ] curry ] 2bi ; : ( quot -- gadget ) [ cr layout pango_cairo_show_layout ] (pango-gadget) ; diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor index 3f702769d8..bb9c473047 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/cairo/pango/pango.factor @@ -4,7 +4,7 @@ ! pangocairo bindings, from pango/pangocairo.h USING: cairo.ffi alien.c-types math alien.syntax system combinators alien -pango pango.fonts ; +arrays pango pango.fonts ; IN: cairo.pango << "pangocairo" { @@ -115,8 +115,8 @@ M: pango-layout dispose ( alien -- ) alien>> g_object_unref ; >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create r> [ with-pango ] curry with-cairo-from-surface ; inline -: layout-size ( quot -- width height ) - [ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline +: layout-size ( quot -- dim ) + [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline : layout-font ( str -- ) pango_font_description_from_string diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor index 3cc63922f8..0e83381349 100644 --- a/extra/cairo/samples/samples.factor +++ b/extra/cairo/samples/samples.factor @@ -142,6 +142,6 @@ IN: cairo.samples USING: quotations cairo.gadgets ui.gadgets.panes sequences ; : samples ( -- ) { arc clip clip-image dash gradient text utf8 } - [ 256 256 rot 1quotation gadget. ] each ; + [ { 256 256 } swap 1quotation gadget. ] each ; - MAIN: samples \ No newline at end of file + MAIN: samples diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor new file mode 100644 index 0000000000..1a15283048 --- /dev/null +++ b/extra/opengl/gadgets/gadgets.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2008 Matthew Willis. +! See http://factorcode.org/license.txt for BSD license. +USING: locals math.functions math namespaces +opengl.gl accessors kernel opengl ui.gadgets +destructors sequences ui.render colors ; +IN: opengl.gadgets + +TUPLE: texture-gadget bytes format dim tex ; + +: 2^-ceil ( x -- y ) + dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable + +: 2^-bounds ( dim -- dim' ) + [ 2^-ceil ] map ; foldable flushable + +: ( bytes format dim -- gadget ) + texture-gadget construct-gadget + swap >>dim + swap >>format + swap >>bytes ; + +:: render ( gadget -- ) + GL_ENABLE_BIT [ + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D gadget tex>> glBindTexture + GL_TEXTURE_2D + 0 + GL_RGBA + gadget dim>> 2^-bounds first2 + 0 + gadget format>> + GL_UNSIGNED_BYTE + gadget bytes>> + glTexImage2D + init-texture + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs ; + +:: four-corners ( dim -- ) + [let* | w [ dim first ] + h [ dim second ] + dim' [ dim dup 2^-bounds [ /f ] 2map ] + w' [ dim' first ] + h' [ dim' second ] | + 0 0 glTexCoord2d 0 0 glVertex2d + 0 h' glTexCoord2d 0 h glVertex2d + w' h' glTexCoord2d w h glVertex2d + w' 0 glTexCoord2d w 0 glVertex2d + ] ; + +M: texture-gadget draw-gadget* ( gadget -- ) + origin get [ + GL_ENABLE_BIT [ + white gl-color + 1.0 -1.0 glPixelZoom + GL_TEXTURE_2D glEnable + GL_TEXTURE_2D over tex>> glBindTexture + GL_QUADS [ + dim>> four-corners + ] do-state + GL_TEXTURE_2D 0 glBindTexture + ] do-attribs + ] with-translation ; + +M: texture-gadget graft* ( gadget -- ) + gen-texture >>tex [ render ] + [ f >>bytes f >>format drop ] bi ; + +M: texture-gadget ungraft* ( gadget -- ) + tex>> delete-texture ; + +M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ; From 1c8b5728754ab4b79aff7fafbf79ef37936ffdc1 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 31 May 2008 01:11:47 -0700 Subject: [PATCH 09/16] cairo.pango renamed to pango.cairo --- .../{cairo/pango/pango.factor => pango/cairo/cairo.factor} | 2 +- extra/{cairo/pango => pango/cairo}/gadgets/gadgets.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) rename extra/{cairo/pango/pango.factor => pango/cairo/cairo.factor} (99%) rename extra/{cairo/pango => pango/cairo}/gadgets/gadgets.factor (85%) diff --git a/extra/cairo/pango/pango.factor b/extra/pango/cairo/cairo.factor similarity index 99% rename from extra/cairo/pango/pango.factor rename to extra/pango/cairo/cairo.factor index bb9c473047..889052c385 100644 --- a/extra/cairo/pango/pango.factor +++ b/extra/pango/cairo/cairo.factor @@ -5,7 +5,7 @@ USING: cairo.ffi alien.c-types math alien.syntax system combinators alien arrays pango pango.fonts ; -IN: cairo.pango +IN: pango.cairo << "pangocairo" { ! { [ os winnt? ] [ "libpangocairo-1.dll" ] } diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/pango/cairo/gadgets/gadgets.factor similarity index 85% rename from extra/cairo/pango/gadgets/gadgets.factor rename to extra/pango/cairo/gadgets/gadgets.factor index 44ebfc30a5..9e8a99515e 100644 --- a/extra/cairo/pango/gadgets/gadgets.factor +++ b/extra/pango/cairo/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: cairo.pango cairo cairo.ffi cairo.gadgets +USING: pango.cairo cairo cairo.ffi cairo.gadgets alien.c-types kernel math ; -IN: cairo.pango.gadgets +IN: pango.cairo.gadgets : (pango-gadget) ( setup show -- gadget ) [ drop layout-size ] @@ -23,7 +23,7 @@ threads io.backend io.encodings.utf8 io.files ; gadget. yield ] each [ - "resource:extra/cairo/pango/gadgets/gadgets.factor" + "resource:extra/pango/cairo/gadgets/gadgets.factor" normalize-path utf8 file-contents layout-text ] gadget. ; From b1bc993799f7b46a69b35fc9e77e6cb7c93a8f5e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 30 May 2008 22:46:15 -0700 Subject: [PATCH 10/16] Add a test suite for json.reader. Fix bugs in json.reader: failure to parse when more than one character of whitespace between tokens, failure to parse escape codes in strings, misinterpretation of "e+02" as a negative exponent, failure to handle leading whitespace, and failure to handle "+" as the first character of a number. Change json.reader to parse JSON booleans into Factor t and f, and to parse JSON null into the json-null symbol. --- extra/json/reader/reader-tests.factor | 43 ++++++++++++++++++++++++ extra/json/reader/reader.factor | 47 +++++++++++++++++++-------- 2 files changed, 76 insertions(+), 14 deletions(-) create mode 100644 extra/json/reader/reader-tests.factor diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor new file mode 100644 index 0000000000..e8dbc2eaa7 --- /dev/null +++ b/extra/json/reader/reader-tests.factor @@ -0,0 +1,43 @@ +USING: arrays json.reader kernel multiline strings tools.test ; +IN: json.reader.tests + +{ f } [ "false" json> ] unit-test +{ t } [ "true" json> ] unit-test +{ json-null } [ "null" json> ] unit-test +{ 0 } [ "0" json> ] unit-test +{ 0 } [ "0000" json> ] unit-test +{ 102 } [ "102" json> ] unit-test +{ -102 } [ "-102" json> ] unit-test +{ 102 } [ "+102" json> ] unit-test +{ 102.0 } [ "102.0" json> ] unit-test +{ 102.5 } [ "102.5" json> ] unit-test +{ 102.5 } [ "102.50" json> ] unit-test +{ -10250 } [ "-102.5e2" json> ] unit-test +{ -10250 } [ "-102.5E+2" json> ] unit-test +{ 10.25 } [ "1025e-2" json> ] unit-test + +{ "fuzzy pickles" } [ <" "fuzzy pickles" "> json> ] unit-test +{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test +{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ "\"scare\" quotes" } [ <" "\"scare\" quotes" "> json> ] unit-test + +{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test +{ H{ + { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } + { "prime" { 2 3 5 7 11 13 } } +} } [ <" { + "fib": [1, 1, 2, 3, 5, 8, + { "etc":"etc" } ], + "prime": + [ 2,3, 5,7, +11, +13 +] } +"> json> ] unit-test + +{ 0 } [ " 0" json> ] unit-test +{ 0 } [ "0 " json> ] unit-test +{ 0 } [ " 0 " json> ] unit-test + diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 17c1b272df..5e6b16dc2f 100755 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -7,6 +7,8 @@ IN: json.reader ! Grammar for JSON from RFC 4627 +SYMBOL: json-null + : [<&>] ( quot -- quot ) { } make unclip [ <&> ] reduce ; @@ -17,8 +19,7 @@ LAZY: 'ws' ( -- parser ) " " token "\n" token <|> "\r" token <|> - "\t" token <|> - "" token <|> ; + "\t" token <|> <*> ; LAZY: spaced ( parser -- parser ) 'ws' swap &> 'ws' <& ; @@ -42,24 +43,39 @@ LAZY: 'value-separator' ( -- parser ) "," token spaced ; LAZY: 'false' ( -- parser ) - "false" token ; + "false" token [ drop f ] <@ ; LAZY: 'null' ( -- parser ) - "null" token ; + "null" token [ drop json-null ] <@ ; LAZY: 'true' ( -- parser ) - "true" token ; + "true" token [ drop t ] <@ ; LAZY: 'quot' ( -- parser ) "\"" token ; +LAZY: 'hex-digit' ( -- parser ) + [ digit> ] satisfy [ digit> ] <@ ; + +: hex-digits>ch ( digits -- ch ) + 0 [ swap 16 * + ] reduce ; + +LAZY: 'string-char' ( -- parser ) + [ quotable? ] satisfy + "\\b" token [ drop 8 ] <@ <|> + "\\t" token [ drop CHAR: \t ] <@ <|> + "\\n" token [ drop CHAR: \n ] <@ <|> + "\\f" token [ drop 12 ] <@ <|> + "\\r" token [ drop CHAR: \r ] <@ <|> + "\\\"" token [ drop CHAR: " ] <@ <|> + "\\/" token [ drop CHAR: / ] <@ <|> + "\\\\" token [ drop CHAR: \\ ] <@ <|> + "\\u" token 'hex-digit' 4 exactly-n &> + [ hex-digits>ch ] <@ <|> ; + LAZY: 'string' ( -- parser ) 'quot' - [ - [ quotable? ] keep - [ CHAR: \\ = or ] keep - CHAR: " = not and - ] satisfy <*> &> + 'string-char' <*> &> 'quot' <& [ >string ] <@ ; DEFER: 'value' @@ -86,6 +102,9 @@ LAZY: 'minus' ( -- parser ) LAZY: 'plus' ( -- parser ) "+" token ; +LAZY: 'sign' ( -- parser ) + 'minus' 'plus' <|> ; + LAZY: 'zero' ( -- parser ) "0" token [ drop 0 ] <@ ; @@ -116,11 +135,11 @@ LAZY: 'e' ( -- parser ) : sign-number ( pair -- number ) #! Pair is { minus? num } #! Convert the json number value to a factor number - dup second swap first [ -1 * ] when ; + dup second swap first [ first "-" = [ -1 * ] when ] when* ; LAZY: 'exp' ( -- parser ) 'e' - 'minus' 'plus' <|> &> + 'sign' &> 'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ; : sequence>frac ( seq -- num ) @@ -136,7 +155,7 @@ LAZY: 'frac' ( -- parser ) dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ; LAZY: 'number' ( -- parser ) - 'minus' + 'sign' [ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@ 'exp' <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ; @@ -149,7 +168,7 @@ LAZY: 'value' ( -- parser ) 'object' , 'array' , 'number' , - ] [<|>] ; + ] [<|>] spaced ; : json> ( string -- object ) #! Parse a json formatted string to a factor object From 0b4a0f5e4d3bfc7596e3e1aa8eabb7aff81c5516 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 31 May 2008 09:10:11 -0700 Subject: [PATCH 11/16] Adjust json.reader unit tests a bit --- extra/json/reader/reader-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/json/reader/reader-tests.factor b/extra/json/reader/reader-tests.factor index e8dbc2eaa7..4b7bd56f01 100644 --- a/extra/json/reader/reader-tests.factor +++ b/extra/json/reader/reader-tests.factor @@ -5,7 +5,6 @@ IN: json.reader.tests { t } [ "true" json> ] unit-test { json-null } [ "null" json> ] unit-test { 0 } [ "0" json> ] unit-test -{ 0 } [ "0000" json> ] unit-test { 102 } [ "102" json> ] unit-test { -102 } [ "-102" json> ] unit-test { 102 } [ "+102" json> ] unit-test @@ -15,12 +14,13 @@ IN: json.reader.tests { -10250 } [ "-102.5e2" json> ] unit-test { -10250 } [ "-102.5E+2" json> ] unit-test { 10.25 } [ "1025e-2" json> ] unit-test +{ 0.125 } [ "0.125" json> ] unit-test +{ -0.125 } [ "-0.125" json> ] unit-test -{ "fuzzy pickles" } [ <" "fuzzy pickles" "> json> ] unit-test +{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test { "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test -{ "\"scare\" quotes" } [ <" "\"scare\" quotes" "> json> ] unit-test { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test { H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test From 8c686c67f9ae3da30e0231ef4ec1e8e5117d3944 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 31 May 2008 13:41:54 -0700 Subject: [PATCH 12/16] pango.fonts: make sure to free arrays with g_free --- extra/pango/fonts/fonts.factor | 6 +++--- extra/pango/pango.factor | 5 +++++ 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/pango/fonts/fonts.factor b/extra/pango/fonts/fonts.factor index 6076b6a254..d07c71226a 100644 --- a/extra/pango/fonts/fonts.factor +++ b/extra/pango/fonts/fonts.factor @@ -26,15 +26,15 @@ pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ; : list-families ( PangoFontMap* -- PangoFontFamily*-seq ) 0 0 [ pango_font_map_list_families ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-faces ( PangoFontFamily* -- PangoFontFace*-seq ) 0 0 [ pango_font_family_list_faces ] 2keep - *int >r *void* r> c-void*-array> ; + *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ; : list-sizes ( PangoFontFace* -- ints ) 0 0 [ pango_font_face_list_sizes ] 2keep - *int >r *void* r> c-int-array> ; + *int swap *void* [ swap c-int-array> ] [ g_free ] bi ; : monospace? ( PangoFontFamily* -- ? ) pango_font_family_is_monospace 1 = ; diff --git a/extra/pango/pango.factor b/extra/pango/pango.factor index 3836a43e3f..3549d9abb4 100644 --- a/extra/pango/pango.factor +++ b/extra/pango/pango.factor @@ -48,7 +48,12 @@ pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ; FUNCTION: void pango_font_description_free ( PangoFontDescription* desc ) ; +! glib functions + TYPEDEF: void* gpointer FUNCTION: void g_object_unref ( gpointer object ) ; + +FUNCTION: void +g_free ( gpointer mem ) ; From 3ab71b00a99f391d9f036585eecc11b039f2d99d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 31 May 2008 23:20:24 -0500 Subject: [PATCH 13/16] URLs library, abstracted out from http.server --- extra/urls/authors.txt | 1 + extra/urls/summary.txt | 1 + extra/urls/tags.txt | 2 + extra/urls/urls-tests.factor | 162 +++++++++++++++++++++++++++++++++++ extra/urls/urls.factor | 143 +++++++++++++++++++++++++++++++ 5 files changed, 309 insertions(+) create mode 100644 extra/urls/authors.txt create mode 100644 extra/urls/summary.txt create mode 100644 extra/urls/tags.txt create mode 100644 extra/urls/urls-tests.factor create mode 100644 extra/urls/urls.factor diff --git a/extra/urls/authors.txt b/extra/urls/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/urls/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/urls/summary.txt b/extra/urls/summary.txt new file mode 100644 index 0000000000..caeda3d21a --- /dev/null +++ b/extra/urls/summary.txt @@ -0,0 +1 @@ +Tools for working with URLs (uniform resource locators) diff --git a/extra/urls/tags.txt b/extra/urls/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/urls/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor new file mode 100644 index 0000000000..dd319a1e65 --- /dev/null +++ b/extra/urls/urls-tests.factor @@ -0,0 +1,162 @@ +IN: urls.tests +USING: urls tools.test tuple-syntax arrays kernel assocs ; + +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test + +[ "hello world" ] [ "hello+world" url-decode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ " ! " ] [ "%20%21%20" url-decode ] unit-test +[ "hello world" ] [ "hello world%" url-decode ] unit-test +[ "hello world" ] [ "hello world%x" url-decode ] unit-test +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test + +[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test + +[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test + +[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +: urls + { + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com:1234/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/a/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + "http://www.apple.com/a/path?a=b#foo" + } + { + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/another/fine/path" + anchor: "foo" + } + "http://www.apple.com:1234/another/fine/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + anchor: "foo" + } + "/a/relative/path#foo" + } + { + TUPLE{ url + path: "/a/relative/path" + } + "/a/relative/path" + } + { + TUPLE{ url + path: "a/relative/path" + } + "a/relative/path" + } + } ; + +urls [ + [ 1array ] [ [ string>url ] curry ] bi* unit-test +] assoc-each + +urls [ + swap [ 1array ] [ [ url>string ] curry ] bi* unit-test +] assoc-each + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } +] [ + TUPLE{ url + path: "/a/path" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + + derive-url +] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor new file mode 100644 index 0000000000..86f3de651d --- /dev/null +++ b/extra/urls/urls.factor @@ -0,0 +1,143 @@ +USING: kernel unicode.categories combinators sequences splitting +fry namespaces assocs arrays strings mirrors +io.encodings.string io.encodings.utf8 +math math.parser accessors namespaces.lib ; +IN: urls + +: url-quotable? ( ch -- ? ) + #! In a URL, can this character be used without + #! URL-encoding? + { + { [ dup letter? ] [ t ] } + { [ dup LETTER? ] [ t ] } + { [ dup digit? ] [ t ] } + { [ dup "/_-.:" member? ] [ t ] } + [ f ] + } cond nip ; foldable + +: push-utf8 ( ch -- ) + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + +: url-encode ( str -- str ) + [ + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each + ] "" make ; + +: url-decode-hex ( index str -- ) + 2dup length 2 - >= [ + 2drop + ] [ + [ 1+ dup 2 + ] dip subseq hex> [ , ] when* + ] if ; + +: url-decode-% ( index str -- index str ) + 2dup url-decode-hex [ 3 + ] dip ; + +: url-decode-+-or-other ( index str ch -- index str ) + dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ; + +: url-decode-iter ( index str -- ) + 2dup length >= [ + 2drop + ] [ + 2dup nth dup CHAR: % = [ + drop url-decode-% + ] [ + url-decode-+-or-other + ] if url-decode-iter + ] if ; + +: url-decode ( str -- str ) + [ 0 swap url-decode-iter ] "" make utf8 decode ; + +: add-query-param ( value key assoc -- ) + [ + at [ + { + { [ dup string? ] [ swap 2array ] } + { [ dup array? ] [ swap suffix ] } + { [ dup not ] [ drop ] } + } cond + ] when* + ] 2keep set-at ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split H{ } clone [ + [ + [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip + add-query-param + ] curry each + ] keep + ] when ; + +: assoc>query ( hash -- str ) + [ + { + { [ dup number? ] [ number>string 1array ] } + { [ dup string? ] [ 1array ] } + { [ dup sequence? ] [ ] } + } cond + ] assoc-map + [ + [ + [ url-encode ] dip + [ url-encode "=" swap 3append , ] with each + ] assoc-each + ] { } make "&" join ; + +TUPLE: url protocol host port path query anchor ; + +: parse-host-part ( protocol rest -- string' ) + [ "protocol" set ] [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 [ + ":" split1 + [ url-decode "host" set ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when "port" set + ] bi* + ] [ "/" prepend ] bi* + ] bi* ; + +: string>url ( string -- url ) + [ + ":" split1 [ parse-host-part ] when* + "#" split1 [ + "?" split1 [ query>assoc "query" set ] when* + url-decode "path" set + ] [ + url-decode "anchor" set + ] bi* + ] url make-object ; + +: unparse-host-part ( protocol -- ) + % + "://" % + "host" get url-encode % + "port" get [ ":" % # ] when* + "path" get "/" head? [ "Invalid URL" throw ] unless ; + +: url>string ( url -- string ) + [ + [ + "protocol" get [ unparse-host-part ] when* + "path" get url-encode % + "query" get [ "?" % assoc>query % ] when* + "anchor" get [ "#" % url-encode % ] when* + ] bind + ] "" make ; + +: fix-relative-path ( url base -- url base ) + over path>> '[ + "/" ?tail drop "/" , 3append + ] change-path + [ f >>path ] dip ; inline + +: derive-url ( url base -- url' ) + clone + over path>> "/" head? [ fix-relative-path ] unless + [ swap [ nip ] assoc-filter update ] keep ; From 18f139394e38380ea277e06cae4e83e8874cf5ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 31 May 2008 23:38:10 -0500 Subject: [PATCH 14/16] remove throwable conecpt from db --- extra/db/db.factor | 25 ++----------------------- extra/db/queries/queries.factor | 5 ++--- extra/db/tuples/tuples.factor | 4 ++-- 3 files changed, 6 insertions(+), 28 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 4b98612069..8d1feca6c7 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -39,31 +39,13 @@ TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -SINGLETON: throwable -SINGLETON: nonthrowable - -: make-throwable ( obj -- obj' ) - dup sequence? [ - [ make-throwable ] map - ] [ - throwable >>type - ] if ; - -: make-nonthrowable ( obj -- obj' ) - dup sequence? [ - [ make-nonthrowable ] map - ] [ - nonthrowable >>type - ] if ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) new swap >>out-params swap >>in-params - swap >>sql - throwable >>type ; + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -81,12 +63,9 @@ GENERIC: more-rows? ( result-set -- ? ) GENERIC: execute-statement* ( statement type -- ) -M: throwable execute-statement* ( statement type -- ) +M: object execute-statement* ( statement type -- ) drop query-results dispose ; -M: nonthrowable execute-statement* ( statement type -- ) - drop [ query-results dispose ] [ 2drop ] recover ; - : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 9743e87f2e..59ee60aa1f 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -8,9 +8,8 @@ IN: db.queries GENERIC: where ( specs obj -- ) : maybe-make-retryable ( statement -- statement ) - dup in-params>> [ generator-bind? ] contains? [ - make-retryable - ] when ; + dup in-params>> [ generator-bind? ] contains? + [ make-retryable ] when ; : query-make ( class quot -- ) >r sql-props r> diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 0a69b9cde8..bac141d6d2 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -112,8 +112,8 @@ M: retryable execute-statement* ( statement type -- ) : recreate-table ( class -- ) [ - drop-sql-statement make-nonthrowable - [ execute-statement ] with-disposals + [ drop-sql-statement [ execute-statement ] with-disposals + ] curry ignore-errors ] [ create-table ] bi ; : ensure-table ( class -- ) From e5b370194df041a54e6e2be37be9c3b15e66f0c4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Jun 2008 00:02:24 -0500 Subject: [PATCH 15/16] re-enable postgresql tests --- extra/db/tuples/tuples-tests.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index e4a16d0b16..f9a597e814 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -199,10 +199,9 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -! : test-postgresql ( quot -- ) -! >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; +: test-postgresql ( quot -- ) + >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; -: test-postgresql drop ; : test-repeated-insert [ ] [ person ensure-table ] unit-test [ ] [ person1 get insert-tuple ] unit-test From 9f0b470f7319ecf32248856525dac475dcbd7fcd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Jun 2008 00:59:06 -0500 Subject: [PATCH 16/16] Improving URL library --- extra/namespaces/lib/lib.factor | 8 +++- extra/urls/urls-tests.factor | 84 +++++++++++++++++++++++---------- extra/urls/urls.factor | 49 ++++++++++++------- 3 files changed, 98 insertions(+), 43 deletions(-) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 47b6b33a9a..851f60d126 100755 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib math.parser math sequences.lib locals ; + assocs.lib math.parser math sequences.lib locals mirrors ; IN: namespaces.lib @@ -58,3 +58,9 @@ MACRO:: nmake ( quot exemplars -- ) ] with-scope ] ] ; + +: make-object ( quot class -- object ) + new [ swap bind ] keep ; inline + +: with-object ( object quot -- ) + [ ] dip bind ; inline diff --git a/extra/urls/urls-tests.factor b/extra/urls/urls-tests.factor index dd319a1e65..e28816fdb3 100644 --- a/extra/urls/urls-tests.factor +++ b/extra/urls/urls-tests.factor @@ -87,6 +87,18 @@ urls [ swap [ 1array ] [ [ url>string ] curry ] bi* unit-test ] assoc-each +[ "b" ] [ "a" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test + +[ "a/b" ] [ "a/" "b" url-append-path ] unit-test + +[ "/b" ] [ "a" "/b" url-append-path ] unit-test + +[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test + +[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test + [ TUPLE{ url protocol: "http" @@ -95,10 +107,6 @@ urls [ path: "/a/path" } ] [ - TUPLE{ url - path: "/a/path" - } - TUPLE{ url protocol: "http" host: "www.apple.com" @@ -106,29 +114,7 @@ urls [ path: "/foo" } - derive-url -] unit-test - -[ TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 - path: "/a/path/relative/path" - query: H{ { "a" "b" } } - anchor: "foo" - } -] [ - TUPLE{ url - path: "relative/path" - query: H{ { "a" "b" } } - anchor: "foo" - } - - TUPLE{ url - protocol: "http" - host: "www.apple.com" - port: 1234 path: "/a/path" } @@ -145,12 +131,32 @@ urls [ anchor: "foo" } ] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/" + } + TUPLE{ url path: "relative/path" query: H{ { "a" "b" } } anchor: "foo" } + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + port: 1234 + path: "/a/path/relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } +] [ TUPLE{ url protocol: "http" host: "www.apple.com" @@ -158,5 +164,31 @@ urls [ path: "/a/path/" } + TUPLE{ url + path: "relative/path" + query: H{ { "a" "b" } } + anchor: "foo" + } + + derive-url +] unit-test + +[ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/baz" + } +] [ + TUPLE{ url + protocol: "http" + host: "www.apple.com" + path: "/xxx/bar" + } + + TUPLE{ url + path: "baz" + } + derive-url ] unit-test diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 86f3de651d..e20df65656 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: kernel unicode.categories combinators sequences splitting fry namespaces assocs arrays strings mirrors io.encodings.string io.encodings.utf8 @@ -89,17 +91,25 @@ IN: urls TUPLE: url protocol host port path query anchor ; +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; + +: parse-host ( string -- host port ) + ":" split1 [ url-decode ] [ + dup [ + string>number + dup [ "Invalid port" throw ] unless + ] when + ] bi* ; + : parse-host-part ( protocol rest -- string' ) [ "protocol" set ] [ "//" ?head [ "Invalid URL" throw ] unless "/" split1 [ - ":" split1 - [ url-decode "host" set ] [ - dup [ - string>number - dup [ "Invalid port" throw ] unless - ] when "port" set - ] bi* + parse-host [ "host" set ] [ "port" set ] bi* ] [ "/" prepend ] bi* ] bi* ; @@ -131,13 +141,20 @@ TUPLE: url protocol host port path query anchor ; ] bind ] "" make ; -: fix-relative-path ( url base -- url base ) - over path>> '[ - "/" ?tail drop "/" , 3append - ] change-path - [ f >>path ] dip ; inline +: url-append-path ( path1 path2 -- path ) + { + { [ dup "/" head? ] [ nip ] } + { [ dup empty? ] [ drop ] } + { [ over "/" tail? ] [ append ] } + { [ "/" pick start not ] [ nip ] } + [ [ "/" last-split1 drop "/" ] dip 3append ] + } cond ; -: derive-url ( url base -- url' ) - clone - over path>> "/" head? [ fix-relative-path ] unless - [ swap [ nip ] assoc-filter update ] keep ; +: derive-url ( base url -- url' ) + [ clone dup ] dip + 2dup [ path>> ] bi@ url-append-path + [ [ ] bi@ [ nip ] assoc-filter update ] dip + >>path ; + +: relative-url ( url -- url' ) + clone f >>protocol f >>host f >>port ;