HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
-{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
+{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
over dup [ dlopen ] when \ library construct-boa ;
: load-library ( name -- dll )
- library library-dll ;
+ library dup [ library-dll ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
r> add*
] when ;
-: malloc-file-contents ( path -- alien )
- binary file-contents malloc-byte-array ;
+: malloc-file-contents ( path -- alien len )
+ binary file-contents dup malloc-byte-array swap length ;
[
[ alien-cell ]
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
+ 1 exit
] recover
] [
"Cannot find " write write "." print
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
-{ $subsection "errors-post-mortem" } ;
+{ $subsection "errors-post-mortem" }
+"When Factor encouters a critical error, it calls the following word:"
+{ $subsection die } ;
ARTICLE: "continuations.private" "Continuation implementation details"
"A continuation is simply a tuple holding the contents of the five stacks:"
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
- drop "Invalid parameters for define-method" ;
+ drop "Invalid parameters for create-method" ;
M: check-tuple summary
drop "Invalid class for define-constructor" ;
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
-compiler.units ;
+compiler.units words ;
TUPLE: combination-1 ;
-M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
+M: combination-1 perform-combination 2drop [ ] ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
[
generic-1 T{ combination-1 } define-generic
- [ ] object \ generic-1 define-method
+ object \ generic-1 create-method [ ] define
] with-compilation-unit
[ ] [
{ $subsection define-generic }
{ $subsection define-simple-generic }
"Methods can be added to existing generic words:"
-{ $subsection define-method }
+{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
-{ method define-method POSTPONE: M: } related-words
+{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
HELP: check-method
{ $values { "class" class } { "generic" generic } }
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
-{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
+{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
-HELP: define-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+HELP: create-method
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
+{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
+{ $notes "To define a method, pass the output value to " { $link define } "." } ;
HELP: implementors
{ $values { "class" class } { "seq" "a sequence of generic words" } }
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
-GENERIC: method-prologue ( class combination -- quot )
-
-M: object method-prologue 2drop [ ] ;
-
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
: check-method ( class generic -- class generic )
over class? over generic? and [
\ check-method construct-boa throw
- ] unless ;
+ ] unless ; inline
-: with-methods ( word quot -- )
+: with-methods ( generic quot -- )
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
-: make-method-def ( quot class generic -- quot )
- "combination" word-prop method-prologue swap append ;
-
-PREDICATE: word method-body "method-def" word-prop >boolean ;
+PREDICATE: word method-body
+ "method-generic" word-prop >boolean ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
-: method-word-props ( quot class generic -- assoc )
+: method-word-props ( class generic -- assoc )
[
"method-generic" set
"method-class" set
- "method-def" set
] H{ } make-assoc ;
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
check-method
- [ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
- tuck set-word-props
- dup rot define ;
-
-: redefine-method ( quot class generic -- )
- [ method swap "method-def" set-word-prop ] 3keep
- [ make-method-def ] 2keep
- method swap define ;
-
-: define-method ( quot class generic -- )
- >r bootstrap-word r>
- 2dup method [
- redefine-method
+ [ set-word-props ] keep ;
+
+: reveal-method ( method class generic -- )
+ [ set-at ] with-methods ;
+
+: create-method ( class generic -- method )
+ 2dup method dup [
+ 2nip
] [
- [ <method> ] 2keep
- [ set-at ] with-methods
+ drop [ <method> dup ] 2keep reveal-method
] if ;
+: <default-method> ( generic combination -- method )
+ object bootstrap-word pick <method>
+ [ -rot make-default-method define ] keep ;
+
: define-default-method ( generic combination -- )
- dupd make-default-method object bootstrap-word pick <method>
- "default-method" set-word-prop ;
+ dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
M: method-spec where
first2 method set-where ;
M: method-spec definer
- drop \ M: \ ; ;
+ first2 method definer ;
M: method-spec definition
- first2 method dup
- [ "method-def" word-prop ] when ;
+ first2 method definition ;
: forget-method ( class generic -- )
check-method
M: method-body definer
drop \ M: \ ; ;
-M: method-body definition
- "method-def" word-prop ;
-
M: method-body forget*
dup "method-class" word-prop
swap "method-generic" word-prop
: applicable-method ( generic class -- quot )
over method
- [ word-def ]
+ [ 1quotation ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )
TUPLE: standard-combination # ;
-M: standard-combination method-prologue
- standard-combination-# object
- <array> swap add* [ declare ] curry ;
-
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
+[ ] [ "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
+
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
+
+[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
+
+[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
-! : file-length ( path -- n ) stat drop 2nip ;
-
: file-modified ( path -- n ) stat >r 3drop r> ;
-! : file-permissions ( path -- perm ) stat 2drop nip ;
-
: exists? ( path -- ? ) file-modified >boolean ;
-: directory? ( path -- ? ) stat 3drop ;
+: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
! Current working directory
HOOK: cd io-backend ( path -- )
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
- dupd [ file-info file-info-size read ] with-file-reader ;
-
-! : file-contents ( path encoding -- str )
-! dupd [ file-length read ] with-file-reader ;
+ <file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables generic kernel math namespaces sequences strings
- continuations assocs io.styles sbufs ;
+USING: hashtables generic kernel math namespaces sequences
+continuations assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str )
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
: contents ( stream -- str )
- 2048 <sbuf> [ stream-copy ] keep >string ;
+ [
+ [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+ ] with-stream ;
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
HELP: die
-{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ;
+{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
+{ $notes
+ "The term FEP originates from the Lisp machines of old. According to the Jargon File,"
+ $nl
+ { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
+ $nl
+ { $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
+} ;
HELP: (clone) ( obj -- newobj )
{ $values { "obj" object } { "newobj" "a shallow copy" } }
\ dispatch ,\r
] [ ] make ;\r
\r
-: specializer-methods ( quot word -- default alist )\r
+: specializer-cases ( quot word -- default alist )\r
dup [ array? ] all? [ 1array ] unless [\r
[ make-specializer ] keep\r
[ declare ] curry pick append\r
] { } map>assoc ;\r
\r
+: method-declaration ( method -- quot )\r
+ dup "method-generic" word-prop dispatch# object <array>\r
+ swap "method-class" word-prop add* ;\r
+\r
+: specialize-method ( quot method -- quot' )\r
+ method-declaration [ declare ] curry swap append ;\r
+\r
+: specialize-quot ( quot specializer -- quot' )\r
+ dup { number } = [\r
+ drop tag-specializer\r
+ ] [\r
+ specializer-cases alist>quot\r
+ ] if ;\r
+\r
+: standard-method? ( method -- ? )\r
+ dup method-body? [\r
+ "method-generic" word-prop standard-generic?\r
+ ] [ drop f ] if ;\r
+\r
: specialized-def ( word -- quot )\r
- dup word-def swap "specializer" word-prop [\r
- dup { number } = [\r
- drop tag-specializer\r
- ] [\r
- specializer-methods alist>quot\r
- ] if\r
- ] when* ;\r
+ dup word-def swap {\r
+ { [ dup standard-method? ] [ specialize-method ] }\r
+ {\r
+ [ dup "specializer" word-prop ]\r
+ [ "specializer" word-prop specialize-quot ]\r
+ }\r
+ { [ t ] [ drop ] }\r
+ } cond ;\r
\r
: specialized-length ( specializer -- n )\r
dup [ array? ] all? [ first ] when length ;\r
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-: create-in ( string -- word )
- in get create dup set-word dup save-location ;
-
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
: parse-tokens ( end -- seq )
100 <vector> swap (parse-tokens) >array ;
+: create-in ( string -- word )
+ in get create dup set-word dup save-location ;
+
: CREATE ( -- word ) scan create-in ;
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
+
: create-class-in ( word -- word )
in get create
dup save-class-location
] ?if
] when ;
+: create-method-in ( class generic -- method )
+ create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+ scan-word bootstrap-word scan-word create-method-in ;
+
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) CREATE dup reset-generic parse-definition ;
+: (:) CREATE-WORD parse-definition ;
+
+: (M:) CREATE-METHOD parse-definition ;
GENERIC: expected>string ( obj -- str )
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
- over define-simple-generic -rot define-method ;
+ over define-simple-generic
+ >r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"SYMBOL:" [
- CREATE dup reset-generic define-symbol
+ CREATE-WORD define-symbol
] define-syntax
"DEFER:" [
] define-syntax
"GENERIC:" [
- CREATE dup reset-word
- define-simple-generic
+ CREATE-GENERIC define-simple-generic
] define-syntax
"GENERIC#" [
- CREATE dup reset-word
+ CREATE-GENERIC
scan-word <standard-combination> define-generic
] define-syntax
"MATH:" [
- CREATE dup reset-word
+ CREATE-GENERIC
T{ math-combination } define-generic
] define-syntax
"HOOK:" [
- CREATE dup reset-word scan-word
+ CREATE-GENERIC scan-word
<hook-combination> define-generic
] define-syntax
"M:" [
- f set-word
- location >r
- scan-word bootstrap-word scan-word
- [ parse-definition -rot define-method ] 2keep
- 2array r> remember-definition
+ (M:) define
] define-syntax
"UNION:" [
] define-syntax
"C:" [
- CREATE dup reset-generic
+ CREATE-WORD
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax
[ 3 ] [
[ 3 swap resume-with ] "Test suspend" suspend
] unit-test
+
+[ f ] [ f get-global ] unit-test
: threads 41 getenv ;
-threads global [ H{ } assoc-like ] change-at
-
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )
$nl
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
+"Examples of constructors:"
+{ $code
+ "TUPLE: color red green blue alpha ;"
+ ""
+ "C: <rgba> rgba"
+ ": <rgba> color construct-boa ; ! identical to above"
+ ""
+ ": <rgb>"
+ " { set-color-red set-color-green set-color-blue }"
+ " color construct ;"
+ ": <rgb> f <rgba> ; ! identical to above"
+ ""
+ ": <color> construct-empty ;"
+ ": <color> { } color construct ; ! identical to above"
+ ": <color> f f f f <rgba> ; ! identical to above"
+}
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
ARTICLE: "tuple-delegation" "Delegation"
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"An example:"
-{ $code "TUPLE: person name address phone ;" }
-"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
+{ $code "TUPLE: person name address phone ;" "C: <person> person" }
+"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
{ $table
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method-def" word-prop ] [ t ] }
+ { [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
-USING: assocs kernel vectors sequences namespaces ;
+USING: arrays assocs kernel vectors sequences namespaces
+random math.parser ;
IN: assocs.lib
: >set ( seq -- hash )
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;
+
+: 2seq>assoc ( keys values exemplar -- assoc )
+ >r 2array flip r> assoc-like ;
+
+: generate-key ( assoc -- str )
+ >r random-256 >hex r>
+ 2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+ dup generate-key [ swap set-at ] keep ;
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
+ "tools.vocabs.monitor"
"editors"
} [ require ] each
IN: builder.benchmark
-: passing-benchmarks ( table -- table )
- [ second first2 number? swap number? and ] subset ;
+! : passing-benchmarks ( table -- table )
+! [ second first2 number? swap number? and ] subset ;
-: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+
+! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
: benchmark-difference ( old-table benchmark-result -- result-diff )
first2 >r
2array ;
: compare-tables ( old new -- table )
- [ passing-benchmarks simplify-table ] 2apply
+ [ passing-benchmarks ] 2apply
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
- "test-all-vocabs" eval-file test-failures.
+ "test-failures" cat
+
+! "test-failures" eval-file test-failures.
"help-lint results:" print "help-lint" cat
! http://cairographics.org/samples/text/
-USING: cairo math math.constants byte-arrays kernel ui ui.render
+USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
ui.gadgets opengl.gl ;
IN: cairo-demo
TUPLE: cairo-gadget image-array cairo-t ;
M: cairo-gadget draw-gadget* ( gadget -- )
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
- cairo-gadget-image-array glDrawPixels ;
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+ cairo-gadget-image-array glDrawPixels ;
: create-surface ( gadget -- cairo_surface_t )
- make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ;
+ make-image-array
+ [ swap set-cairo-gadget-image-array ] keep
+ convert-array-to-surface ;
: init-cairo ( gadget -- cairo_t )
create-surface cairo_create ;
cairo_fill ;
M: cairo-gadget graft* ( gadget -- )
- dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
+ dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
M: cairo-gadget ungraft* ( gadget -- )
cairo-gadget-cairo-t cairo_destroy ;
Sampo Vuori
+Doug Coleman
+++ /dev/null
-! Bindings for Cairo library
-! Copyright (c) 2007 Sampo Vuori
-! License: http://factorcode.org/license.txt
-
-! Unimplemented:
-! - most of the font stuff
-! - most of the matrix stuff
-! - most of the query functions
-
-
-USING: alien alien.syntax combinators system ;
-
-IN: cairo
-
-<< "cairo" {
- { [ win32? ] [ "cairo.dll" ] }
- ! { [ macosx? ] [ "libcairo.dylib" ] }
- { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
- { [ unix? ] [ "libcairo.so.2" ] }
- } cond "cdecl" add-library >>
-
-LIBRARY: cairo
-
-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
-;
-
-TYPEDEF: int cairo_content_t
-: CAIRO_CONTENT_COLOR HEX: 1000 ;
-: CAIRO_CONTENT_ALPHA HEX: 2000 ;
-: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
-
-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
-;
-
-TYPEDEF: int cairo_line_cap_t
-C-ENUM:
- CAIRO_LINE_CAP_BUTT
- CAIRO_LINE_CAP_ROUND
- CAIRO_LINE_CAP_SQUARE
-;
-
-TYPEDEF: int cair_line_join_t
-C-ENUM:
- CAIRO_LINE_JOIN_MITER
- CAIRO_LINE_JOIN_ROUND
- CAIRO_LINE_JOIN_BEVEL
-;
-
-TYPEDEF: int cairo_fill_rule_t
-C-ENUM:
- CAIRO_FILL_RULE_WINDING
- CAIRO_FILL_RULE_EVEN_ODD
-;
-
-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
-;
-
-C-STRUCT: cairo_font_t
- { "int" "refcount" }
- { "uint" "scale" } ;
-
-C-STRUCT: cairo_rectangle_t
- { "short" "x" }
- { "short" "y" }
- { "ushort" "width" }
- { "ushort" "height" } ;
-
-C-STRUCT: cairo_clip_rec_t
- { "cairo_rectangle_t" "rect" }
- { "void*" "region" }
- { "void*" "surface" } ;
-
-C-STRUCT: cairo_matrix_t
- { "void*" "m" } ;
-
-C-STRUCT: cairo_gstate_t
- { "uint" "operator" }
- { "double" "tolerance" }
- { "double" "line_width" }
- { "uint" "line_cap" }
- { "uint" "line_join" }
- { "double" "miter_limit" }
- { "uint" "fill_rule" }
- { "void*" "dash" }
- { "int" "num_dashes" }
- { "double" "dash_offset" }
- { "char*" "font_family " }
- { "uint" "font_slant" }
- { "uint" "font_weight" }
- { "void*" "font" }
- { "void*" "surface" }
- { "void*" "pattern " }
- { "double" "alpha" }
- { "cairo_clip_rec_t" "clip" }
- { "double" "pixels_per_inch" }
- { "cairo_matrix_t" "font_matrix" }
- { "cairo_matrix_t" "ctm" }
- { "cairo_matrix_t" "ctm_inverse" }
- { "void*" "path" }
- { "void*" "pen_regular" }
- { "void*" "next" } ;
-
-C-STRUCT: cairo_t
- { "uint" "ref_count" }
- { "cairo_gstate_t*" "gstate" }
- { "uint" "status ! cairo_status_t" } ;
-
-C-STRUCT: cairo_matrix_t
- { "double" "xx" }
- { "double" "yx" }
- { "double" "xy" }
- { "double" "yy" }
- { "double" "x0" }
- { "double" "y0" } ;
-
-TYPEDEF: int cairo_format_t
-C-ENUM:
- CAIRO_FORMAT_ARGB32
- CAIRO_FORMAT_RGB24
- CAIRO_FORMAT_A8
- CAIRO_FORMAT_A1
-;
-
-TYPEDEF: int cairo_antialias_t
-C-ENUM:
- CAIRO_ANTIALIAS_DEFAULT
- CAIRO_ANTIALIAS_NONE
- CAIRO_ANTIALIAS_GRAY
- CAIRO_ANTIALIAS_SUBPIXEL
-;
-
-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
-;
-
-: cairo_create ( cairo_surface_t -- cairo_t )
- "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
-
-: cairo_reference ( cairo_t -- cairo_t )
- "cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_destroy ( cairo_t -- )
- "void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_save ( cairo_t -- )
- "void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_restore ( cairo_t -- )
- "void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_set_operator ( cairo_t cairo_operator_t -- )
- "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ;
-
-: cairo_set_source ( cairo_t cairo_pattern_t -- )
- "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ;
-
-: cairo_set_source_rgb ( cairo_t red green blue -- )
- "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ;
-
-: cairo_set_source_rgba ( cairo_t red green blue alpha -- )
- "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_set_source_surface ( cairo_t cairo_surface_t x y -- )
- "void" "cairo" "cairo_set_source_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ;
-
-: cairo_set_tolerance ( cairo_t tolerance -- )
- "void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ;
-
-: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t )
- "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ;
-
-
-: cairo_set_antialias ( cairo_t cairo_antialias_t -- )
- "void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ;
-
-: cairo_set_fill_rule ( cairo_t cairo_fill_rule_t -- )
- "void" "cairo" "cairo_set_fill_rule" [ "cairo_t*" "int" ] alien-invoke ;
-
-: cairo_set_line_width ( cairo_t width -- )
- "void" "cairo" "cairo_set_line_width" [ "cairo_t*" "double" ] alien-invoke ;
-
-: cairo_set_line_cap ( cairo_t cairo_line_cap_t -- )
- "void" "cairo" "cairo_set_line_cap" [ "cairo_t*" "int" ] alien-invoke ;
-
-: cairo_set_line_join ( cairo_t cairo_line_join_t -- )
- "void" "cairo" "cairo_set_line_join" [ "cairo_t*" "int" ] alien-invoke ;
-
-: cairo_set_dash ( cairo_t dashes num_dashes offset -- )
- "void" "cairo" "cairo_set_dash" [ "cairo_t*" "double" "int" "double" ] alien-invoke ;
-
-: cairo_set_miter_limit ( cairo_t limit -- )
- "void" "cairo" "cairo_set_miter_limit" [ "cairo_t*" "double" ] alien-invoke ;
-
-: cairo_translate ( cairo_t x y -- )
- "void" "cairo" "cairo_translate" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_scale ( cairo_t sx sy -- )
- "void" "cairo" "cairo_scale" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_rotate ( cairo_t angle -- )
- "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ;
-
-: cairo_transform ( cairo_t cairo_matrix_t -- )
- "void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
-
-: cairo_set_matrix ( cairo_t cairo_matrix_t -- )
- "void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
-
-: cairo_identity_matrix ( cairo_t -- )
- "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;
-
-! cairo path creating functions
-
-: cairo_new_path ( cairo_t -- )
- "void" "cairo" "cairo_new_path" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_move_to ( cairo_t x y -- )
- "void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_new_sub_path ( cairo_t -- )
- "void" "cairo" "cairo_new_sub_path" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_line_to ( cairo_t x y -- )
- "void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_curve_to ( cairo_t x1 y1 x2 y2 x3 y3 -- )
- "void" "cairo" "cairo_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_arc ( cairo_t xc yc radius angle1 angle2 -- )
- "void" "cairo" "cairo_arc" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_arc_negative ( cairo_t xc yc radius angle1 angle2 -- )
- "void" "cairo" "cairo_arc_negative" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_rel_move_to ( cairo_t dx dy -- )
- "void" "cairo" "cairo_rel_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_rel_line_to ( cairo_t dx dy -- )
- "void" "cairo" "cairo_rel_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_rel_curve_to ( cairo_t dx1 dy1 dx2 dy2 dx3 dy3 -- )
- "void" "cairo" "cairo_rel_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_rectangle ( cairo_t x y width height -- )
- "void" "cairo" "cairo_rectangle" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_close_path ( cairo_t -- )
- "void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ;
-
-! Surface manipulation
-
-: cairo_surface_create_similar ( cairo_surface_t cairo_content_t width height -- cairo_surface_t )
- "cairo_surface_t*" "cairo" "cairo_surface_create_similar" [ "cairo_surface_t*" "uint" "int" "int" ] alien-invoke ;
-
-: cairo_surface_reference ( cairo_surface_t -- cairo_surface_t )
- "cairo_surface_t*" "cairo" "cairo_surface_reference" [ "cairo_surface_t*" ] alien-invoke ;
-
-: cairo_surface_finish ( cairo_surface_t -- )
- "void" "cairo" "cairo_surface_finish" [ "cairo_surface_t*" ] alien-invoke ;
-
-: cairo_surface_destroy ( cairo_surface_t -- )
- "void" "cairo" "cairo_surface_destroy" [ "cairo_surface_t*" ] alien-invoke ;
-
-: cairo_surface_get_reference_count ( cairo_surface_t -- count )
- "uint" "cairo" "cairo_surface_get_reference_count" [ "cairo_surface_t*" ] alien-invoke ;
-
-: cairo_surface_status ( cairo_surface_t -- cairo_status_t )
- "uint" "cairo" "cairo_surface_status" [ "cairo_surface_t*" ] alien-invoke ;
-
-: cairo_surface_flush ( cairo_surface_t -- )
- "void" "cairo" "cairo_surface_flush" [ "cairo_surface_t*" ] alien-invoke ;
-
-! painting functions
-: cairo_paint ( cairo_t -- )
- "void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_paint_with_alpha ( cairo_t alpha -- )
- "void" "cairo" "cairo_paint_with_alpha" [ "cairo_t*" "double" ] alien-invoke ;
-
-: cairo_mask ( cairo_t cairo_pattern_t -- )
- "void" "cairo" "cairo_mask" [ "cairo_t*" "void*" ] alien-invoke ;
-
-: cairo_mask_surface ( cairo_t cairo_pattern_t surface-x surface-y -- )
- "void" "cairo" "cairo_mask_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ;
-
-: cairo_stroke ( cairo_t -- )
- "void" "cairo" "cairo_stroke" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_stroke_preserve ( cairo_t -- )
- "void" "cairo" "cairo_stroke_preserve" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_fill ( cairo_t -- )
- "void" "cairo" "cairo_fill" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_fill_preserve ( cairo_t -- )
- "void" "cairo" "cairo_fill_preserve" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_copy_page ( cairo_t -- )
- "void" "cairo" "cairo_copy_page" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_show_page ( cairo_t -- )
- "void" "cairo" "cairo_show_page" [ "cairo_t*" ] alien-invoke ;
-
-! insideness testing
-: cairo_in_stroke ( cairo_t x y -- t/f )
- "int" "cairo" "cairo_in_stroke" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-: cairo_in_fill ( cairo_t x y -- t/f )
- "int" "cairo" "cairo_in_fill" [ "cairo_t*" "double" "double" ] alien-invoke ;
-
-! rectangular extents
-: cairo_stroke_extents ( cairo_t x1 y1 x2 y2 -- )
- "void" "cairo" "cairo_stroke_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_fill_extents ( cairo_t x1 y1 x2 y2 -- )
- "void" "cairo" "cairo_fill_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
-
-! clipping
-: cairo_reset_clip ( cairo_t -- )
- "void" "cairo" "cairo_reset_clip" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_clip ( cairo_t -- )
- "void" "cairo" "cairo_clip" [ "cairo_t*" ] alien-invoke ;
-
-: cairo_clip_preserve ( cairo_t -- )
- "void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ;
-
-
-: cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t )
- "void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_pattern_create_radial ( cx0 cy0 radius0 cx1 cy1 radius1 -- cairo_pattern_t )
- "void*" "cairo" "cairo_pattern_create_radial" [ "double" "double" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_pattern_add_color_stop_rgba ( pattern offset red green blue alpha -- status )
- "uint" "cairo" "cairo_pattern_add_color_stop_rgba" [ "void*" "double" "double" "double" "double" "double" ] alien-invoke ;
-
-: cairo_show_text ( cairo_t msg_utf8 -- )
- "void" "cairo" "cairo_show_text" [ "cairo_t*" "char*" ] alien-invoke ;
-
-: cairo_text_path ( cairo_t msg_utf8 -- )
- "void" "cairo" "cairo_text_path" [ "cairo_t*" "char*" ] alien-invoke ;
-
-: cairo_select_font_face ( cairo_t family font_slant font_weight -- )
- "void" "cairo" "cairo_select_font_face" [ "cairo_t*" "char*" "uint" "uint" ] alien-invoke ;
-
-: cairo_set_font_size ( cairo_t scale -- )
- "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ;
-
-: cairo_set_font_matrix ( cairo_t cairo_matrix_t -- )
- "void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
-
-: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- )
- "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
-
-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 ) ;
-
-! Cairo pdf
-
-: cairo_pdf_surface_create ( filename width height -- surface )
- "void*" "cairo" "cairo_pdf_surface_create" [ "char*" "double" "double" ] alien-invoke ;
-
-! Missing:
-
-! cairo_public cairo_surface_t *
-! cairo_pdf_surface_create_for_stream (cairo_write_func_t write_func,
-! void *closure,
-! double width_in_points,
-! double height_in_points);
-
-: cairo_pdf_surface_set_size ( surface width height -- )
- "void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ;
-
-! Cairo png
-
-TYPEDEF: void* cairo_write_func_t
-TYPEDEF: void* cairo_read_func_t
-
-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 ) ;
-
-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 ) ;
--- /dev/null
+! Bindings for Cairo library
+! Copyright (c) 2007 Sampo Vuori
+! License: http://factorcode.org/license.txt
+
+! Unimplemented:
+! - most of the font stuff
+! - most of the matrix stuff
+! - most of the query functions
+
+
+USING: alien alien.syntax combinators system ;
+
+IN: cairo.ffi
+
+<< "cairo" {
+ { [ win32? ] [ "cairo.dll" ] }
+ ! { [ macosx? ] [ "libcairo.dylib" ] }
+ { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ unix? ] [ "libcairo.so.2" ] }
+ } cond "cdecl" add-library >>
+
+LIBRARY: cairo
+
+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
+;
+
+TYPEDEF: int cairo_content_t
+: CAIRO_CONTENT_COLOR HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+
+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
+;
+
+TYPEDEF: int cairo_line_cap_t
+C-ENUM:
+ CAIRO_LINE_CAP_BUTT
+ CAIRO_LINE_CAP_ROUND
+ CAIRO_LINE_CAP_SQUARE
+;
+
+TYPEDEF: int cair_line_join_t
+C-ENUM:
+ CAIRO_LINE_JOIN_MITER
+ CAIRO_LINE_JOIN_ROUND
+ CAIRO_LINE_JOIN_BEVEL
+;
+
+TYPEDEF: int cairo_fill_rule_t
+C-ENUM:
+ CAIRO_FILL_RULE_WINDING
+ CAIRO_FILL_RULE_EVEN_ODD
+;
+
+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
+;
+
+C-STRUCT: cairo_font_t
+ { "int" "refcount" }
+ { "uint" "scale" } ;
+
+C-STRUCT: cairo_rectangle_t
+ { "short" "x" }
+ { "short" "y" }
+ { "ushort" "width" }
+ { "ushort" "height" } ;
+
+C-STRUCT: cairo_clip_rec_t
+ { "cairo_rectangle_t" "rect" }
+ { "void*" "region" }
+ { "void*" "surface" } ;
+
+C-STRUCT: cairo_matrix_t
+ { "void*" "m" } ;
+
+C-STRUCT: cairo_gstate_t
+ { "uint" "operator" }
+ { "double" "tolerance" }
+ { "double" "line_width" }
+ { "uint" "line_cap" }
+ { "uint" "line_join" }
+ { "double" "miter_limit" }
+ { "uint" "fill_rule" }
+ { "void*" "dash" }
+ { "int" "num_dashes" }
+ { "double" "dash_offset" }
+ { "char*" "font_family " }
+ { "uint" "font_slant" }
+ { "uint" "font_weight" }
+ { "void*" "font" }
+ { "void*" "surface" }
+ { "void*" "pattern " }
+ { "double" "alpha" }
+ { "cairo_clip_rec_t" "clip" }
+ { "double" "pixels_per_inch" }
+ { "cairo_matrix_t" "font_matrix" }
+ { "cairo_matrix_t" "ctm" }
+ { "cairo_matrix_t" "ctm_inverse" }
+ { "void*" "path" }
+ { "void*" "pen_regular" }
+ { "void*" "next" } ;
+
+C-STRUCT: cairo_t
+ { "uint" "ref_count" }
+ { "cairo_gstate_t*" "gstate" }
+ { "uint" "status ! cairo_status_t" } ;
+
+C-STRUCT: cairo_matrix_t
+ { "double" "xx" }
+ { "double" "yx" }
+ { "double" "xy" }
+ { "double" "yy" }
+ { "double" "x0" }
+ { "double" "y0" } ;
+
+TYPEDEF: int cairo_format_t
+C-ENUM:
+ CAIRO_FORMAT_ARGB32
+ CAIRO_FORMAT_RGB24
+ CAIRO_FORMAT_A8
+ CAIRO_FORMAT_A1
+;
+
+TYPEDEF: int cairo_antialias_t
+C-ENUM:
+ CAIRO_ANTIALIAS_DEFAULT
+ CAIRO_ANTIALIAS_NONE
+ CAIRO_ANTIALIAS_GRAY
+ CAIRO_ANTIALIAS_SUBPIXEL
+;
+
+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
+;
+
+: cairo_create ( cairo_surface_t -- cairo_t )
+ "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
+
+: cairo_reference ( cairo_t -- cairo_t )
+ "cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_destroy ( cairo_t -- )
+ "void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_save ( cairo_t -- )
+ "void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_restore ( cairo_t -- )
+ "void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_set_operator ( cairo_t cairo_operator_t -- )
+ "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ;
+
+: cairo_set_source ( cairo_t cairo_pattern_t -- )
+ "void" "cairo" "cairo_set_source" [ "cairo_t*" "void*" ] alien-invoke ;
+
+: cairo_set_source_rgb ( cairo_t red green blue -- )
+ "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" ] alien-invoke ;
+
+: cairo_set_source_rgba ( cairo_t red green blue alpha -- )
+ "void" "cairo" "cairo_set_source_rgb" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_set_source_surface ( cairo_t cairo_surface_t x y -- )
+ "void" "cairo" "cairo_set_source_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ;
+
+: cairo_set_tolerance ( cairo_t tolerance -- )
+ "void" "cairo" "cairo_set_tolerance" [ "cairo_t*" "double" ] alien-invoke ;
+
+: cairo_image_surface_create_for_data ( data format width height stride -- cairo_surface_t )
+ "void*" "cairo" "cairo_image_surface_create_for_data" [ "void*" "uint" "int" "int" "int" ] alien-invoke ;
+
+
+: cairo_set_antialias ( cairo_t cairo_antialias_t -- )
+ "void" "cairo" "cairo_set_antialias" [ "cairo_t*" "int" ] alien-invoke ;
+
+: cairo_set_fill_rule ( cairo_t cairo_fill_rule_t -- )
+ "void" "cairo" "cairo_set_fill_rule" [ "cairo_t*" "int" ] alien-invoke ;
+
+: cairo_set_line_width ( cairo_t width -- )
+ "void" "cairo" "cairo_set_line_width" [ "cairo_t*" "double" ] alien-invoke ;
+
+: cairo_set_line_cap ( cairo_t cairo_line_cap_t -- )
+ "void" "cairo" "cairo_set_line_cap" [ "cairo_t*" "int" ] alien-invoke ;
+
+: cairo_set_line_join ( cairo_t cairo_line_join_t -- )
+ "void" "cairo" "cairo_set_line_join" [ "cairo_t*" "int" ] alien-invoke ;
+
+: cairo_set_dash ( cairo_t dashes num_dashes offset -- )
+ "void" "cairo" "cairo_set_dash" [ "cairo_t*" "double" "int" "double" ] alien-invoke ;
+
+: cairo_set_miter_limit ( cairo_t limit -- )
+ "void" "cairo" "cairo_set_miter_limit" [ "cairo_t*" "double" ] alien-invoke ;
+
+: cairo_translate ( cairo_t x y -- )
+ "void" "cairo" "cairo_translate" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_scale ( cairo_t sx sy -- )
+ "void" "cairo" "cairo_scale" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_rotate ( cairo_t angle -- )
+ "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ;
+
+: cairo_transform ( cairo_t cairo_matrix_t -- )
+ "void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+: cairo_set_matrix ( cairo_t cairo_matrix_t -- )
+ "void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+: cairo_identity_matrix ( cairo_t -- )
+ "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;
+
+! cairo path creating functions
+
+: cairo_new_path ( cairo_t -- )
+ "void" "cairo" "cairo_new_path" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_move_to ( cairo_t x y -- )
+ "void" "cairo" "cairo_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_new_sub_path ( cairo_t -- )
+ "void" "cairo" "cairo_new_sub_path" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_line_to ( cairo_t x y -- )
+ "void" "cairo" "cairo_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_curve_to ( cairo_t x1 y1 x2 y2 x3 y3 -- )
+ "void" "cairo" "cairo_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_arc ( cairo_t xc yc radius angle1 angle2 -- )
+ "void" "cairo" "cairo_arc" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_arc_negative ( cairo_t xc yc radius angle1 angle2 -- )
+ "void" "cairo" "cairo_arc_negative" [ "cairo_t*" "double" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_rel_move_to ( cairo_t dx dy -- )
+ "void" "cairo" "cairo_rel_move_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_rel_line_to ( cairo_t dx dy -- )
+ "void" "cairo" "cairo_rel_line_to" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_rel_curve_to ( cairo_t dx1 dy1 dx2 dy2 dx3 dy3 -- )
+ "void" "cairo" "cairo_rel_curve_to" [ "cairo_t*" "double" "double" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_rectangle ( cairo_t x y width height -- )
+ "void" "cairo" "cairo_rectangle" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_close_path ( cairo_t -- )
+ "void" "cairo" "cairo_close_path" [ "cairo_t*" ] alien-invoke ;
+
+! Surface manipulation
+
+: cairo_surface_create_similar ( cairo_surface_t cairo_content_t width height -- cairo_surface_t )
+ "cairo_surface_t*" "cairo" "cairo_surface_create_similar" [ "cairo_surface_t*" "uint" "int" "int" ] alien-invoke ;
+
+: cairo_surface_reference ( cairo_surface_t -- cairo_surface_t )
+ "cairo_surface_t*" "cairo" "cairo_surface_reference" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_finish ( cairo_surface_t -- )
+ "void" "cairo" "cairo_surface_finish" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_destroy ( cairo_surface_t -- )
+ "void" "cairo" "cairo_surface_destroy" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_get_reference_count ( cairo_surface_t -- count )
+ "uint" "cairo" "cairo_surface_get_reference_count" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_status ( cairo_surface_t -- cairo_status_t )
+ "uint" "cairo" "cairo_surface_status" [ "cairo_surface_t*" ] alien-invoke ;
+
+: cairo_surface_flush ( cairo_surface_t -- )
+ "void" "cairo" "cairo_surface_flush" [ "cairo_surface_t*" ] alien-invoke ;
+
+! painting functions
+: cairo_paint ( cairo_t -- )
+ "void" "cairo" "cairo_paint" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_paint_with_alpha ( cairo_t alpha -- )
+ "void" "cairo" "cairo_paint_with_alpha" [ "cairo_t*" "double" ] alien-invoke ;
+
+: cairo_mask ( cairo_t cairo_pattern_t -- )
+ "void" "cairo" "cairo_mask" [ "cairo_t*" "void*" ] alien-invoke ;
+
+: cairo_mask_surface ( cairo_t cairo_pattern_t surface-x surface-y -- )
+ "void" "cairo" "cairo_mask_surface" [ "cairo_t*" "void*" "double" "double" ] alien-invoke ;
+
+: cairo_stroke ( cairo_t -- )
+ "void" "cairo" "cairo_stroke" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_stroke_preserve ( cairo_t -- )
+ "void" "cairo" "cairo_stroke_preserve" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_fill ( cairo_t -- )
+ "void" "cairo" "cairo_fill" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_fill_preserve ( cairo_t -- )
+ "void" "cairo" "cairo_fill_preserve" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_copy_page ( cairo_t -- )
+ "void" "cairo" "cairo_copy_page" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_show_page ( cairo_t -- )
+ "void" "cairo" "cairo_show_page" [ "cairo_t*" ] alien-invoke ;
+
+! insideness testing
+: cairo_in_stroke ( cairo_t x y -- t/f )
+ "int" "cairo" "cairo_in_stroke" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+: cairo_in_fill ( cairo_t x y -- t/f )
+ "int" "cairo" "cairo_in_fill" [ "cairo_t*" "double" "double" ] alien-invoke ;
+
+! rectangular extents
+: cairo_stroke_extents ( cairo_t x1 y1 x2 y2 -- )
+ "void" "cairo" "cairo_stroke_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_fill_extents ( cairo_t x1 y1 x2 y2 -- )
+ "void" "cairo" "cairo_fill_extents" [ "cairo_t*" "double" "double" "double" "double" ] alien-invoke ;
+
+! clipping
+: cairo_reset_clip ( cairo_t -- )
+ "void" "cairo" "cairo_reset_clip" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_clip ( cairo_t -- )
+ "void" "cairo" "cairo_clip" [ "cairo_t*" ] alien-invoke ;
+
+: cairo_clip_preserve ( cairo_t -- )
+ "void" "cairo" "cairo_clip_preserve" [ "cairo_t*" ] alien-invoke ;
+
+
+: cairo_pattern_create_linear ( x0 y0 x1 y1 -- cairo_pattern_t )
+ "void*" "cairo" "cairo_pattern_create_linear" [ "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_pattern_create_radial ( cx0 cy0 radius0 cx1 cy1 radius1 -- cairo_pattern_t )
+ "void*" "cairo" "cairo_pattern_create_radial" [ "double" "double" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_pattern_add_color_stop_rgba ( pattern offset red green blue alpha -- status )
+ "uint" "cairo" "cairo_pattern_add_color_stop_rgba" [ "void*" "double" "double" "double" "double" "double" ] alien-invoke ;
+
+: cairo_show_text ( cairo_t msg_utf8 -- )
+ "void" "cairo" "cairo_show_text" [ "cairo_t*" "char*" ] alien-invoke ;
+
+: cairo_text_path ( cairo_t msg_utf8 -- )
+ "void" "cairo" "cairo_text_path" [ "cairo_t*" "char*" ] alien-invoke ;
+
+: cairo_select_font_face ( cairo_t family font_slant font_weight -- )
+ "void" "cairo" "cairo_select_font_face" [ "cairo_t*" "char*" "uint" "uint" ] alien-invoke ;
+
+: cairo_set_font_size ( cairo_t scale -- )
+ "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ;
+
+: cairo_set_font_matrix ( cairo_t cairo_matrix_t -- )
+ "void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- )
+ "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
+
+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 ) ;
+
+! Cairo pdf
+
+: cairo_pdf_surface_create ( filename width height -- surface )
+ "void*" "cairo" "cairo_pdf_surface_create" [ "char*" "double" "double" ] alien-invoke ;
+
+! Missing:
+
+! cairo_public cairo_surface_t *
+! cairo_pdf_surface_create_for_stream (cairo_write_func_t write_func,
+! void *closure,
+! double width_in_points,
+! double height_in_points);
+
+: cairo_pdf_surface_set_size ( surface width height -- )
+ "void" "cairo" "cairo_pdf_surface_set_size" [ "void*" "double" "double" ] alien-invoke ;
+
+! Cairo png
+
+TYPEDEF: void* cairo_write_func_t
+TYPEDEF: void* cairo_read_func_t
+
+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 ) ;
+
+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 ) ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types cairo.ffi continuations destructors
+kernel libc locals math combinators.cleave shuffle new-slots
+accessors ;
+IN: cairo.lib
+
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
+: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
+
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: cairo-surface-t-destroy-always ( alien -- )
+ <cairo-surface-t> add-always-destructor ;
+
+: cairo-surface-t-destroy-later ( alien -- )
+ <cairo-surface-t> add-error-destructor ;
+
+: cairo-surface>array ( surface -- cairo-t byte-array )
+ [
+ dup
+ [ drop CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height ] tri
+ over 4 *
+ 2dup * [
+ malloc dup free-always [
+ 5 -nrot cairo_image_surface_create_for_data
+ dup cairo-surface-t-destroy-always
+ cairo_create dup cairo-t-destroy-later
+ [ swap 0 0 cairo_set_source_surface ] keep
+ dup cairo_paint
+ ] keep
+ ] keep memory>byte-array
+ ] with-destructors ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.cleave kernel new-slots
+accessors math ui.gadgets ui.render opengl.gl byte-arrays
+namespaces opengl cairo.ffi cairo.lib ;
+IN: cairo.png
+
+TUPLE: png surface width height cairo-t array ;
+TUPLE: png-gadget png ;
+
+: <png> ( path -- png )
+ cairo_image_surface_create_from_png
+ dup [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height ] [ ] tri
+ cairo-surface>array png construct-boa ;
+
+: write-png ( png path -- )
+ >r png-surface r>
+ cairo_surface_write_to_png
+ zero? [ "write png failed" throw ] unless ;
+
+: <png-gadget> ( path -- gadget )
+ png-gadget construct-gadget swap
+ <png> >>png ;
+
+M: png-gadget pref-dim* ( gadget -- )
+ png>>
+ [ width>> ] [ height>> ] bi 2array ;
+
+M: png-gadget draw-gadget* ( gadget -- )
+ origin get [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ png>>
+ [ width>> ]
+ [ height>> GL_RGBA GL_UNSIGNED_BYTE ]
+ [ array>> ] tri
+ glDrawPixels
+ ] with-translation ;
+
+M: png-gadget graft* ( gadget -- )
+ drop ;
+
+M: png-gadget ungraft* ( gadget -- )
+ png>> surface>> cairo_destroy ;
swap
[ [ r> ] swap append ] map concat
append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Cleave into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: words quotations fry arrays.lib ;
+
+: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+
+: >quots ( seq -- seq ) [ >quot ] map ;
+
+MACRO: <arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ , cleave , narray ] ;
+
+MACRO: <2arr> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ , 2cleave , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Spread into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr*> ( seq -- )
+ [ >quots ] [ length ] bi
+ '[ , spread , narray ] ;
--- /dev/null
+IN: db.tests\r
+USING: tools.test db kernel ;\r
+\r
+{ 1 0 } [ [ drop ] query-each ] must-infer-as\r
+{ 1 1 } [ [ ] query-map ] must-infer-as\r
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
+TUPLE: nonthrowable-statement ;
+: make-nonthrowable ( obj -- obj' )
+ dup sequence? [
+ [ make-nonthrowable ] map
+ ] [
+ nonthrowable-statement construct-delegate
+ ] if ;
+
+MIXIN: throwable-statement
+INSTANCE: statement throwable-statement
+INSTANCE: simple-statement throwable-statement
+INSTANCE: prepared-statement throwable-statement
+
TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( sql in out -- statement )
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
-: execute-statement ( statement -- )
+GENERIC: execute-statement ( statement -- )
+
+M: throwable-statement execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
+M: nonthrowable-statement execute-statement ( statement -- )
+ dup sequence? [
+ [ execute-statement ] each
+ ] [
+ [ query-results dispose ] [ 2drop ] recover
+ ] if ;
+
: bind-statement ( obj statement -- )
swap >>bind-params
[ bind-statement* ] keep
sql-spec-type {
{ FACTOR-BLOB [
dup [
- binary [ serialize ] with-byte-writer
+ object>bytes
malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [
dup [ malloc-byte-array/length ] [ 0 ] if ] }
{ BLOB [ pq-get-blob ] }
{ FACTOR-BLOB [
pq-get-blob
- dup [ binary [ deserialize ] with-byte-reader ] when ] }
+ dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
! PQgetlength PQgetisnull
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
+INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
: postgresql-make ( class quot -- )
>r sql-props r>
- [ postgresql-counter off ] swap compose
- { "" { } { } } nmake <postgresql-statement> ;
+ [ postgresql-counter off call ] { "" { } { } } nmake
+ <postgresql-statement> ; inline
: create-table-sql ( class -- statement )
[
");" 0%
] postgresql-make ;
-M: postgresql-db <insert-assigned-statement> ( class -- statement )
+M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
{ TIMESTAMP [ sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
- binary [ serialize ] with-byte-writer
+ object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
[ no-sql-type ]
} case ;
-: sqlite-finalize ( handle -- )
- sqlite3_finalize sqlite-check-result ;
-
-: sqlite-reset ( handle -- )
- sqlite3_reset sqlite-check-result ;
-
-: sqlite-#columns ( query -- int )
- sqlite3_column_count ;
-
-: sqlite-column ( handle index -- string )
- sqlite3_column_text ;
+: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-#columns ( query -- int ) sqlite3_column_count ;
+: sqlite-column ( handle index -- string ) sqlite3_column_text ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
: sqlite-column-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep
dup array? [ first ] when
{
{ +native-id+ [ sqlite3_column_int64 ] }
+ { +random-id+ [ sqlite3_column_int64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }
{ DOUBLE [ sqlite3_column_double ] }
{ BLOB [ sqlite-column-blob ] }
{ FACTOR-BLOB [
sqlite-column-blob
- dup [ binary [ deserialize ] with-byte-reader ] when
+ dup [ bytes>object ] when
] }
! { NULL [ 2drop f ] }
[ no-sql-type ]
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
-: sqlite-step-has-more-rows? ( step-result -- bool )
+: sqlite-step-has-more-rows? ( prepared -- bool )
dup SQLITE_ROW = [
drop t
] [
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
combinators.cleave io namespaces.lib ;
+USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db path ;
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
-M: sqlite-db db-close ( handle -- )
- sqlite-close ;
-
+M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-
-: with-sqlite ( path quot -- )
- sqlite-db swap with-db ; inline
+: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
+INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-result-set has-more? ;
set-statement-in-params
set-statement-out-params
} statement construct
- db get db-handle over statement-sql sqlite-prepare
- over set-statement-handle
sqlite-statement construct-delegate ;
+: sqlite-maybe-prepare ( statement -- statement )
+ dup statement-handle [
+ [
+ delegate
+ db get db-handle over statement-sql sqlite-prepare
+ swap set-statement-handle
+ ] keep
+ ] unless ;
+
M: sqlite-statement dispose ( statement -- )
- statement-handle sqlite-finalize ;
+ statement-handle
+ [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
+ sqlite-maybe-prepare
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
+ sqlite-maybe-prepare
dup statement-bound? [ dup reset-statement ] when
[ statement-bind-params ] [ statement-handle ] bi
sqlite-bind ;
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
+ sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
-M: sqlite-db begin-transaction ( -- )
- "BEGIN" sql-command ;
-
-M: sqlite-db commit-transaction ( -- )
- "COMMIT" sql-command ;
-
-M: sqlite-db rollback-transaction ( -- )
- "ROLLBACK" sql-command ;
+M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
+M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
+M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
- { "" { } { } } nmake <simple-statement> ;
+ { "" { } { } } nmake <simple-statement> ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
] sqlite-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
- [
- "drop table " 0% 0% ";" 0% drop
- ] sqlite-make ;
+ [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
");" 0%
] sqlite-make ;
-M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
+ { +random-id+ "primary key" }
+ ! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +not-null+ "not null" }
} ;
-M: sqlite-db compound-modifier ( str obj -- newstr )
- compound-type ;
+M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
-M: sqlite-db compound-type ( str seq -- newstr )
+M: sqlite-db compound-type ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
+ { +random-id+ "integer primary key" }
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ FACTOR-BLOB "blob" }
} ;
-M: sqlite-db create-type-table
- type-table ;
+M: sqlite-db create-type-table ( symbol -- str ) type-table ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
-: <person> ( name age real ts date time blob -- person )
+: <person> ( name age real ts date time blob factor-blob -- person )
{
set-person-the-name
set-person-the-number
: test-postgresql ( -- )
>r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
-[ native-person-schema test-tuples ] test-sqlite
-[ assigned-person-schema test-tuples ] test-sqlite
-
-! [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-tuples ] test-postgresql
+: test-repeated-insert
+ [ ] [ person ensure-table ] unit-test
+
+ [ ] [ person1 get insert-tuple ] unit-test
+ [ person1 get insert-tuple ] must-fail ;
TUPLE: serialize-me id data ;
;
! [ test-ranges ] test-sqlite
+
+TUPLE: secret n message ;
+C: <secret> secret
+
+: test-random-id
+ secret "SECRET"
+ {
+ { "n" "ID" +random-id+ }
+ { "message" "MESSAGE" TEXT }
+ } define-persistent
+
+ [ ] [ secret ensure-table ] unit-test
+ [ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
+ [ ] [ T{ secret } select-tuples ] unit-test
+ ;
+
+
+
+! [ test-random-id ] test-sqlite
+ [ native-person-schema test-tuples ] test-sqlite
+ [ assigned-person-schema test-tuples ] test-sqlite
+! [ assigned-person-schema test-repeated-insert ] test-sqlite
+! [ native-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-repeated-insert ] test-postgresql
+
+! \ insert-tuple must-infer
+! \ update-tuple must-infer
+! \ delete-tuple must-infer
+! \ select-tuple must-infer
+! \ define-persistent must-infer
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( class -- obj )
+HOOK: <insert-nonnative-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
-HOOK: <select-by-slots-statement> db ( tuple -- tuple )
+HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
- [ dup drop-table ] ignore-errors create-table ;
+ [
+ drop-sql-statement make-nonthrowable
+ [ execute-statement ] with-disposals
+ ] [ create-table ] bi ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
-: insert-assigned ( tuple -- )
+: insert-nonnative ( tuple -- )
+! TODO logic here for unique ids
dup class
- db get db-insert-statements [ <insert-assigned-statement> ] cache
+ db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key assigned-id? [
- insert-assigned
+ dup class db-columns find-primary-key nonnative-id? [
+ insert-nonnative
] [
insert-native
] if ;
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols ;
+mirrors tuples combinators calendar.format symbols
+singleton ;
IN: db.types
HOOK: modifier-table db ( -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
-SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
-+serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ ;
+SINGLETON: +native-id+
+SINGLETON: +assigned-id+
+SINGLETON: +random-id+
+UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
+UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
-: (primary-key?) ( obj -- ? )
- { +native-id+ +assigned-id+ } member? ;
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
++foreign-id+ +has-many+ ;
: primary-key? ( spec -- ? )
- sql-spec-primary-key (primary-key?) ;
+ sql-spec-primary-key +primary-key+? ;
+
+: native-id? ( spec -- ? )
+ sql-spec-primary-key +native-id+? ;
+
+: nonnative-id? ( spec -- ? )
+ sql-spec-primary-key +nonnative-id+? ;
: normalize-spec ( spec -- )
- dup sql-spec-type dup (primary-key?) [
+ dup sql-spec-type dup +primary-key+? [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
- (primary-key?)
+ +primary-key+?
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
-: native-id? ( spec -- ? )
- sql-spec-primary-key +native-id+ = ;
-
-: assigned-id? ( spec -- ? )
- sql-spec-primary-key +assigned-id+ = ;
-
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
dup number? [ number>string ] when ;
: maybe-remove-id ( specs -- obj )
- [ native-id? not ] subset ;
+ [ +native-id+? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;
swap { } like "protocol-words" set-word-prop ;
: PROTOCOL:
- CREATE dup reset-generic dup define-symbol
+ CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
- pick add spin define-method ;
+ pick add >r swap create-method r> define ;
: define-consult ( class group quot -- )
- >r group-words r>
- swapd [ define-consult-method ] 2curry each ;
+ >r group-words swap r>
+ [ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition swapd define-consult ; parsing
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
- [ "method-def" word-prop spin define-method ]
+ [ >r swap create-method r> word-def define ]
[ 3drop ] if
] 2curry each ;
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
+: dispose-each ( seq -- )
+ <reversed> [ dispose ] each ;
+
: do-always-destructors ( -- )
- always-destructors get [ dispose ] each ;
+ always-destructors get dispose-each ;
: do-error-destructors ( -- )
- error-destructors get [ dispose ] each ;
+ error-destructors get dispose-each ;
: with-destructors ( quot -- )
[
USING: tools.deploy.config ;
H{
- { deploy-io 2 }
- { deploy-math? f }
- { deploy-threads? f }
- { deploy-compiler? f }
- { deploy-word-props? f }
- { deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
- { deploy-reflection 2 }
+ { deploy-threads? f }
{ deploy-c-types? f }
+ { deploy-compiler? f }
{ deploy-ui? f }
+ { deploy-math? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-io 2 }
+ { deploy-word-props? f }
{ "stop-after-last-window?" t }
}
--- /dev/null
+IN: help.tests
+USING: tools.test help kernel ;
+
+[ 3 throw ] must-fail
+[ ] [ :help ] unit-test
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print
- ":vars - list all variables at error time";
+ ":vars - list all variables at error time" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] subset
port: 80
version: "1.1"
cookies: V{ }
+ header: H{ }
}
] [
[
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
-[ "" ] [ "%XX%XX%X" 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
request construct-empty
"1.1" >>version
http-port >>port
+ H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies ;
IN: http.server.actions.tests
-USING: http.server.actions tools.test math math.parser
-multiline namespaces http io.streams.string http.server
-sequences accessors ;
+USING: http.server.actions http.server.validators
+tools.test math math.parser multiline namespaces http
+io.streams.string http.server sequences accessors ;
+
+[
+ "a" [ v-number ] { { "a" "123" } } validate-param
+ [ 123 ] [ "a" get ] unit-test
+] with-scope
<action>
[ "a" get "b" get + ] >>display
- { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
+ { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
STRING: action-request-test-1
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
- { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+ { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors new-slots sequences kernel assocs combinators\r
http.server http.server.validators http hashtables namespaces\r
-combinators.cleave fry continuations ;\r
+combinators.cleave fry continuations locals ;\r
IN: http.server.actions\r
\r
SYMBOL: +path+\r
[ <400> ] >>display\r
[ <400> ] >>submit ;\r
\r
-: with-validator ( string quot -- result error? )\r
- '[ , @ f ] [\r
- dup validation-error? [ t ] [ rethrow ] if\r
- ] recover ; inline\r
-\r
-: validate-param ( name validator assoc -- error? )\r
- swap pick\r
- >r >r at r> with-validator swap r> set ;\r
+:: validate-param ( name validator assoc -- )\r
+ name assoc at validator with-validator name set ; inline\r
\r
: action-params ( validators -- error? )\r
- [ params get validate-param ] { } assoc>map [ ] contains? ;\r
+ validation-failed? off\r
+ params get '[ , validate-param ] assoc-each\r
+ validation-failed? get ;\r
\r
: handle-get ( -- response )\r
action get get-params>> action-params [ <400> ] [\r
action get display>> call exit-with ;\r
\r
M: action call-responder ( path action -- response )\r
- [ +path+ associate request-params union params set ]\r
- [ action set ] bi*\r
- request get method>> {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case ;\r
+ '[\r
+ , ,\r
+ [ +path+ associate request-params union params set ]\r
+ [ action set ] bi*\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case\r
+ ] with-exit-continuation ;\r
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: http.server.sessions accessors\r
-http.server.auth.providers ;\r
+http.server.auth.providers assocs namespaces kernel ;\r
IN: http.server.auth\r
\r
SYMBOL: logged-in-user\r
+SYMBOL: user-profile-changed?\r
+\r
+GENERIC: init-user-profile ( responder -- )\r
+\r
+M: object init-user-profile drop ;\r
\r
: uid ( -- string ) logged-in-user sget username>> ;\r
+\r
+: profile ( -- assoc ) logged-in-user sget profile>> ;\r
+\r
+: uget ( key -- value )\r
+ profile at ;\r
+\r
+: uset ( value key -- )\r
+ profile set-at user-profile-changed? on ;\r
+\r
+: uchange ( quot key -- )\r
+ profile swap change-at\r
+ user-profile-changed? on ; inline\r
--- /dev/null
+<% USING: http.server.components http.server.auth.login\r
+http.server namespaces kernel combinators ; %>\r
+<html>\r
+<body>\r
+<h1>Edit profile</h1>\r
+\r
+<form method="POST" action="edit-profile">\r
+<% hidden-form-field %>\r
+\r
+<table>\r
+\r
+<tr>\r
+<td>User name:</td>\r
+<td><% "username" component render-view %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Real name:</td>\r
+<td><% "realname" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Specifying a real name is optional.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Current password:</td>\r
+<td><% "password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>If you don't want to change your current password, leave this field blank.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td>New password:</td>\r
+<td><% "new-password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Verify:</td>\r
+<td><% "verify-password" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>If you are changing your password, enter it twice to ensure it is correct.</td>\r
+</tr>\r
+\r
+<tr>\r
+<td>E-mail:</td>\r
+<td><% "email" component render-edit %></td>\r
+</tr>\r
+\r
+<tr>\r
+<td></td>\r
+<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
+</tr>\r
+\r
+</table>\r
+\r
+<p><input type="submit" value="Update" />\r
+\r
+<% {\r
+ { [ login-failed? get ] [ "invalid password" render-error ] }\r
+ { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
+ { [ t ] [ ] }\r
+} cond %>\r
+\r
+</p>\r
+\r
+</form>\r
+\r
+</body>\r
+</html>\r
http.server.templating.fhtml http.server.validators\r
http.server.auth http sequences io.files namespaces hashtables\r
fry io.sockets combinators.cleave arrays threads locals\r
-qualified ;\r
+qualified continuations destructors ;\r
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
-TUPLE: login users ;\r
-\r
SYMBOL: post-login-url\r
SYMBOL: login-failed?\r
\r
+TUPLE: login users ;\r
+\r
+: users login get users>> ;\r
+\r
+! Destructor\r
+TUPLE: user-saver user ;\r
+\r
+C: <user-saver> user-saver\r
+\r
+M: user-saver dispose\r
+ user-profile-changed? get [\r
+ user>> users update-user\r
+ ] [ drop ] if ;\r
+\r
+: save-user-after ( user -- )\r
+ <user-saver> add-always-destructor ;\r
+\r
! ! ! Login\r
\r
: <login-form>\r
form validate-form\r
\r
"password" value "username" value\r
- login get users>> check-login [\r
+ users check-login [\r
successful-login\r
] [\r
login-failed? on\r
t >>required\r
add-field\r
"realname" <string> add-field\r
- "password" <password>\r
+ "
new-password" <password>
\r t >>required\r
add-field\r
"verify-password" <password>\r
SYMBOL: user-exists?\r
\r
: same-password-twice ( -- )\r
- "password" value "verify-password" value = [ \r
+ "new-password" value "verify-password" value = [ \r
password-mismatch? on\r
validation-failed\r
] unless ;\r
\r
same-password-twice\r
\r
- <user> values get [\r
- "username" get >>username\r
- "realname" get >>realname\r
- "password" get >>password\r
- "email" get >>email\r
- ] bind\r
+ <user>\r
+ "username" value >>username\r
+ "realname" value >>realname\r
+ "new-password" value >>password\r
+ "email" value >>email\r
\r
- login get users>> new-user [\r
+ users new-user [\r
user-exists? on\r
validation-failed\r
] unless*\r
\r
successful-login\r
+\r
+ login get responder>> init-user-profile\r
+ ] >>submit\r
+ ] ;\r
+\r
+! ! ! Editing user profile\r
+\r
+: <edit-profile-form> ( -- form )\r
+ "edit-profile" <form>\r
+ "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template\r
+ "username" <username> add-field\r
+ "realname" <string> add-field\r
+ "password" <password> add-field\r
+ "new-password" <password> add-field\r
+ "verify-password" <password> add-field\r
+ "email" <email> add-field ;\r
+\r
+SYMBOL: previous-page\r
+\r
+:: <edit-profile-action> ( -- action )\r
+ [let | form [ <edit-profile-form> ] |\r
+ <action>\r
+ [\r
+ blank-values\r
+ logged-in-user sget\r
+ dup username>> "username" set-value\r
+ dup realname>> "realname" set-value\r
+ dup email>> "email" set-value\r
+ ] >>init\r
+\r
+ [\r
+ "text/html" <content>\r
+ [ form edit-form ] >>body\r
+ ] >>display\r
+\r
+ [\r
+ blank-values\r
+ uid "username" set-value\r
+\r
+ form validate-form\r
+\r
+ logged-in-user sget\r
+\r
+ "password" value empty? [\r
+ same-password-twice\r
+\r
+ "password" value uid users check-login\r
+ [ login-failed? on validation-failed ] unless\r
+\r
+ "new-password" value set-password\r
+ ] unless\r
+\r
+ "realname" value >>realname\r
+ "email" value >>email\r
+\r
+ user-profile-changed? on\r
+\r
+ previous-page sget f <permanent-redirect>\r
] >>submit\r
] ;\r
\r
form validate-form\r
\r
"email" value "username" value\r
- login get users>> issue-ticket [\r
+ users issue-ticket [\r
send-password-email\r
] when*\r
\r
"username" <username> <hidden>\r
t >>required\r
add-field\r
- "password" <password>\r
+ "
new-password" <password>
\r t >>required\r
add-field\r
"verify-password" <password>\r
\r
"ticket" value\r
"username" value\r
- login get users>> claim-ticket [\r
- "password" value >>password\r
- login get users>> update-user\r
+ users claim-ticket [\r
+ "new-password" value >>password\r
+ users update-user\r
\r
"resource:extra/http/server/auth/login/recover-4.fhtml"\r
serve-template\r
\r
C: <protected> protected\r
\r
+: show-login-page ( -- response )\r
+ request get request-url post-login-url sset\r
+ "login" f <permanent-redirect> ;\r
+\r
M: protected call-responder ( path responder -- response )\r
- logged-in-user sget [ responder>> call-responder ] [\r
+ logged-in-user sget [\r
+ dup save-user-after\r
+ request get request-url previous-page sset\r
+ responder>> call-responder\r
+ ] [\r
2drop\r
- request get method>> { "GET" "HEAD" } member? [\r
- request get request-url post-login-url sset\r
- "login" f <permanent-redirect>\r
- ] [ <400> ] if\r
+ request get method>> { "GET" "HEAD" } member?\r
+ [ show-login-page ] [ <400> ] if\r
] if ;\r
\r
M: login call-responder ( path responder -- response )\r
swap <protected> >>default\r
<login-action> "login" add-responder\r
<logout-action> "logout" add-responder\r
- no >>users ;\r
+ no-users >>users ;\r
\r
! ! ! Configuration\r
\r
+: allow-edit-profile ( login -- login )\r
+ <edit-profile-action> <protected> "edit-profile" add-responder ;\r
+\r
: allow-registration ( login -- login )\r
<register-action> "register" add-responder ;\r
\r
<recover-action-1> "recover-password" add-responder\r
<recover-action-3> "new-password" add-responder ;\r
\r
+: allow-edit-profile? ( -- ? )\r
+ login get responders>> "edit-profile" swap key? ;\r
+\r
: allow-registration? ( -- ? )\r
login get responders>> "register" swap key? ;\r
\r
\r
<tr>\r
<td>Password:</td>\r
-<td><% "password" component render-edit %></td>\r
+<td><% "new-password" component render-edit %></td>\r
</tr>\r
\r
<tr>\r
\r
<tr>\r
<td>Password:</td>\r
-<td><% "password" component render-edit %></td>\r
+<td><% "new-password" component render-edit %></td>\r
</tr>\r
\r
<tr>\r
http.server.auth.providers.assoc tools.test\r
namespaces accessors kernel ;\r
\r
-<in-memory> "provider" set\r
+<users-in-memory> "provider" set\r
\r
[ t ] [\r
<user>\r
\r
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
-[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test\r
\r
-[ f ] [ "xx" "blah" "provider" get set-password ] unit-test\r
+[ t ] [ "user" get >boolean ] unit-test\r
\r
-[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test\r
+[ ] [ "user" get "fdasf" set-password drop ] unit-test\r
\r
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
USING: new-slots accessors assocs kernel\r
http.server.auth.providers ;\r
\r
-TUPLE: in-memory assoc ;\r
+TUPLE: users-in-memory assoc ;\r
\r
-: <in-memory> ( -- provider )\r
- H{ } clone in-memory construct-boa ;\r
+: <users-in-memory> ( -- provider )\r
+ H{ } clone users-in-memory construct-boa ;\r
\r
-M: in-memory get-user ( username provider -- user/f )\r
+M: users-in-memory get-user ( username provider -- user/f )\r
assoc>> at ;\r
\r
-M: in-memory update-user ( user provider -- ) 2drop ;\r
+M: users-in-memory update-user ( user provider -- ) 2drop ;\r
\r
-M: in-memory new-user ( user provider -- user/f )\r
+M: users-in-memory new-user ( user provider -- user/f )\r
>r dup username>> r> assoc>>\r
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;\r
namespaces db db.sqlite db.tuples continuations\r
io.files accessors kernel ;\r
\r
-from-db "provider" set\r
+users-in-db "provider" set\r
\r
"auth-test.db" temp-file sqlite-db [\r
\r
- [ user drop-table ] ignore-errors\r
- [ user create-table ] ignore-errors\r
+ init-users-table\r
\r
[ t ] [\r
<user>\r
- "slava" >>username\r
- "foobar" >>password\r
- "slava@factorcode.org" >>email\r
- "provider" get new-user\r
- username>> "slava" =\r
+ "slava" >>username\r
+ "foobar" >>password\r
+ "slava@factorcode.org" >>email\r
+ "provider" get new-user\r
+ username>> "slava" =\r
] unit-test\r
\r
[ f ] [\r
<user>\r
- "slava" >>username\r
+ "slava" >>username\r
"provider" get new-user\r
] unit-test\r
\r
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
- [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test\r
+ [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test\r
+\r
+ [ t ] [ "user" get >boolean ] unit-test\r
\r
- [ f ] [ "xx" "blah" "provider" get set-password ] unit-test\r
+ [ ] [ "user" get "fdasf" set-password drop ] unit-test\r
\r
- [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test\r
+ [ ] [ "user" get "provider" get update-user ] unit-test\r
\r
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: db db.tuples db.types new-slots accessors\r
-http.server.auth.providers kernel continuations ;\r
+http.server.auth.providers kernel continuations\r
+singleton ;\r
IN: http.server.auth.providers.db\r
\r
user "USERS"\r
\r
: init-users-table user ensure-table ;\r
\r
-TUPLE: from-db ;\r
-\r
-: from-db T{ from-db } ;\r
+SINGLETON: users-in-db\r
\r
: find-user ( username -- user )\r
<user>\r
swap >>username\r
select-tuple ;\r
\r
-M: from-db get-user\r
+M: users-in-db get-user\r
drop\r
find-user ;\r
\r
-M: from-db new-user\r
+M: users-in-db new-user\r
drop\r
[\r
dup username>> find-user [\r
] if\r
] with-transaction ;\r
\r
-M: from-db update-user\r
+M: users-in-db update-user\r
drop update-tuple ;\r
USING: http.server.auth.providers kernel ;\r
IN: http.server.auth.providers.null\r
\r
-! Named "no" because we can say no >>users\r
+TUPLE: no-users ;\r
\r
-TUPLE: no ;\r
+: no-users T{ no-users } ;\r
\r
-: no T{ no } ;\r
+M: no-users get-user 2drop f ;\r
\r
-M: no get-user 2drop f ;\r
+M: no-users new-user 2drop f ;\r
\r
-M: no new-user 2drop f ;\r
-\r
-M: no update-user 2drop ;\r
+M: no-users update-user 2drop ;\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel new-slots accessors random math.parser locals\r
-sequences math ;\r
+sequences math crypto.sha2 ;\r
IN: http.server.auth.providers\r
\r
TUPLE: user username realname password email ticket profile ;\r
: check-login ( password username provider -- user/f )\r
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;\r
\r
-:: set-password ( password username provider -- ? )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user\r
- password >>password\r
- provider update-user t\r
- ] [ f ] if\r
- ] ;\r
+: set-password ( user password -- user ) >>password ;\r
\r
! Password recovery support\r
\r
USING: html http http.server io kernel math namespaces\r
continuations calendar sequences assocs new-slots hashtables\r
accessors arrays alarms quotations combinators\r
-combinators.cleave fry ;\r
+combinators.cleave fry assocs.lib ;\r
IN: http.server.callbacks\r
\r
SYMBOL: responder\r
cont-id query-param swap callbacks>> at ;\r
\r
M: callback-responder call-responder ( path responder -- response )\r
- [ callback-responder set ]\r
- [ request get resuming-callback ] bi\r
+ '[\r
+ , ,\r
\r
- [ invoke-callback ]\r
- [ callback-responder get responder>> call-responder ] ?if ;\r
+ [ callback-responder set ]\r
+ [ request get resuming-callback ] bi\r
+\r
+ [\r
+ invoke-callback\r
+ ] [\r
+ callback-responder get responder>> call-responder\r
+ ] ?if\r
+ ] with-exit-continuation ;\r
\r
: show-page ( quot -- )\r
>r redirect-to-here store-current-show r>\r
\r
[ t ] [ "number" value validation-error? ] unit-test\r
] with-scope\r
+\r
+[\r
+ [ ] [\r
+ "n" <number>\r
+ 0 >>min-value\r
+ 10 >>max-value\r
+ "n" set\r
+ ] unit-test\r
+\r
+ [ "123" ] [\r
+ "123" "n" get validate value>>\r
+ ] unit-test\r
+ \r
+ [ ] [ "n" get t >>integer drop ] unit-test\r
+\r
+ [ 3 ] [\r
+ "3" "n" get validate\r
+ ] unit-test\r
+] with-scope\r
+\r
+[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
combinators.cleave fry continuations math ;
IN: http.server.components
-SYMBOL: validation-failed?
-
SYMBOL: components
TUPLE: component id required default ;
: validate ( value component -- result )
'[
- , ,
+ ,
over empty? [
[ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ]
bi
] [ validate* ] if
- ] [
- dup validation-error?
- [ validation-failed? on ] [ rethrow ] if
- ] recover ;
+ ] with-validator ;
: render-view ( component -- )
[ id>> value ] [ render-view* ] bi ;
render-edit* render-error ;
! Number fields
-TUPLE: number min-value max-value ;
+TUPLE: number min-value max-value integer ;
: <number> ( id -- component ) number <component> ;
M: number validate*
[ v-number ] [
+ [ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
- bi
+ tri
] bi* ;
M: number render-view*
! Text areas
TUPLE: text ;
-: <text> ( id -- component ) <string> text construct-delegate ;
+: <text> ( id -- component ) text <component> ;
+
+M: text validate* drop ;
+
+M: text render-view*
+ drop write ;
: render-textarea
<textarea
: <dispatcher> ( -- dispatcher )
404-responder get H{ } clone dispatcher construct-boa ;
-: set-main ( dispatcher name -- dispatcher )
- '[ , f <permanent-redirect> ] <trivial-responder>
- >>default ;
-
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
M: dispatcher call-responder ( path dispatcher -- response )
over [
- 2dup find-responder call-responder [
- 2nip
- ] [
- default>> [
- call-responder
- ] [
- drop f
- ] if*
- ] if*
+ find-responder call-responder
] [
2drop redirect-with-/
] if ;
+: <webapp> ( class -- dispatcher )
+ <dispatcher> swap construct-delegate ; inline
+
+TUPLE: vhost-dispatcher default responders ;
+
+: <vhost-dispatcher> ( -- dispatcher )
+ 404-responder get H{ } clone vhost-dispatcher construct-boa ;
+
+: find-vhost ( dispatcher -- responder )
+ request get host>> over responders>> at*
+ [ nip ] [ drop default>> ] if ;
+
+M: vhost-dispatcher call-responder ( path dispatcher -- response )
+ find-vhost call-responder ;
+
+: set-main ( dispatcher name -- dispatcher )
+ '[ , f <permanent-redirect> ] <trivial-responder>
+ >>default ;
+
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder ] keep set-main ;
-: <webapp> ( class -- dispatcher )
- <dispatcher> swap construct-delegate ; inline
-
SYMBOL: main-responder
main-responder global
: exit-with exit-continuation get continue-with ;
+: with-exit-continuation ( quot -- )
+ '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+
: do-request ( request -- response )
- '[
- exit-continuation set ,
- [
- [ log-request ]
- [ request set ]
- [ path>> main-responder get call-responder ] tri
- [ <404> ] unless*
- ] [
- [ \ do-request log-error ]
- [ <500> ]
- bi
- ] recover
- ] callcc1
- exit-continuation off ;
+ [
+ [ log-request ]
+ [ request set ]
+ [ path>> main-responder get call-responder ] tri
+ [ <404> ] unless*
+ ] [
+ [ \ do-request log-error ]
+ [ <500> ]
+ bi
+ ] recover ;
: default-timeout 1 minutes stdio get set-timeout ;
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main
-
-! Utility
-: generate-key ( assoc -- str )
- >r random-256 >hex r>
- 2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
- dup generate-key [ swap set-at ] keep ;
IN: http.server.sessions.tests\r
-USING: tools.test http.server.sessions math namespaces\r
-kernel accessors ;\r
+USING: tools.test http http.server.sessions\r
+http.server.sessions.storage http.server.sessions.storage.assoc\r
+http.server.actions http.server math namespaces kernel accessors\r
+prettyprint io.streams.string splitting destructors sequences ;\r
\r
[ H{ } ] [ H{ } add-session-id ] unit-test\r
\r
\r
M: foo init-session* drop 0 "x" sset ;\r
\r
-f <session> "123" >>id [\r
+M: foo call-responder\r
+ 2drop\r
+ "x" [ 1+ ] schange\r
+ "text/html" <content> [ "x" sget pprint ] >>body ;\r
+\r
+[\r
+ "123" session-id set\r
+ H{ } clone session set\r
+ session-changed? off\r
+\r
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test\r
\r
[ ] [ 3 "x" sset ] unit-test\r
[ ] [ "x" [ 1- ] schange ] unit-test\r
\r
[ 4 ] [ "x" sget sq ] unit-test\r
-] with-session\r
+\r
+ [ t ] [ session-changed? get ] unit-test\r
+] with-scope\r
\r
[ t ] [ f <url-sessions> url-sessions? ] unit-test\r
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test\r
\r
[ ] [\r
<foo> <url-sessions>\r
+ <sessions-in-memory> >>sessions\r
"manager" set\r
] unit-test\r
\r
[ { 5 0 } ] [\r
[\r
- "manager" get new-session\r
- dup "manager" get get-session [ 5 "a" sset ] with-session\r
- dup "manager" get get-session [ "a" sget , ] with-session\r
- dup "manager" get get-session [ "x" sget , ] with-session\r
- "manager" get get-session delete-session\r
+ "manager" get begin-session drop\r
+ dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session\r
+ dup "manager" get sessions>> get-session [ "a" sget , ] with-session\r
+ dup "manager" get sessions>> get-session [ "x" sget , ] with-session\r
+ "manager" get sessions>> get-session\r
+ "manager" get sessions>> delete-session\r
] { } make\r
] unit-test\r
+\r
+[ ] [\r
+ <request>\r
+ "GET" >>method\r
+ request set\r
+ "/etc" "manager" get call-responder\r
+ response set\r
+] unit-test\r
+\r
+[ 307 ] [ response get code>> ] unit-test\r
+\r
+[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test\r
+\r
+: url-responder-mock-test\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ "id" get session-id-key set-query-param\r
+ "/" >>path\r
+ request set\r
+ "/" "manager" get call-responder\r
+ [ write-response-body drop ] with-string-writer\r
+ ] with-destructors ;\r
+\r
+[ "1" ] [ url-responder-mock-test ] unit-test\r
+[ "2" ] [ url-responder-mock-test ] unit-test\r
+[ "3" ] [ url-responder-mock-test ] unit-test\r
+[ "4" ] [ url-responder-mock-test ] unit-test\r
+\r
+[ ] [\r
+ <foo> <cookie-sessions>\r
+ <sessions-in-memory> >>sessions\r
+ "manager" set\r
+] unit-test\r
+\r
+[\r
+ <request>\r
+ "GET" >>method\r
+ "/" >>path\r
+ request set\r
+ "/etc" "manager" get call-responder response set\r
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
+ response get\r
+] with-destructors\r
+response set\r
+\r
+[ ] [ response get cookies>> "cookies" set ] unit-test\r
+\r
+: cookie-responder-mock-test\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ "cookies" get >>cookies\r
+ "/" >>path\r
+ request set\r
+ "/" "manager" get call-responder\r
+ [ write-response-body drop ] with-string-writer\r
+ ] with-destructors ;\r
+\r
+[ "2" ] [ cookie-responder-mock-test ] unit-test\r
+[ "3" ] [ cookie-responder-mock-test ] unit-test\r
+[ "4" ] [ cookie-responder-mock-test ] unit-test\r
+\r
+: <exiting-action>\r
+ <action>\r
+ [\r
+ "text/plain" <content> exit-with\r
+ ] >>display ;\r
+\r
+[\r
+ [ ] [\r
+ <request>\r
+ "GET" >>method\r
+ "id" get session-id-key set-query-param\r
+ "/" >>path\r
+ request set\r
+\r
+ [\r
+ "/" <exiting-action> <cookie-sessions>\r
+ call-responder\r
+ ] with-destructors response set\r
+ ] unit-test\r
+\r
+ [ "text/plain" ] [ response get "content-type" header ] unit-test\r
+\r
+ [ f ] [ response get cookies>> empty? ] unit-test\r
+] with-scope\r
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
-boxes alarms new-slots accessors http http.server
+new-slots accessors http http.server
+http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry combinators.cleave
-html.elements ;
+html.elements symbols continuations destructors ;
IN: http.server.sessions
! ! ! ! ! !
GENERIC: init-session* ( responder -- )
-M: dispatcher init-session* drop ;
+M: object init-session* drop ;
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
- >r H{ } clone session-manager construct-boa r>
- construct-delegate ; inline
+ >r <sessions-in-memory> session-manager construct-boa
+ r> construct-delegate ; inline
-TUPLE: session manager id namespace alarm ;
+SYMBOLS: session session-id session-changed? ;
-: <session> ( manager -- session )
- f H{ } clone <box> \ session construct-boa ;
+: sget ( key -- value )
+ session get at ;
-: timeout ( -- dt ) 20 minutes ;
+: sset ( value key -- )
+ session get set-at
+ session-changed? on ;
-: cancel-timeout ( session -- )
- alarm>> [ cancel-alarm ] if-box? ;
+: schange ( key quot -- )
+ session get swap change-at
+ session-changed? on ; inline
-: delete-session ( session -- )
- [ cancel-timeout ]
- [ dup manager>> sessions>> delete-at ]
- bi ;
+: sessions session-manager get sessions>> ;
-: touch-session ( session -- session )
- [ cancel-timeout ]
- [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
- [ ]
- tri ;
+: managed-responder session-manager get responder>> ;
-: session ( -- assoc ) \ session get namespace>> ;
+: init-session ( managed -- session )
+ H{ } clone [ session [ init-session* ] with-variable ] keep ;
-: sget ( key -- value ) session at ;
+: begin-session ( responder -- id session )
+ [ responder>> init-session ] [ sessions>> ] bi
+ [ new-session ] [ drop ] 2bi ;
-: sset ( value key -- ) session set-at ;
+! Destructor
+TUPLE: session-saver id session ;
-: schange ( key quot -- ) session swap change-at ; inline
+C: <session-saver> session-saver
-: init-session ( session -- session )
- dup dup \ session [
- manager>> responder>> init-session*
- ] with-variable ;
+M: session-saver dispose
+ session-changed? get [
+ [ session>> ] [ id>> ] bi
+ sessions update-session
+ ] [ drop ] if ;
-: new-session ( responder -- id )
- [ <session> init-session touch-session ]
- [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
- bi id>> ;
+: save-session-after ( id session -- )
+ <session-saver> add-always-destructor ;
-: get-session ( id responder -- session/f )
- sessions>> at* [ touch-session ] when ;
-
-: call-responder/session ( path responder session -- response )
- \ session set responder>> call-responder ;
-
-: sessions ( -- manager/f )
- \ session get dup [ manager>> ] when ;
+: call-responder/session ( path responder id session -- response )
+ [ save-session-after ]
+ [ [ session-id set ] [ session set ] bi* ] 2bi
+ [ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: null-sessions ;
null-sessions <session-manager> ;
M: null-sessions call-responder ( path responder -- response )
- dup <session> call-responder/session ;
+ H{ } clone f call-responder/session ;
TUPLE: url-sessions ;
: <url-sessions> ( responder -- responder' )
url-sessions <session-manager> ;
-: sess-id "factorsessid" ;
+: session-id-key "factorsessid" ;
-: current-session ( responder -- session )
- >r request-params sess-id swap at r> get-session ;
+: current-url-session ( responder -- id/f session/f )
+ [ request-params session-id-key swap at ] [ sessions>> ] bi*
+ [ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
- \ session get [ id>> sess-id associate union ] when* ;
+ session-id get [ session-id-key associate union ] when* ;
: session-form-field ( -- )
<input
- "hidden" =type
- sess-id =id
- sess-id =name
- \ session get id>> =value
+ "hidden" =type
+ session-id-key =id
+ session-id-key =name
+ session-id get =value
input/> ;
+: new-url-session ( responder -- response )
+ [ f ] [ begin-session drop session-id-key associate ] bi*
+ <temporary-redirect> ;
+
M: url-sessions call-responder ( path responder -- response )
[ add-session-id ] link-hook set
[ session-form-field ] form-hook set
- dup current-session [
+ dup current-url-session dup [
call-responder/session
] [
- nip
- f swap new-session sess-id associate <temporary-redirect>
- ] if* ;
+ 2drop nip new-url-session
+ ] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
-: get-session-cookie ( responder -- cookie )
- request get sess-id get-cookie
- [ value>> swap get-session ] [ drop f ] if* ;
+: current-cookie-session ( responder -- id namespace/f )
+ request get session-id-key get-cookie dup
+ [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
: <session-cookie> ( id -- cookie )
- sess-id <cookie> ;
+ session-id-key <cookie> ;
+
+: call-responder/new-session ( path responder -- response )
+ dup begin-session
+ [ call-responder/session ]
+ [ drop <session-cookie> ] 2bi
+ put-cookie ;
M: cookie-sessions call-responder ( path responder -- response )
- dup get-session-cookie [
+ dup current-cookie-session dup [
call-responder/session
] [
- dup new-session
- [ over get-session call-responder/session ] keep
- <session-cookie> put-cookie
- ] if* ;
+ 2drop call-responder/new-session
+ ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: assocs assocs.lib new-slots accessors\r
+http.server.sessions.storage combinators.cleave alarms kernel\r
+fry http.server ;\r
+IN: http.server.sessions.storage.assoc\r
+\r
+TUPLE: sessions-in-memory sessions alarms ;\r
+\r
+: <sessions-in-memory> ( -- storage )\r
+ H{ } clone H{ } clone sessions-in-memory construct-boa ;\r
+\r
+: cancel-session-timeout ( id storage -- )\r
+ alarms>> at [ cancel-alarm ] when* ;\r
+\r
+: touch-session ( id storage -- )\r
+ [ cancel-session-timeout ]\r
+ [ '[ , , delete-session ] timeout later ]\r
+ [ alarms>> set-at ]\r
+ 2tri ;\r
+\r
+M: sessions-in-memory get-session ( id storage -- namespace )\r
+ [ sessions>> at ] [ touch-session ] 2bi ;\r
+\r
+M: sessions-in-memory update-session ( namespace id storage -- )\r
+ [ sessions>> set-at ]\r
+ [ touch-session ]\r
+ 2bi ;\r
+\r
+M: sessions-in-memory delete-session ( id storage -- )\r
+ [ sessions>> delete-at ]\r
+ [ cancel-session-timeout ]\r
+ 2bi ;\r
+\r
+M: sessions-in-memory new-session ( namespace storage -- id )\r
+ [ sessions>> set-at-unique ]\r
+ [ [ touch-session ] [ drop ] 2bi ]\r
+ bi ;\r
--- /dev/null
+IN: http.server.sessions.storage.db\r
+USING: http.server.sessions.storage\r
+http.server.sessions.storage.db namespaces io.files\r
+db.sqlite db accessors math tools.test kernel assocs\r
+sequences ;\r
+\r
+sessions-in-db "storage" set\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+ [ ] [ init-sessions-table ] unit-test\r
+\r
+ [ f ] [ H{ } "storage" get new-session empty? ] unit-test\r
+\r
+ H{ } "storage" get new-session "id" set\r
+\r
+ "id" get "storage" get get-session "session" set\r
+ "a" "b" "session" get set-at\r
+\r
+ "session" get "id" get "storage" get update-session\r
+\r
+ [ H{ { "b" "a" } } ] [\r
+ "id" get "storage" get get-session\r
+ ] unit-test\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: assocs new-slots accessors http.server.sessions.storage\r
+alarms kernel http.server db.tuples db.types singleton\r
+combinators.cleave math.parser ;\r
+IN: http.server.sessions.storage.db\r
+\r
+SINGLETON: sessions-in-db\r
+\r
+TUPLE: session id namespace ;\r
+\r
+session "SESSIONS"\r
+{\r
+ { "id" "ID" INTEGER +native-id+ }\r
+ { "namespace" "NAMESPACE" FACTOR-BLOB }\r
+} define-persistent\r
+\r
+: init-sessions-table session ensure-table ;\r
+\r
+: <session> ( id -- session )\r
+ session construct-empty\r
+ swap dup [ string>number ] when >>id ;\r
+\r
+M: sessions-in-db get-session ( id storage -- namespace/f )\r
+ drop\r
+ dup [\r
+ <session>\r
+ select-tuple dup [ namespace>> ] when\r
+ ] when ;\r
+\r
+M: sessions-in-db update-session ( namespace id storage -- )\r
+ drop\r
+ <session>\r
+ swap >>namespace\r
+ update-tuple ;\r
+\r
+M: sessions-in-db delete-session ( id storage -- )\r
+ drop\r
+ <session>\r
+ delete-tuple ;\r
+\r
+M: sessions-in-db new-session ( namespace storage -- id )\r
+ drop\r
+ f <session>\r
+ swap >>namespace\r
+ [ insert-tuple ] [ id>> number>string ] bi ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: calendar ;\r
+IN: http.server.sessions.storage\r
+\r
+: timeout 20 minutes ;\r
+\r
+GENERIC: get-session ( id storage -- namespace )\r
+\r
+GENERIC: update-session ( namespace id storage -- )\r
+\r
+GENERIC: delete-session ( id storage -- )\r
+\r
+GENERIC: new-session ( namespace storage -- id )\r
USING: kernel sequences tools.test http.server.validators
accessors ;
-[ "foo" v-number ] [ validation-error? ] must-fail-with
+[ "foo" v-number ] must-fail
+[ 123 ] [ "123" v-number ] unit-test
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
] unit-test
[ "slava@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
combinators.cleave sequences ;
IN: http.server.validators
+SYMBOL: validation-failed?
+
TUPLE: validation-error value reason ;
-: validation-error ( value reason -- * )
- \ validation-error construct-boa throw ;
+C: <validation-error> validation-error
+
+: with-validator ( value quot -- result )
+ [ validation-failed? on <validation-error> ] recover ;
+ inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
- dup empty? [ "required" validation-error ] when ;
+ dup empty? [ "required" throw ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
- validation-error
+ throw
] [
drop
] if ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
- validation-error
+ throw
] [
drop
] if ;
: v-number ( str -- n )
- dup string>number [ ] [
- "must be a number" validation-error
- ] ?if ;
+ dup string>number [ ] [ "must be a number" throw ] ?if ;
+
+: v-integer ( n -- n )
+ dup integer? [ "must be an integer" throw ] unless ;
: v-min-value ( x n -- x )
2dup < [
- [ "must be at least " % # ] "" make
- validation-error
+ [ "must be at least " % # ] "" make throw
] [
drop
] if ;
: v-max-value ( x n -- x )
2dup > [
- [ "must be no more than " % # ] "" make
- validation-error
+ [ "must be no more than " % # ] "" make throw
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
- [ drop ] [ "invalid " swap append validation-error ] if ;
+ [ drop ] [ "invalid " swap append throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
v-regexp ;
: v-captcha ( str -- str )
- dup empty? [ "must remain blank" validation-error ] unless ;
+ dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
dup "\r\n" seq-intersect empty?
- [ "must be a single line" validation-error ] unless ;
+ [ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
- [ "must be a single word" validation-error ] unless ;
+ [ "must be a single word" throw ] unless ;
ascii <process-stream> contents
] unit-test
-[ "" ] [
+[ f ] [
<process>
"cat"
"launcher-test-1" temp-file
try-process
] unit-test
-[ "" ] [
+[ f ] [
"cat"
"launcher-test-1" temp-file
2array
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
-
-"tools.vocabs.monitor" require
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
-+directory+ +archive+ +device+ +normal+ +temporary+
++archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +encrypted+ ;
USE: io.backend
T{ windows-nt-io } set-io-backend
-
-"tools.vocabs.monitor" require
] when drop ;
: open-append ( path -- handle length )
- dup file-info file-info-size dup [
- >r (open-append) r> 2dup set-file-pointer
- ] [
- drop open-write
- ] if ;
+ [ dup file-info file-info-size ] [ drop 0 ] recover
+ >r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
IN: ldap.libldap
<< "libldap" {
- { [ win32? ] [ "libldap.dll" "stdcall" ] }
+ { [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
+ { [ unix? ] [ "libldap.so" "cdecl" ] }
} cond add-library >>
: LDAP_VERSION1 1 ; inline
USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays strings prettyprint ;
+namespaces arrays strings prettyprint io.streams.string parser
+;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ "[| a! | ]" ] [
[| a! | ] unparse
] unit-test
+
+DEFER: xyzzy
+
+[ ] [
+ "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 10 ] [ 10 xyzzy ] unit-test
+
+[ ] [
+ "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
+ <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 5 ] [ 10 xyzzy ] unit-test
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals ;
-: ((::)) ( word -- word quot )
+: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
-: (::) ( -- word quot )
- CREATE dup reset-generic ((::)) ;
+: (::) CREATE-WORD parse-locals-definition ;
+
+: (M::) CREATE-METHOD parse-locals-definition ;
PRIVATE>
: :: (::) define ; parsing
-! This will be cleaned up when method tuples and method words
-! are unified
-: create-method ( class generic -- method )
- 2dup method dup
- [ 2nip ]
- [ drop 2dup [ ] -rot define-method create-method ] if ;
-
-: CREATE-METHOD ( -- class generic body )
- scan-word bootstrap-word scan-word 2dup
- create-method f set-word dup save-location ;
-
-: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
+: M:: (M::) define ; parsing
: MACRO:: (::) define-macro ; parsing
\r
: LOG:\r
#! Syntax: name level\r
- CREATE\r
- dup reset-generic\r
+ CREATE-WORD\r
dup scan-word\r
[ >r >r 1array stack>message r> r> log-message ] 2curry\r
define ; parsing\r
USING: namespaces kernel io calendar sequences io.files\r
io.sockets continuations prettyprint assocs math.parser\r
words debugger math combinators concurrency.messaging\r
-threads arrays init math.ranges strings calendar.format
-io.encodings.ascii ;\r
+threads arrays init math.ranges strings calendar.format\r
+io.encodings.utf8 ;\r
IN: logging.server\r
\r
: log-root ( -- string )\r
: open-log-stream ( service -- stream )\r
log-path\r
dup make-directories\r
- 1 log# ascii <file-appender> ;\r
+ 1 log# utf8 <file-appender> ;\r
\r
: log-stream ( service -- stream )\r
log-files get [ open-log-stream ] cache ;\r
over make-memoizer define ;
: MEMO:
- CREATE dup reset-generic parse-definition define-memoized ; parsing
+ CREATE-WORD parse-definition define-memoized ; parsing
PREDICATE: word memoized "memoize" word-prop ;
lexer get next-line ;
: STRING:
- CREATE dup reset-generic
+ CREATE-WORD
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
--- /dev/null
+IN: namespaces.lib.tests\r
+USING: namespaces.lib tools.test ;\r
+\r
+[ ] [ [ ] { } nmake ] unit-test\r
+\r
+[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test\r
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math sequences.lib ;
+ assocs.lib math.parser math sequences.lib locals ;
IN: namespaces.lib
: 4% 4 n% ;
: 4# 4 n# ;
-: nmake ( quot exemplars -- seqs )
- dup length dup zero? [ 1+ ] when
- [
+MACRO:: nmake ( quot exemplars -- )
+ [let | n [ exemplars length ] |
[
- [ drop 1024 swap new-resizable ] 2map
- [ building-seq set call ] keep
- ] 2keep >r [ like ] 2map r> firstn
- ] with-scope ;
+ [
+ exemplars
+ [ 0 swap new-resizable ] map
+ building-seq set
+
+ quot call
+
+ building-seq get
+ exemplars [ like ] 2map
+ n firstn
+ ] with-scope
+ ]
+ ] ;
--- /dev/null
+
+USING: help.syntax help.markup ;
+
+IN: opengl.gl
+
+ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
+ { $subsection "opengl-specifying-vertices" }
+ { $subsection "opengl-geometric-primitives" }
+ { $subsection "opengl-modeling-transformations" } ;
+
+ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
+
+ { $subsection glVertex2d }
+ { $subsection glVertex2f }
+ { $subsection glVertex2i }
+ { $subsection glVertex2s }
+ { $subsection glVertex3d }
+ { $subsection glVertex3f }
+ { $subsection glVertex3i }
+ { $subsection glVertex3s }
+ { $subsection glVertex4d }
+ { $subsection glVertex4f }
+ { $subsection glVertex4i }
+ { $subsection glVertex4s }
+ { $subsection glVertex2dv }
+ { $subsection glVertex2fv }
+ { $subsection glVertex2iv }
+ { $subsection glVertex2sv }
+ { $subsection glVertex3dv }
+ { $subsection glVertex3fv }
+ { $subsection glVertex3iv }
+ { $subsection glVertex3sv }
+ { $subsection glVertex4dv }
+ { $subsection glVertex4fv }
+ { $subsection glVertex4iv }
+ { $subsection glVertex4sv } ;
+
+ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
+
+ { $table
+ { { $link GL_POINTS } "individual points" }
+ { { $link GL_LINES } { "pairs of vertices interpreted as "
+ "individual line segments" } }
+ { { $link GL_LINE_STRIP } "series of connected line segments" }
+ { { $link GL_LINE_LOOP } { "same as above, with a segment added "
+ "between last and first vertices" } }
+ { { $link GL_TRIANGLES }
+ "triples of vertices interpreted as triangles" }
+ { { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
+ { { $link GL_TRIANGLE_FAN } "linked fan of triangles" }
+ { { $link GL_QUADS }
+ "quadruples of vertices interpreted as four-sided polygons" }
+ { { $link GL_QUAD_STRIP } "linked strip of quadrilaterals" }
+ { { $link GL_POLYGON } "boundary of a simple, convex polygon" } }
+
+;
+
+HELP: glBegin
+ { $values { "mode"
+ { "One of the " { $link "opengl-geometric-primitives" } } } } ;
+
+HELP: glPolygonMode
+ { $values { "face" { "One of the following:"
+ { $list { $link GL_FRONT }
+ { $link GL_BACK }
+ { $link GL_FRONT_AND_BACK } } } }
+ { "mode" { "One of the following:"
+ { $list
+ { $link GL_POINT }
+ { $link GL_LINE }
+ { $link GL_FILL } } } } } ;
+
+ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+ { $subsection glTranslatef }
+ { $subsection glTranslated }
+ { $subsection glRotatef }
+ { $subsection glRotated }
+ { $subsection glScalef }
+ { $subsection glScaled } ;
+
+
+{ glTranslatef glTranslated glRotatef glRotated glScalef glScaled }
+related-words
+
+
{ $description "If the most recent OpenGL call resulted in an error, print the error to the " { $link stdio } " stream." } ;
HELP: do-state
-{ $values { "what" integer } { "quot" quotation } }
+ {
+ $values
+ { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
+ { "quot" quotation }
+ }
{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
HELP: do-enabled
"GL error: " over gluErrorString append throw
] unless drop ;
-: do-state ( what quot -- )
+: do-state ( mode quot -- )
swap glBegin call glEnd ; inline
: do-enabled ( what quot -- )
IN: openssl.libcrypto
+<<
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "stdcall" ] }
+ { [ win32? ] [ "libeay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libcrypto.so" "cdecl" ] }
+ { [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
+>>
C-STRUCT: bio-method
{ "int" "type" }
IN: openssl.libssl
<< "libssl" {
- { [ win32? ] [ "ssleay32.dll" "stdcall" ] }
+ { [ win32? ] [ "ssleay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
+ { [ unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
! Initialize context
! =========================================================
-init load-error-strings
+[ ] [ init load-error-strings ] unit-test
-ssl-v23 new-ctx
+[ ] [ ssl-v23 new-ctx ] unit-test
-get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain
+[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path 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" string>char-alien set-default-passwd-userdata
+[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
-get-ctx "/extra/openssl/test/server.pem" resource-path
-SSL_FILETYPE_PEM use-private-key
+[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
+SSL_FILETYPE_PEM use-private-key ] unit-test
-get-ctx "/extra/openssl/test/root.pem" resource-path f
-verify-load-locations
+[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
+verify-load-locations ] unit-test
-get-ctx 1 set-verify-depth
+[ ] [ get-ctx 1 set-verify-depth ] unit-test
! =========================================================
! Load Diffie-Hellman parameters
! =========================================================
-"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file
+[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
-get-bio f f f read-pem-dh-params
+[ ] [ get-bio f f f read-pem-dh-params ] unit-test
-get-bio bio-free
+[ ] [ get-bio bio-free ] unit-test
! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
-! get-ctx get-dh set-tmp-dh-callback
+[ ] [ 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
+! [ ] [ 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
+[ ] [ 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
+[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
-get-rsa free-rsa
+[ ] [ get-rsa free-rsa ] unit-test
! =========================================================
! Listen and accept on socket
! Dump errors to file
! =========================================================
-"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file
+[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
-get-bio bio-free
+[ ] [ get-bio bio-free ] unit-test
! =========================================================
! Clean-up
+++ /dev/null
-Elie Chaftari
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with libharu2 2.0.8 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
-USING: alien alien.syntax combinators system ;
-
-IN: pdf.libhpdf
-
-<< "libhpdf" {
- { [ win32? ] [ "libhpdf.dll" "stdcall" ] }
- { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
-} cond add-library >>
-
-! compression mode
-: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
-: HPDF_COMP_TEXT HEX: 01 ; inline ! Compress contents stream of page
-: HPDF_COMP_IMAGE HEX: 02 ; inline ! Compress streams of image objects
-: HPDF_COMP_METADATA HEX: 04 ; inline ! Compress other data (fonts, cmaps...)
-: HPDF_COMP_ALL HEX: 0F ; inline ! All stream data are compressed
-: HPDF_COMP_MASK HEX: FF ; inline
-
-! page mode
-C-ENUM:
- HPDF_PAGE_MODE_USE_NONE
- HPDF_PAGE_MODE_USE_OUTLINE
- HPDF_PAGE_MODE_USE_THUMBS
- HPDF_PAGE_MODE_FULL_SCREEN
- HPDF_PAGE_MODE_EOF
-;
-
-: error-code ( -- seq ) {
- { HEX: 1001 "HPDF_ARRAY_COUNT_ERR\nInternal error. The consistency of the data was lost." }
- { HEX: 1002 "HPDF_ARRAY_ITEM_NOT_FOUND\nInternal error. The consistency of the data was lost." }
- { HEX: 1003 "HPDF_ARRAY_ITEM_UNEXPECTED_TYPE\nInternal error. The consistency of the data was lost." }
- { HEX: 1004 "HPDF_BINARY_LENGTH_ERR\nThe length of the data exceeds HPDF_LIMIT_MAX_STRING_LEN." }
- { HEX: 1005 "HPDF_CANNOT_GET_PALLET\nCannot get a pallet data from PNG image." }
- { HEX: 1007 "HPDF_DICT_COUNT_ERR\nThe count of elements of a dictionary exceeds HPDF_LIMIT_MAX_DICT_ELEMENT" }
- { HEX: 1008 "HPDF_DICT_ITEM_NOT_FOUND\nInternal error. The consistency of the data was lost." }
- { HEX: 1009 "HPDF_DICT_ITEM_UNEXPECTED_TYPE\nInternal error. The consistency of the data was lost." }
- { HEX: 100A "HPDF_DICT_STREAM_LENGTH_NOT_FOUND\nInternal error. The consistency of the data was lost." }
- { HEX: 100B "HPDF_DOC_ENCRYPTDICT_NOT_FOUND\nHPDF_SetPermission() OR HPDF_SetEncryptMode() was called before a password is set." }
- { HEX: 100C "HPDF_DOC_INVALID_OBJECT\nInternal error. The consistency of the data was lost." }
- { HEX: 100E "HPDF_DUPLICATE_REGISTRATION\nTried to register a font that has been registered." }
- { HEX: 100F "HPDF_EXCEED_JWW_CODE_NUM_LIMIT\nCannot register a character to the japanese word wrap characters list." }
- { HEX: 1011 "HPDF_ENCRYPT_INVALID_PASSWORD\nTried to set the owner password to NULL. owner password and user password is the same." }
- { HEX: 1013 "HPDF_ERR_UNKNOWN_CLASS\nInternal error. The consistency of the data was lost." }
- { HEX: 1014 "HPDF_EXCEED_GSTATE_LIMIT\nThe depth of the stack exceeded HPDF_LIMIT_MAX_GSTATE." }
- { HEX: 1015 "HPDF_FAILED_TO_ALLOC_MEM\nMemory allocation failed." }
- { HEX: 1016 "HPDF_FILE_IO_ERROR\nFile processing failed. (A detailed code is set.)" }
- { HEX: 1017 "HPDF_FILE_OPEN_ERROR\nCannot open a file. (A detailed code is set.)" }
- { HEX: 1019 "HPDF_FONT_EXISTS\nTried to load a font that has already been registered." }
- { HEX: 101A "HPDF_FONT_INVALID_WIDTHS_TABLE\nThe format of a font-file is invalid . Internal error. The consistency of the data was lost." }
- { HEX: 101B "HPDF_INVALID_AFM_HEADER\nCannot recognize a header of an afm file." }
- { HEX: 101C "HPDF_INVALID_ANNOTATION\nThe specified annotation handle is invalid." }
- { HEX: 101E "HPDF_INVALID_BIT_PER_COMPONENT\nBit-per-component of a image which was set as mask-image is invalid." }
- { HEX: 101F "HPDF_INVALID_CHAR_MATRICS_DATA\nCannot recognize char-matrics-data of an afm file." }
- { HEX: 1020 "HPDF_INVALID_COLOR_SPACE\n1. The color_space parameter of HPDF_LoadRawImage is invalid.\n2. Color-space of a image which was set as mask-image is invalid.\n3. The function which is invalid in the present color-space was invoked." }
- { HEX: 1021 "HPDF_INVALID_COMPRESSION_MODE\nInvalid value was set when invoking HPDF_SetCommpressionMode()." }
- { HEX: 1022 "HPDF_INVALID_DATE_TIME\nAn invalid date-time value was set." }
- { HEX: 1023 "HPDF_INVALID_DESTINATION\nAn invalid destination handle was set." }
- { HEX: 1025 "HPDF_INVALID_DOCUMENT\nAn invalid document handle is set." }
- { HEX: 1026 "HPDF_INVALID_DOCUMENT_STATE\nThe function which is invalid in the present state was invoked." }
- { HEX: 1027 "HPDF_INVALID_ENCODER\nAn invalid encoder handle was set." }
- { HEX: 1028 "HPDF_INVALID_ENCODER_TYPE\nA combination between font and encoder is wrong." }
- { HEX: 102B "HPDF_INVALID_ENCODING_NAME\nAn Invalid encoding name is specified." }
- { HEX: 102C "HPDF_INVALID_ENCRYPT_KEY_LEN\nThe lengh of the key of encryption is invalid." }
- { HEX: 102D "HPDF_INVALID_FONTDEF_DATA\n1. An invalid font handle was set.\n2. Unsupported font format." }
- { HEX: 102E "HPDF_INVALID_FONTDEF_TYPE\nInternal error. The consistency of the data was lost." }
- { HEX: 102F "HPDF_INVALID_FONT_NAME\nA font which has the specified name is not found." }
- { HEX: 1030 "HPDF_INVALID_IMAGE\nUnsupported image format." }
- { HEX: 1031 "HPDF_INVALID_JPEG_DATA\nUnsupported image format." }
- { HEX: 1032 "HPDF_INVALID_N_DATA\nCannot read a postscript-name from an afm file." }
- { HEX: 1033 "HPDF_INVALID_OBJECT\n1. An invalid object is set.\n2. Internal error. The consistency of the data was lost." }
- { HEX: 1034 "HPDF_INVALID_OBJ_ID\nInternal error. The consistency of the data was lost." }
- { HEX: 1035 "HPDF_INVALID_OPERATION\nInvoked HPDF_Image_SetColorMask() against the image-object which was set a mask-image." }
- { HEX: 1036 "HPDF_INVALID_OUTLINE\nAn invalid outline-handle was specified." }
- { HEX: 1037 "HPDF_INVALID_PAGE\nAn invalid page-handle was specified." }
- { HEX: 1038 "HPDF_INVALID_PAGES\nAn invalid pages-handle was specified. (internal error)" }
- { HEX: 1039 "HPDF_INVALID_PARAMETER\nAn invalid value is set." }
- { HEX: 103B "HPDF_INVALID_PNG_IMAGE\nInvalid PNG image format." }
- { HEX: 103C "HPDF_INVALID_STREAM\nInternal error. The consistency of the data was lost." }
- { HEX: 103D "HPDF_MISSING_FILE_NAME_ENTRY\nInternal error. The \"_FILE_NAME\" entry for delayed loading is missing." }
- { HEX: 103F "HPDF_INVALID_TTC_FILE\nInvalid .TTC file format." }
- { HEX: 1040 "HPDF_INVALID_TTC_INDEX\nThe index parameter was exceed the number of included fonts" }
- { HEX: 1041 "HPDF_INVALID_WX_DATA\nCannot read a width-data from an afm file." }
- { HEX: 1042 "HPDF_ITEM_NOT_FOUND\nInternal error. The consistency of the data was lost." }
- { HEX: 1043 "HPDF_LIBPNG_ERROR\nAn error has returned from PNGLIB while loading an image." }
- { HEX: 1044 "HPDF_NAME_INVALID_VALUE\nInternal error. The consistency of the data was lost." }
- { HEX: 1045 "HPDF_NAME_OUT_OF_RANGE\nInternal error. The consistency of the data was lost." }
- { HEX: 1049 "HPDF_PAGES_MISSING_KIDS_ENTRY\nInternal error. The consistency of the data was lost." }
- { HEX: 104A "HPDF_PAGE_CANNOT_FIND_OBJECT\nInternal error. The consistency of the data was lost." }
- { HEX: 104B "HPDF_PAGE_CANNOT_GET_ROOT_PAGES\nInternal error. The consistency of the data was lost." }
- { HEX: 104C "HPDF_PAGE_CANNOT_RESTORE_GSTATE\nThere are no graphics-states to be restored." }
- { HEX: 104D "HPDF_PAGE_CANNOT_SET_PARENT\nInternal error. The consistency of the data was lost." }
- { HEX: 104E "HPDF_PAGE_FONT_NOT_FOUND\nThe current font is not set." }
- { HEX: 104F "HPDF_PAGE_INVALID_FONT\nAn invalid font-handle was specified." }
- { HEX: 1050 "HPDF_PAGE_INVALID_FONT_SIZE\nAn invalid font-size was set." }
- { HEX: 1051 "HPDF_PAGE_INVALID_GMODE\nSee Graphics mode." }
- { HEX: 1052 "HPDF_PAGE_INVALID_INDEX\nInternal error. The consistency of the data was lost." }
- { HEX: 1053 "HPDF_PAGE_INVALID_ROTATE_VALUE\nThe specified value is not a multiple of 90." }
- { HEX: 1054 "HPDF_PAGE_INVALID_SIZE\nAn invalid page-size was set." }
- { HEX: 1055 "HPDF_PAGE_INVALID_XOBJECT\nAn invalid image-handle was set." }
- { HEX: 1056 "HPDF_PAGE_OUT_OF_RANGE\nThe specified value is out of range." }
- { HEX: 1057 "HPDF_REAL_OUT_OF_RANGE\nThe specified value is out of range." }
- { HEX: 1058 "HPDF_STREAM_EOF\nUnexpected EOF marker was detected." }
- { HEX: 1059 "HPDF_STREAM_READLN_CONTINUE\nInternal error. The consistency of the data was lost." }
- { HEX: 105B "HPDF_STRING_OUT_OF_RANGE\nThe length of the specified text is too long." }
- { HEX: 105C "HPDF_THIS_FUNC_WAS_SKIPPED\nThe execution of a function was skipped because of other errors." }
- { HEX: 105D "HPDF_TTF_CANNOT_EMBEDDING_FONT\nThis font cannot be embedded. (restricted by license.)" }
- { HEX: 105E "HPDF_TTF_INVALID_CMAP\nUnsupported ttf format. (cannot find unicode cmap.)" }
- { HEX: 105F "HPDF_TTF_INVALID_FOMAT\nUnsupported ttf format." }
- { HEX: 1060 "HPDF_TTF_MISSING_TABLE\nUnsupported ttf format. (cannot find a necessary table.)" }
- { HEX: 1061 "HPDF_UNSUPPORTED_FONT_TYPE\nInternal error. The consistency of the data was lost." }
- { HEX: 1062 "HPDF_UNSUPPORTED_FUNC\n1. The library is not configured to use PNGLIB.\n2. Internal error. The consistency of the data was lost." }
- { HEX: 1063 "HPDF_UNSUPPORTED_JPEG_FORMAT\nUnsupported Jpeg format." }
- { HEX: 1064 "HPDF_UNSUPPORTED_TYPE1_FONT\nFailed to parse .PFB file." }
- { HEX: 1065 "HPDF_XREF_COUNT_ERR\nInternal error. The consistency of the data was lost." }
- { HEX: 1066 "HPDF_ZLIB_ERROR\nAn error has occurred while executing a function of Zlib." }
- { HEX: 1067 "HPDF_INVALID_PAGE_INDEX\nAn error returned from Zlib." }
- { HEX: 1068 "HPDF_INVALID_URI\nAn invalid URI was set." }
- { HEX: 1069 "HPDF_PAGELAYOUT_OUT_OF_RANGE\nAn invalid page-layout was set." }
- { HEX: 1070 "HPDF_PAGEMODE_OUT_OF_RANGE\nAn invalid page-mode was set." }
- { HEX: 1071 "HPDF_PAGENUM_STYLE_OUT_OF_RANGE\nAn invalid page-num-style was set." }
- { HEX: 1072 "HPDF_ANNOT_INVALID_ICON\nAn invalid icon was set." }
- { HEX: 1073 "HPDF_ANNOT_INVALID_BORDER_STYLE\nAn invalid border-style was set." }
- { HEX: 1074 "HPDF_PAGE_INVALID_DIRECTION\nAn invalid page-direction was set." }
- { HEX: 1075 "HPDF_INVALID_FONT\nAn invalid font-handle was specified." }
-} ;
-
-LIBRARY: libhpdf
-
-! ===============================================
-! hpdf.h
-! ===============================================
-
-FUNCTION: void* HPDF_New ( void* user_error_fn, void* user_data ) ;
-
-FUNCTION: void* HPDF_Free ( void* pdf ) ;
-
-FUNCTION: ulong HPDF_SetCompressionMode ( void* pdf, uint mode ) ;
-
-FUNCTION: ulong HPDF_SetPageMode ( void* pdf, uint mode ) ;
-
-FUNCTION: void* HPDF_AddPage ( void* pdf ) ;
-
-FUNCTION: ulong HPDF_SaveToFile ( void* pdf, char* file_name ) ;
-
-FUNCTION: float HPDF_Page_GetHeight ( void* page ) ;
-
-FUNCTION: float HPDF_Page_GetWidth ( void* page ) ;
-
-FUNCTION: ulong HPDF_Page_SetLineWidth ( void* page, float line_width ) ;
-
-FUNCTION: ulong HPDF_Page_Rectangle ( void* page, float x, float y,
- float width, float height ) ;
-
-FUNCTION: ulong HPDF_Page_Stroke ( void* page ) ;
-
-FUNCTION: void* HPDF_GetFont ( void* pdf, char* font_name,
- char* encoding_name ) ;
-
-FUNCTION: ulong HPDF_Page_SetFontAndSize ( void* page, void* font,
- float size ) ;
-
-FUNCTION: float HPDF_Page_TextWidth ( void* page, char* text ) ;
-
-FUNCTION: ulong HPDF_Page_BeginText ( void* page ) ;
-
-FUNCTION: ulong HPDF_Page_TextOut ( void* page, float xpos, float ypos,
- char* text ) ;
-
-FUNCTION: ulong HPDF_Page_EndText ( void* page ) ;
-
-FUNCTION: ulong HPDF_Page_MoveTextPos ( void* page, float x, float y ) ;
-
-FUNCTION: ulong HPDF_Page_ShowText ( void* page, char* text ) ;
+++ /dev/null
-USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ;
-IN: pdf.tests
-
-SYMBOL: font
-
-SYMBOL: width
-SYMBOL: height
-SYMBOL: twidth
-
-: font-list ( -- seq ) {
- "Courier"
- "Courier-Bold"
- "Courier-Oblique"
- "Courier-BoldOblique"
- "Helvetica"
- "Helvetica-Bold"
- "Helvetica-Oblique"
- "Helvetica-BoldOblique"
- "Times-Roman"
- "Times-Bold"
- "Times-Italic"
- "Times-BoldItalic"
- "Symbol"
- "ZapfDingbats"
-} ;
-
-[
- ! HPDF_COMP_ALL set-compression-mode
-
- ! HPDF_PAGE_MODE_USE_OUTLINE set-page-mode
-
- ! Add a new page object
- add-page
-
- get-page-height height set
-
- get-page-width width set
-
- ! Print the lines of the page
- 1 set-page-line-width
-
- 50 50 width get 100 - height get 110 - page-rectangle
-
- page-stroke
-
- ! Print the title of the page (with positioning center)
- "Helvetica" f get-font font set
-
- font get 24 set-page-font-and-size
-
- "Font Demo" page-text-width twidth set
-
- [
- width get twidth get - 2 / height get 50 - "Font Demo" page-text-out
-
- ] with-text
-
- ! Print subtitle
- [
- font get 16 set-page-font-and-size
-
- 60 height get 80 - "<Standard Type1 font samples>" page-text-out
-
- ] with-text
-
- ! Print font list
- [
- 60 height get 105 - page-move-text-pos
-
- SYMBOL: fontname
-
- font-list [
-
- fontname set
-
- fontname get f get-font font set
-
- ! print a label of text
- font get 9 set-page-font-and-size
-
- fontname get page-show-text
-
- 0 -18 page-move-text-pos
-
- ! print a sample text
- font get 20 set-page-font-and-size
-
- "abcdefgABCDEFG12345!#$%&+-@?" page-show-text
-
- 0 -20 page-move-text-pos
-
- ] each
-
- ] with-text
-
- "font_test.pdf" temp-file save-to-file
-
-] with-pdf
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with libharu2 2.0.8 on Mac OS X 10.4.9 PowerPC
-
-USING: assocs continuations hashtables kernel math namespaces pdf.libhpdf ;
-
-IN: pdf
-
-SYMBOL: pdf
-SYMBOL: page
-
-! =========================================================
-! Error handling routines
-! =========================================================
-
-: check-status ( status -- )
- dup zero? [
- drop
- ] [
- error-code >hashtable at throw
- ] if ;
-
-! =========================================================
-! Document handling routines
-! =========================================================
-
-: new-pdf ( error-handler user-data -- )
- HPDF_New pdf set ;
-
-: free-pdf ( -- )
- pdf get HPDF_Free drop ;
-
-: with-pdf ( quot -- )
- [ f f new-pdf [ free-pdf ] [ ] cleanup ] with-scope ; inline
-
-: set-compression-mode ( mode -- )
- pdf get swap HPDF_SetCompressionMode check-status ;
-
-: set-page-mode ( mode -- )
- pdf get swap HPDF_SetPageMode check-status ;
-
-: add-page ( -- )
- pdf get HPDF_AddPage page set ;
-
-: save-to-file ( filename -- )
- pdf get swap HPDF_SaveToFile check-status ;
-
-: get-font ( fontname encoding -- font )
- pdf get -rot HPDF_GetFont ;
-
-! =========================================================
-! Page Handling routines
-! =========================================================
-
-: get-page-height ( -- height )
- page get HPDF_Page_GetHeight ;
-
-: get-page-width ( -- width )
- page get HPDF_Page_GetWidth ;
-
-: page-text-width ( text -- width )
- page get swap HPDF_Page_TextWidth ;
-
-! =========================================================
-! Graphics routines
-! =========================================================
-
-: set-page-line-width ( linewidth -- )
- page get swap HPDF_Page_SetLineWidth check-status ;
-
-: page-rectangle ( x y width height -- )
- >r >r >r >r page get r> r> r> r> HPDF_Page_Rectangle check-status ;
-
-: page-stroke ( -- )
- page get HPDF_Page_Stroke check-status ;
-
-: set-page-font-and-size ( font size -- )
- page get -rot HPDF_Page_SetFontAndSize check-status ;
-
-: page-begin-text ( -- )
- page get HPDF_Page_BeginText check-status ;
-
-: page-text-out ( xpos ypos text -- )
- page get -roll HPDF_Page_TextOut check-status ;
-
-: page-end-text ( -- )
- page get HPDF_Page_EndText check-status ;
-
-: with-text ( -- )
- [ page-begin-text [ page-end-text ] [ ] cleanup ] with-scope ; inline
-
-: page-move-text-pos ( x y -- )
- page get -rot HPDF_Page_MoveTextPos check-status ;
-
-: page-show-text ( text -- )
- page get swap HPDF_Page_ShowText check-status ;
+++ /dev/null
-To build libharu as a shared dylib on Mac OS X, modify the Makefile after calling ./configure --shared\r\rHere are the relevant sections and the lines to be changed:\r\r...\rCC=cc\rPREFIX=/usr/local\r\rLIBNAME=libhpdf.a\rSONAME=libhpdf.dylib\rSOVER1=.1\rSOVER2=.0.0\rLIBTARGET=libhpdf.dylib\rCFLAGS=-Iinclude -fPIC -fno-common -c\r...\r$(SONAME): $(OBJS)\r$(CC) -dynamiclib -o $(SONAME)$(SOVER1)$(SOVER2) $(OBJS) $(LDFLAGS) -Wl\rln -sf $(SONAME)$(SOVER1)$(SOVER2) $(SONAME)$(SOVER1)\rln -sf $(SONAME)$(SOVER1) $(SONAME)
-
-Now you can build and install:
-
-make clean
-make
-make install
-
-Test PDF files from pdf-tests.factor are generated in the test folder.
\ No newline at end of file
] [ ] make ;
: LAZY:
- CREATE dup reset-generic
+ CREATE-WORD
dup parse-definition
make-lazy-quot define ; parsing
--- /dev/null
+USING: assocs math kernel shuffle combinators.lib\r
+words quotations arrays combinators sequences math.vectors\r
+io.styles combinators.cleave prettyprint vocabs sorting io\r
+generic locals.private math.statistics ;\r
+IN: reports.noise\r
+\r
+: badness ( word -- n )\r
+ H{\r
+ { -nrot 5 }\r
+ { -roll 4 }\r
+ { -rot 3 }\r
+ { 2apply 1 }\r
+ { 2curry 1 }\r
+ { 2drop 1 }\r
+ { 2dup 1 }\r
+ { 2keep 1 }\r
+ { 2nip 2 }\r
+ { 2over 4 }\r
+ { 2slip 2 }\r
+ { 2swap 3 }\r
+ { 2with 2 }\r
+ { 2with* 3 }\r
+ { 3apply 1/2 }\r
+ { 3curry 2 }\r
+ { 3drop 1 }\r
+ { 3dup 2 }\r
+ { 3keep 3 }\r
+ { 3nip 4 }\r
+ { 3slip 3 }\r
+ { 3with 3 }\r
+ { 3with* 4 }\r
+ { 4drop 2 }\r
+ { 4dup 3 }\r
+ { 4slip 4 }\r
+ { compose 1/2 }\r
+ { curry 1/3 }\r
+ { dip 1 }\r
+ { dipd 2 }\r
+ { drop 1/3 }\r
+ { dup 1/3 }\r
+ { if 1/3 }\r
+ { when 1/4 }\r
+ { unless 1/4 }\r
+ { when* 1/3 }\r
+ { unless* 1/3 }\r
+ { ?if 1/2 }\r
+ { cond 1/2 }\r
+ { case 1/2 }\r
+ { keep 1 }\r
+ { napply 2 }\r
+ { ncurry 3 }\r
+ { ndip 5 }\r
+ { ndrop 2 }\r
+ { ndup 3 }\r
+ { nip 2 }\r
+ { nipd 3 }\r
+ { nkeep 5 }\r
+ { npick 6 }\r
+ { nrev 5 }\r
+ { nrot 5 }\r
+ { nslip 5 }\r
+ { ntuck 6 }\r
+ { nwith 4 }\r
+ { over 2 }\r
+ { pick 4 }\r
+ { roll 4 }\r
+ { rot 3 }\r
+ { slip 1 }\r
+ { spin 3 }\r
+ { swap 1 }\r
+ { swapd 3 }\r
+ { tuck 2 }\r
+ { tuckd 4 }\r
+ { with 1/2 }\r
+ { with* 2 }\r
+ { r> 1 }\r
+ { >r 1 }\r
+\r
+ { bi 1/2 }\r
+ { tri 1 }\r
+ { bi* 1/2 }\r
+ { tri* 1 }\r
+\r
+ { cleave 2 }\r
+ { spread 2 }\r
+ } at 0 or ;\r
+\r
+: vsum { 0 0 } [ v+ ] reduce ;\r
+\r
+GENERIC: noise ( obj -- pair )\r
+\r
+M: word noise badness 1 2array ;\r
+\r
+M: wrapper noise wrapped noise ;\r
+\r
+M: let noise let-body noise ;\r
+\r
+M: wlet noise wlet-body noise ;\r
+\r
+M: lambda noise lambda-body noise ;\r
+\r
+M: object noise drop { 0 0 } ;\r
+\r
+M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;\r
+\r
+M: array noise [ noise ] map vsum ;\r
+\r
+: noise-factor / 100 * >integer ;\r
+\r
+: quot-noise-factor ( quot -- n )\r
+ #! For very short words, noise doesn't count so much\r
+ #! (so dup foo swap bar isn't penalized as badly).\r
+ noise first2 {\r
+ { [ over 4 <= ] [ >r drop 0 r> ] }\r
+ { [ over 15 >= ] [ >r 2 * r> ] }\r
+ { [ t ] [ ] }\r
+ } cond\r
+ {\r
+ ! short words are easier to read\r
+ { [ dup 10 <= ] [ >r 2 / r> ] }\r
+ { [ dup 5 <= ] [ >r 3 / r> ] }\r
+ ! long words are penalized even more\r
+ { [ dup 25 >= ] [ >r 2 * r> 20 max ] }\r
+ { [ dup 20 >= ] [ >r 5/3 * r> ] }\r
+ { [ dup 15 >= ] [ >r 3/2 * r> ] }\r
+ { [ t ] [ ] }\r
+ } cond noise-factor ;\r
+\r
+GENERIC: word-noise-factor ( word -- factor )\r
+\r
+M: word word-noise-factor\r
+ word-def quot-noise-factor ;\r
+\r
+M: lambda-word word-noise-factor\r
+ "lambda" word-prop quot-noise-factor ;\r
+\r
+: flatten-generics ( words -- words' )\r
+ [\r
+ dup generic? [ methods values ] [ 1array ] if\r
+ ] map concat ;\r
+\r
+: noisy-words ( -- alist )\r
+ all-words flatten-generics\r
+ [ dup word-noise-factor ] { } map>assoc\r
+ sort-values reverse ;\r
+\r
+: noise. ( alist -- )\r
+ standard-table-style [\r
+ [\r
+ [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row\r
+ ] assoc-each\r
+ ] tabular-output ;\r
+\r
+: vocab-noise-factor ( vocab -- factor )\r
+ words flatten-generics\r
+ [ word-noise-factor dup 20 < [ drop 0 ] when ] map\r
+ dup empty? [ drop 0 ] [\r
+ [ [ sum ] [ length 5 max ] bi /i ]\r
+ [ supremum ]\r
+ bi +\r
+ ] if ;\r
+\r
+: noisy-vocabs ( -- alist )\r
+ vocabs [ dup vocab-noise-factor ] { } map>assoc\r
+ sort-values reverse ;\r
+\r
+: noise-report ( -- )\r
+ "NOISY WORDS:" print\r
+ noisy-words 80 head noise.\r
+ nl\r
+ "NOISY VOCABS:" print\r
+ noisy-vocabs 80 head noise. ;\r
+\r
+MAIN: noise-report\r
--- /dev/null
+USING: assocs words sequences arrays compiler tools.time\r
+io.styles io prettyprint vocabs kernel sorting generator\r
+optimizer math combinators.cleave ;\r
+IN: report.optimizer\r
+\r
+: count-optimization-passes ( nodes n -- n )\r
+ >r optimize-1\r
+ [ r> 1+ count-optimization-passes ] [ drop r> ] if ;\r
+\r
+: results\r
+ [ [ second ] swap compose compare ] curry sort 20 tail*\r
+ print\r
+ standard-table-style\r
+ [\r
+ [ [ [ pprint-cell ] each ] with-row ] each\r
+ ] tabular-output ; inline\r
+\r
+: optimizer-measurements ( -- alist )\r
+ all-words [ compiled? ] subset\r
+ [\r
+ dup [\r
+ word-dataflow nip 1 count-optimization-passes\r
+ ] benchmark nip 2array\r
+ ] { } map>assoc ;\r
+\r
+: optimizer-measurements. ( alist -- )\r
+ [ [ first ] "Worst number of optimizer passes:" results ]\r
+ [ [ second ] "Worst compile times:" results ] bi ;\r
+\r
+: optimizer-report ( -- )\r
+ optimizer-measurements optimizer-measurements. ;\r
+\r
+MAIN: optimizer-report\r
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
+
+[ ] [ { } 0 firstn ] unit-test
+[ "a" ] [ { "a" } 1 firstn ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
-arrays math.parser math.private sorting strings ascii macros ;
+arrays math.parser math.private sorting strings ascii macros
+assocs.lib quotations ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: firstn ( n -- )
- [ [ swap nth ] curry
- [ keep ] curry ] map concat [ drop ] compose ;
+ [ [ swap nth ] curry [ keep ] curry ] map
+ concat >quotation
+ [ drop ] compose ;
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
: accumulator ( quot -- quot vec )
- V{ } clone [ [ push ] curry compose ] keep ;
+ V{ } clone [ [ push ] curry compose ] keep ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: nths ( indices seq -- seq' )
[ swap nth ] with map ;
+
+: replace ( str oldseq newseq -- str' )
+ H{ } 2seq>assoc substitute ;
USING: tools.test kernel serialize io io.streams.byte-array math
alien arrays byte-arrays sequences math prettyprint parser
classes math.constants io.encodings.binary random
-combinators.lib ;
+combinators.lib assocs ;
IN: serialize.tests
: test-serialize-cell
} ;
: check-serialize-1 ( obj -- ? )
+ "=====" print
dup class .
+ dup .
dup
- binary [ serialize ] with-byte-writer
- binary [ deserialize ] with-byte-reader = ;
+ object>bytes
+ bytes>object
+ dup . = ;
: check-serialize-2 ( obj -- ? )
dup number? over wrapper? or [
drop t ! we don't care if numbers aren't interned
] [
+ "=====" print
dup class .
- dup 2array
- binary [ serialize ] with-byte-writer
- binary [ deserialize ] with-byte-reader
+ dup 2array dup .
+ object>bytes
+ bytes>object dup .
first2 eq?
] if ;
[ t ] [ pi check-serialize-1 ] unit-test
[ serialize ] must-infer
[ deserialize ] must-infer
+
+[ t ] [
+ V{ } dup dup push
+ object>bytes
+ bytes>object
+ dup first eq?
+] unit-test
+
+[ t ] [
+ H{ } dup dup dup set-at
+ object>bytes
+ bytes>object
+ dup keys first eq?
+] unit-test
!
! See http://factorcode.org/license.txt for BSD license.
!
-IN: serialize
USING: namespaces sequences kernel math io math.functions
-io.binary strings classes words sbufs tuples arrays
-vectors byte-arrays bit-arrays quotations hashtables
-assocs help.syntax help.markup float-arrays splitting
-io.encodings.string io.encodings.utf8 combinators new-slots
-accessors ;
+io.binary strings classes words sbufs tuples arrays vectors
+byte-arrays bit-arrays quotations hashtables assocs help.syntax
+help.markup float-arrays splitting io.streams.byte-array
+io.encodings.string io.encodings.utf8 io.encodings.binary
+combinators combinators.cleave new-slots accessors locals
+prettyprint compiler.units sequences.private tuples.private ;
+IN: serialize
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
: serialize-shared ( obj quot -- )
>r dup object-id
- [ CHAR: o write1 serialize-cell drop ] r> if* ; inline
+ [ CHAR: o write1 serialize-cell drop ]
+ r> if* ; inline
M: f (serialize) ( obj -- )
drop CHAR: n write1 ;
dup numerator (serialize)
denominator (serialize) ;
-: serialize-string ( obj code -- )
- write1
- dup utf8 encode dup length serialize-cell write
- add-object ;
-
-M: string (serialize) ( obj -- )
- [ CHAR: s serialize-string ] serialize-shared ;
-
-: serialize-elements ( seq -- )
- [ (serialize) ] each CHAR: . write1 ;
+: serialize-seq ( obj code -- )
+ [
+ write1
+ [ add-object ]
+ [ length serialize-cell ]
+ [ [ (serialize) ] each ] tri
+ ] curry serialize-shared ;
M: tuple (serialize) ( obj -- )
[
CHAR: T write1
- dup tuple>array serialize-elements
- add-object
+ [ class (serialize) ]
+ [ add-object ]
+ [ tuple>array 1 tail (serialize) ]
+ tri
] serialize-shared ;
-: serialize-seq ( seq code -- )
- [
- write1
- dup serialize-elements
- add-object
- ] curry serialize-shared ;
-
M: array (serialize) ( obj -- )
CHAR: a serialize-seq ;
-M: byte-array (serialize) ( obj -- )
+M: quotation (serialize) ( obj -- )
[
- CHAR: A write1
- dup dup length serialize-cell write
- add-object
+ CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
-M: bit-array (serialize) ( obj -- )
+M: hashtable (serialize) ( obj -- )
[
- CHAR: b write1
- dup length serialize-cell
- dup [ 1 0 ? ] B{ } map-as write
- add-object
+ CHAR: h write1
+ [ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
-M: quotation (serialize) ( obj -- )
- CHAR: q serialize-seq ;
+M: bit-array (serialize) ( obj -- )
+ CHAR: b serialize-seq ;
+
+M: byte-array (serialize) ( obj -- )
+ [
+ CHAR: A write1
+ [ add-object ]
+ [ length serialize-cell ]
+ [ write ] tri
+ ] serialize-shared ;
M: float-array (serialize) ( obj -- )
[
CHAR: f write1
- dup length serialize-cell
- dup [ double>bits 8 >be write ] each
- add-object
+ [ add-object ]
+ [ length serialize-cell ]
+ [ [ double>bits 8 >be write ] each ]
+ tri
] serialize-shared ;
-M: hashtable (serialize) ( obj -- )
+M: string (serialize) ( obj -- )
[
- CHAR: h write1
- dup >alist (serialize)
- add-object
+ CHAR: s write1
+ [ add-object ]
+ [
+ utf8 encode
+ [ length serialize-cell ]
+ [ write ] bi
+ ] bi
] serialize-shared ;
-M: word (serialize) ( obj -- )
+: serialize-true ( word -- )
+ drop CHAR: t write1 ;
+
+: serialize-gensym ( word -- )
[
- CHAR: w write1
- dup word-name (serialize)
- dup word-vocabulary (serialize)
- add-object
+ CHAR: G write1
+ [ add-object ]
+ [ word-def (serialize) ]
+ [ word-props (serialize) ]
+ tri
] serialize-shared ;
+: serialize-word ( word -- )
+ CHAR: w write1
+ [ word-name (serialize) ]
+ [ word-vocabulary (serialize) ]
+ bi ;
+
+M: word (serialize) ( obj -- )
+ {
+ { [ dup t eq? ] [ serialize-true ] }
+ { [ dup word-vocabulary not ] [ serialize-gensym ] }
+ { [ t ] [ serialize-word ] }
+ } cond ;
+
M: wrapper (serialize) ( obj -- )
CHAR: W write1
wrapped (serialize) ;
: deserialize-false ( -- f )
f ;
+: deserialize-true ( -- f )
+ t ;
+
: deserialize-positive-integer ( -- number )
deserialize-cell ;
(deserialize-string) dup intern-object ;
: deserialize-word ( -- word )
- (deserialize) dup (deserialize) lookup
- [ dup intern-object ] [ "Unknown word" throw ] ?if ;
+ (deserialize) (deserialize) 2dup lookup
+ dup [ 2nip ] [
+ "Unknown word: " -rot
+ 2array unparse append throw
+ ] if ;
+
+: deserialize-gensym ( -- word )
+ gensym
+ dup intern-object
+ dup (deserialize) define
+ dup (deserialize) swap set-word-props ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
-SYMBOL: +stop+
-
-: (deserialize-seq) ( -- seq )
- [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
-
-: deserialize-seq ( seq -- array )
- >r (deserialize-seq) r> like dup intern-object ;
+:: (deserialize-seq) ( exemplar quot -- seq )
+ deserialize-cell exemplar new
+ [ intern-object ]
+ [ dup [ drop quot call ] change-each ] bi ; inline
: deserialize-array ( -- array )
- { } deserialize-seq ;
+ { } [ (deserialize) ] (deserialize-seq) ;
: deserialize-quotation ( -- array )
- [ ] deserialize-seq ;
-
-: (deserialize-byte-array) ( -- byte-array )
- deserialize-cell read B{ } like ;
+ (deserialize) >quotation dup intern-object ;
: deserialize-byte-array ( -- byte-array )
- (deserialize-byte-array) dup intern-object ;
+ B{ } [ read1 ] (deserialize-seq) ;
: deserialize-bit-array ( -- bit-array )
- (deserialize-byte-array) [ 0 > ] ?{ } map-as
- dup intern-object ;
+ ?{ } [ (deserialize) ] (deserialize-seq) ;
: deserialize-float-array ( -- float-array )
- deserialize-cell
- 8 * read 8 <groups> [ be> bits>double ] F{ } map-as
- dup intern-object ;
+ F{ } [ 8 read be> bits>double ] (deserialize-seq) ;
: deserialize-hashtable ( -- hashtable )
- (deserialize) >hashtable dup intern-object ;
+ H{ } clone
+ [ intern-object ]
+ [ (deserialize) update ]
+ [ ] tri ;
+
+: copy-seq-to-tuple ( seq tuple -- )
+ >r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
- (deserialize-seq) >tuple dup intern-object ;
+ #! Ugly because we have to intern the tuple before reading
+ #! slots
+ (deserialize) construct-empty
+ [ intern-object ]
+ [
+ [ (deserialize) ]
+ [ [ copy-seq-to-tuple ] keep ] bi*
+ ] bi ;
: deserialize-unknown ( -- object )
deserialize-cell deserialized get nth ;
-: deserialize-stop ( -- object )
- +stop+ get ;
-
: deserialize* ( -- object ? )
read1 [
{
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
+ { CHAR: t [ deserialize-true ] }
{ CHAR: o [ deserialize-unknown ] }
{ CHAR: p [ deserialize-positive-integer ] }
{ CHAR: q [ deserialize-quotation ] }
{ CHAR: r [ deserialize-ratio ] }
{ CHAR: s [ deserialize-string ] }
{ CHAR: w [ deserialize-word ] }
+ { CHAR: G [ deserialize-word ] }
{ CHAR: z [ deserialize-zero ] }
- { CHAR: . [ deserialize-stop ] }
} case t
] [
f f
deserialize* [ "End of stream" throw ] unless ;
: deserialize ( -- obj )
- [
- V{ } clone deserialized set
- gensym +stop+ set
- (deserialize)
- ] with-scope ;
+ ! [
+ V{ } clone deserialized
+ [ (deserialize) ] with-variable ;
+ ! ] with-compilation-unit ;
: serialize ( obj -- )
- [
- H{ } clone serialized set
- (serialize)
- ] with-scope ;
\ No newline at end of file
+ H{ } clone serialized [ (serialize) ] with-variable ;
+
+: bytes>object ( bytes -- obj )
+ binary [ deserialize ] with-byte-reader ;
+
+: object>bytes ( obj -- bytes )
+ binary [ serialize ] with-byte-writer ;
\ No newline at end of file
USING: tools.deploy.config ;
H{
- { deploy-reflection 2 }
- { deploy-word-props? f }
+ { deploy-name "Sudoku" }
+ { deploy-threads? f }
+ { deploy-c-types? f }
{ deploy-compiler? t }
+ { deploy-ui? f }
{ deploy-math? f }
- { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
{ deploy-io 2 }
- { deploy-ui? f }
- { deploy-name "Sudoku" }
+ { deploy-word-props? f }
{ "stop-after-last-window?" t }
- { deploy-word-defs? f }
}
-USING: kernel symbols tools.test ;
+USING: kernel symbols tools.test parser generic words ;
IN: symbols.tests
[ ] [ SYMBOLS: a b c ; ] unit-test
[ a ] [ a ] unit-test
[ b ] [ b ] unit-test
[ c ] [ c ] unit-test
+
+DEFER: blah
+
+[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test
+[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test
+
+[ f ] [ \ blah generic? ] unit-test
+[ t ] [ \ blah symbol? ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser sequences words ;
+USING: parser sequences words kernel ;
IN: symbols
: SYMBOLS:
- ";" parse-tokens [ create-in define-symbol ] each ;
+ ";" parse-tokens
+ [ create-in dup reset-generic define-symbol ] each ;
parsing
: run-factor ( vm flags -- )
swap add* dup . run-with-output ; inline
-: make-staging-image ( vm config -- )
- staging-command-line run-factor ;
+: make-staging-image ( config -- )
+ vm swap staging-command-line run-factor ;
+
+: ?make-staging-image ( config -- )
+ dup [ staging-image-name ] bind exists?
+ [ drop ] [ make-staging-image ] if ;
: deploy-command-line ( image vocab config -- flags )
[
: make-deploy-image ( vm image vocab config -- )
make-boot-image
- dup staging-image-name exists? [
- >r pick r> tuck make-staging-image
- ] unless
+ dup ?make-staging-image
deploy-command-line run-factor ;
SYMBOL: deploy-implementation
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
-tools.deploy.backend math sequences io.launcher ;\r
+tools.deploy.backend math sequences io.launcher arrays ;\r
\r
-: shake-and-bake\r
+: shake-and-bake ( vocab -- )\r
"." resource-path [\r
- vm\r
+ >r vm\r
"test.image" temp-file\r
- rot dup deploy-config make-deploy-image\r
+ r> dup deploy-config make-deploy-image\r
] with-directory ;\r
\r
+: small-enough? ( n -- ? )\r
+ >r "test.image" temp-file file-info file-info-size r> <= ;\r
+\r
[ ] [ "hello-world" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- "hello.image" temp-file file-info file-info-size 500000 <=\r
+ 500000 small-enough?\r
] unit-test\r
\r
[ ] [ "sudoku" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- "hello.image" temp-file file-info file-info-size 1500000 <=\r
+ 1500000 small-enough?\r
] unit-test\r
\r
[ ] [ "hello-ui" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- "hello.image" temp-file file-info file-info-size 2000000 <=\r
+ 2000000 small-enough?\r
] unit-test\r
\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- "hello.image" temp-file file-info file-info-size 3000000 <=\r
+ 3000000 small-enough?\r
] unit-test\r
\r
[ ] [\r
"tools.deploy.test.1" shake-and-bake\r
- vm "-i=" "test.image" temp-file append try-process\r
+ vm "-i=" "test.image" temp-file append 2array try-process\r
] unit-test\r
\r
[ ] [\r
"tools.deploy.test.2" shake-and-bake\r
- vm "-i=" "test.image" temp-file append try-process\r
+ vm "-i=" "test.image" temp-file append 2array try-process\r
] unit-test\r
QUALIFIED: init
QUALIFIED: inspector
QUALIFIED: io.backend
-QUALIFIED: io.nonblocking
QUALIFIED: io.thread
QUALIFIED: layouts
QUALIFIED: libc.private
strip-io? [ io.backend:io-backend , ] when
- { io.backend:io-backend io.nonblocking:default-buffer-size }
+ [
+ io.backend:io-backend ,
+ "default-buffer-size" "io.nonblocking" lookup ,
+ ] { } make
{ "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [
global swap
'[ drop , member? not ] assoc-subset
[ drop string? not ] assoc-subset ! strip CLI args
- dup keys .
+ dup keys unparse show
21 setenv
] [ drop ] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals continuations
-threads namespaces namespaces.private ;
+threads namespaces namespaces.private assocs ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
- [let | p [ <promise> ]
- s [ f <model> ]
- c [ f <model> ] |
+ [let | p [ <promise> ] |
[
H{ } clone >n
- [ s c start-walker-thread p fulfill ] new-walker-hook set
- [ drop ] show-walker-hook set
+
+ [
+ p promise-fulfilled?
+ [ drop ] [ p fulfill ] if
+ 2drop
+ ] show-walker-hook set
break
p ?promise
send-synchronous drop
- detach
p ?promise
- send-synchronous drop
-
- c model-value continuation-data
+ thread-variables walker-continuation swap at
+ model-value continuation-data
] ;
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models ;
+sequences.private assocs models combinators.cleave ;
IN: tools.walker
-SYMBOL: new-walker-hook ! ( -- )
-SYMBOL: show-walker-hook ! ( thread -- )
+SYMBOL: show-walker-hook ! ( status continuation thread -- )
-! Thread local
+! Thread local in thread being walked
SYMBOL: walker-thread
+
+! Thread local in walker thread
SYMBOL: walking-thread
+SYMBOL: walker-status
+SYMBOL: walker-continuation
+SYMBOL: walker-history
+
+DEFER: start-walker-thread
-: get-walker-thread ( -- thread )
+: get-walker-thread ( -- status continuation thread )
walker-thread tget [
- dup show-walker-hook get call
+ [ thread-variables walker-status swap at ]
+ [ thread-variables walker-continuation swap at ]
+ [ ] tri
] [
- new-walker-hook get call
- walker-thread tget
+ f <model>
+ f <model>
+ 2dup start-walker-thread
] if* ;
-: break ( -- )
- continuation callstack over set-continuation-call
+USING: io.streams.c prettyprint ;
+
+: show-walker ( -- thread )
+ get-walker-thread
+ [ show-walker-hook get call ] keep ;
- get-walker-thread send-synchronous {
+: after-break ( object -- )
+ {
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ "Single stepping abandoned" throw ] }
} cond ;
+: break ( -- )
+ continuation callstack over set-continuation-call
+ show-walker send-synchronous
+ after-break ;
+
\ break t "break?" set-word-prop
: walk ( quot -- quot' )
SYMBOL: abandon
SYMBOL: call-in
-! Thread locals
-SYMBOL: walker-status
-SYMBOL: walker-continuation
-SYMBOL: walker-history
-
SYMBOL: +running+
SYMBOL: +suspended+
SYMBOL: +stopped+
-SYMBOL: +detached+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
: set-status ( symbol -- )
walker-status tget set-model ;
-: unassociate-thread ( -- )
- walker-thread walking-thread tget thread-variables delete-at
- [ ] walking-thread tget set-thread-exit-handler ;
-
-: detach-msg ( -- )
- +detached+ set-status
- unassociate-thread ;
-
: keep-running ( -- )
+running+ set-status ;
: walker-stopped ( -- )
+stopped+ set-status
- [ status +stopped+ eq? ] [
- [
- {
- { detach [ detach-msg ] }
- [ drop ]
- } case f
- ] handle-synchronous
- ] [ ] while ;
+ [ status +stopped+ eq? ]
+ [ [ drop f ] handle-synchronous ]
+ [ ] while ;
: step-into-all-loop ( -- )
+running+ set-status
[ status +running+ eq? ] [
[
{
- { detach [ detach-msg f ] }
{ step [ f ] }
{ step-out [ f ] }
{ step-into [ f ] }
{
! These are sent by the walker tool. We reply
! and keep cycling.
- { detach [ detach-msg ] }
- ! These change the state of the thread being
- ! interpreted, so we modify the continuation and
- ! output f.
{ step [ step-msg keep-running ] }
{ step-out [ step-out-msg keep-running ] }
{ step-into [ step-into-msg keep-running ] }
: walker-loop ( -- )
+running+ set-status
- [ status +detached+ eq? not ] [
+ [ status +stopped+ eq? not ] [
[
{
- { detach [ detach-msg f ] }
! ignore these commands while the thread is
! running
{ step [ f ] }
] keep *void* ;
: open-face ( font style -- face )
- ttf-name ttf-path
- dup malloc-file-contents
- swap file-info file-info-size
- (open-face) ;
+ ttf-name ttf-path malloc-file-contents (open-face) ;
SYMBOL: dpi
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
-namespaces tools.walker assocs ;
+namespaces tools.walker assocs combinators combinators.cleave ;
IN: ui.tools.walker
-TUPLE: walker-gadget status continuation thread traceback ;
+TUPLE: walker-gadget
+status continuation thread
+traceback
+closing? ;
: walker-command ( walker msg -- )
- over walker-gadget-thread thread-registered?
- [ swap walker-gadget-thread send-synchronous drop ]
+ swap
+ dup walker-gadget-thread thread-registered?
+ [ walker-gadget-thread send-synchronous drop ]
[ 2drop ] if ;
: com-step ( walker -- ) step walker-command ;
: com-abandon ( walker -- ) abandon walker-command ;
M: walker-gadget ungraft*
- dup delegate ungraft* detach walker-command ;
+ [ t swap set-walker-gadget-closing? ]
+ [ com-continue ]
+ [ delegate ungraft* ] tri ;
M: walker-gadget focusable-child*
walker-gadget-traceback ;
{ +stopped+ "Stopped" }
{ +suspended+ "Suspended" }
{ +running+ "Running" }
- { +detached+ "Detached" }
} at %
")" %
drop
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
- over <traceback-gadget> walker-gadget construct-boa [
+ over <traceback-gadget> f walker-gadget construct-boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
{ T{ key-down f f "F1" } walker-help }
} define-command-map
-: walker-window ( -- )
- f <model> f <model> 2dup start-walker-thread
- [ <walker-gadget> ] keep thread-name open-status-window ;
+: walker-for-thread? ( thread gadget -- ? )
+ {
+ { [ dup walker-gadget? not ] [ 2drop f ] }
+ { [ dup walker-gadget-closing? ] [ 2drop f ] }
+ { [ t ] [ walker-gadget-thread eq? ] }
+ } cond ;
-[ [ walker-window ] with-ui ] new-walker-hook set-global
+: find-walker-window ( thread -- world/f )
+ [ swap walker-for-thread? ] curry find-window ;
+
+: walker-window ( status continuation thread -- )
+ [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
[
- [
- >r dup walker-gadget?
- [ walker-gadget-thread r> eq? ]
- [ r> 2drop f ] if
- ] curry find-window raise-window
+ dup find-walker-window dup
+ [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
] show-walker-hook set-global
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+! ! ! !
+: set-world-dim ( dim world -- )
+ swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
+ SetWindowPos drop ;
+USE: random
+USE: arrays
+
+: twiddle
+ 100 500 random +
+ 100 500 random +
+ 2array
+ "x" get-global find-world
+ set-world-dim
+ yield ;
+! ! ! !
+
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
- "MSG" <c-object> msg-obj set-global
+ "MSG" malloc-object msg-obj set-global
"Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
- class-name-ptr get-global [
- dup f UnregisterClass drop
- free
- ] when*
- f class-name-ptr set-global ;
+ class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+ msg-obj get-global [ free ] when*
+ f class-name-ptr set-global
+ f msg-obj set-global ;
: setup-pixel-format ( hdc -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
<<
: VALUE:
- CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
+ CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;
! FUNCTION: SetWindowLongA
! FUNCTION: SetWindowLongW
! FUNCTION: SetWindowPlacement
-! FUNCTION: SetWindowPos
+FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
+
+: HWND_BOTTOM ALIEN: 1 ;
+: HWND_NOTOPMOST ALIEN: -2 ;
+: HWND_TOP ALIEN: 0 ;
+: HWND_TOPMOST ALIEN: -1 ;
+
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA
! FUNCTION: SetWindowsHookExA
(" !.*$" . font-lock-comment-face)
("( .* )" . font-lock-comment-face)
"MAIN:"
- "IN:" "USING:" "TUPLE:" "^C:" "^M:" "USE:" "REQUIRE:" "PROVIDE:"
+ "IN:" "USING:" "TUPLE:" "^C:" "^M:"
+ "METHOD:"
+ "USE:" "REQUIRE:" "PROVIDE:"
"REQUIRES:"
"GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:"
"C-STRUCT:"
(insert str)
(comint-send-input))))
+(defun factor-send-definition ()
+ (interactive)
+ (factor-send-region (search-backward ":")
+ (search-forward ";")))
+
(defun factor-see ()
(interactive)
(comint-send-string "*factor*" "\\ ")
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
+(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
(define-key factor-mode-map "\C-c\C-s" 'factor-see)
(define-key factor-mode-map "\C-ce" 'factor-edit)
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
(defun factor-refresh-all ()
(interactive)
- (comint-send-string "*factor*" "refresh-all\n"))
\ No newline at end of file
+ (comint-send-string "*factor*" "refresh-all\n"))
+
+
--- /dev/null
+Elie Chaftari
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with libharu2 2.0.8 on Mac OS X 10.4.9 PowerPC
+!
+! export LD_LIBRARY_PATH=/opt/local/lib
+
+USING: alien alien.syntax combinators system ;
+
+IN: pdf.libhpdf
+
+<< "libhpdf" {
+ { [ win32? ] [ "libhpdf.dll" "stdcall" ] }
+ { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
+ { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
+} cond add-library >>
+
+! compression mode
+: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
+: HPDF_COMP_TEXT HEX: 01 ; inline ! Compress contents stream of page
+: HPDF_COMP_IMAGE HEX: 02 ; inline ! Compress streams of image objects
+: HPDF_COMP_METADATA HEX: 04 ; inline ! Compress other data (fonts, cmaps...)
+: HPDF_COMP_ALL HEX: 0F ; inline ! All stream data are compressed
+: HPDF_COMP_MASK HEX: FF ; inline
+
+! page mode
+C-ENUM:
+ HPDF_PAGE_MODE_USE_NONE
+ HPDF_PAGE_MODE_USE_OUTLINE
+ HPDF_PAGE_MODE_USE_THUMBS
+ HPDF_PAGE_MODE_FULL_SCREEN
+ HPDF_PAGE_MODE_EOF
+;
+
+: error-code ( -- seq ) {
+ { HEX: 1001 "HPDF_ARRAY_COUNT_ERR\nInternal error. The consistency of the data was lost." }
+ { HEX: 1002 "HPDF_ARRAY_ITEM_NOT_FOUND\nInternal error. The consistency of the data was lost." }
+ { HEX: 1003 "HPDF_ARRAY_ITEM_UNEXPECTED_TYPE\nInternal error. The consistency of the data was lost." }
+ { HEX: 1004 "HPDF_BINARY_LENGTH_ERR\nThe length of the data exceeds HPDF_LIMIT_MAX_STRING_LEN." }
+ { HEX: 1005 "HPDF_CANNOT_GET_PALLET\nCannot get a pallet data from PNG image." }
+ { HEX: 1007 "HPDF_DICT_COUNT_ERR\nThe count of elements of a dictionary exceeds HPDF_LIMIT_MAX_DICT_ELEMENT" }
+ { HEX: 1008 "HPDF_DICT_ITEM_NOT_FOUND\nInternal error. The consistency of the data was lost." }
+ { HEX: 1009 "HPDF_DICT_ITEM_UNEXPECTED_TYPE\nInternal error. The consistency of the data was lost." }
+ { HEX: 100A "HPDF_DICT_STREAM_LENGTH_NOT_FOUND\nInternal error. The consistency of the data was lost." }
+ { HEX: 100B "HPDF_DOC_ENCRYPTDICT_NOT_FOUND\nHPDF_SetPermission() OR HPDF_SetEncryptMode() was called before a password is set." }
+ { HEX: 100C "HPDF_DOC_INVALID_OBJECT\nInternal error. The consistency of the data was lost." }
+ { HEX: 100E "HPDF_DUPLICATE_REGISTRATION\nTried to register a font that has been registered." }
+ { HEX: 100F "HPDF_EXCEED_JWW_CODE_NUM_LIMIT\nCannot register a character to the japanese word wrap characters list." }
+ { HEX: 1011 "HPDF_ENCRYPT_INVALID_PASSWORD\nTried to set the owner password to NULL. owner password and user password is the same." }
+ { HEX: 1013 "HPDF_ERR_UNKNOWN_CLASS\nInternal error. The consistency of the data was lost." }
+ { HEX: 1014 "HPDF_EXCEED_GSTATE_LIMIT\nThe depth of the stack exceeded HPDF_LIMIT_MAX_GSTATE." }
+ { HEX: 1015 "HPDF_FAILED_TO_ALLOC_MEM\nMemory allocation failed." }
+ { HEX: 1016 "HPDF_FILE_IO_ERROR\nFile processing failed. (A detailed code is set.)" }
+ { HEX: 1017 "HPDF_FILE_OPEN_ERROR\nCannot open a file. (A detailed code is set.)" }
+ { HEX: 1019 "HPDF_FONT_EXISTS\nTried to load a font that has already been registered." }
+ { HEX: 101A "HPDF_FONT_INVALID_WIDTHS_TABLE\nThe format of a font-file is invalid . Internal error. The consistency of the data was lost." }
+ { HEX: 101B "HPDF_INVALID_AFM_HEADER\nCannot recognize a header of an afm file." }
+ { HEX: 101C "HPDF_INVALID_ANNOTATION\nThe specified annotation handle is invalid." }
+ { HEX: 101E "HPDF_INVALID_BIT_PER_COMPONENT\nBit-per-component of a image which was set as mask-image is invalid." }
+ { HEX: 101F "HPDF_INVALID_CHAR_MATRICS_DATA\nCannot recognize char-matrics-data of an afm file." }
+ { HEX: 1020 "HPDF_INVALID_COLOR_SPACE\n1. The color_space parameter of HPDF_LoadRawImage is invalid.\n2. Color-space of a image which was set as mask-image is invalid.\n3. The function which is invalid in the present color-space was invoked." }
+ { HEX: 1021 "HPDF_INVALID_COMPRESSION_MODE\nInvalid value was set when invoking HPDF_SetCommpressionMode()." }
+ { HEX: 1022 "HPDF_INVALID_DATE_TIME\nAn invalid date-time value was set." }
+ { HEX: 1023 "HPDF_INVALID_DESTINATION\nAn invalid destination handle was set." }
+ { HEX: 1025 "HPDF_INVALID_DOCUMENT\nAn invalid document handle is set." }
+ { HEX: 1026 "HPDF_INVALID_DOCUMENT_STATE\nThe function which is invalid in the present state was invoked." }
+ { HEX: 1027 "HPDF_INVALID_ENCODER\nAn invalid encoder handle was set." }
+ { HEX: 1028 "HPDF_INVALID_ENCODER_TYPE\nA combination between font and encoder is wrong." }
+ { HEX: 102B "HPDF_INVALID_ENCODING_NAME\nAn Invalid encoding name is specified." }
+ { HEX: 102C "HPDF_INVALID_ENCRYPT_KEY_LEN\nThe lengh of the key of encryption is invalid." }
+ { HEX: 102D "HPDF_INVALID_FONTDEF_DATA\n1. An invalid font handle was set.\n2. Unsupported font format." }
+ { HEX: 102E "HPDF_INVALID_FONTDEF_TYPE\nInternal error. The consistency of the data was lost." }
+ { HEX: 102F "HPDF_INVALID_FONT_NAME\nA font which has the specified name is not found." }
+ { HEX: 1030 "HPDF_INVALID_IMAGE\nUnsupported image format." }
+ { HEX: 1031 "HPDF_INVALID_JPEG_DATA\nUnsupported image format." }
+ { HEX: 1032 "HPDF_INVALID_N_DATA\nCannot read a postscript-name from an afm file." }
+ { HEX: 1033 "HPDF_INVALID_OBJECT\n1. An invalid object is set.\n2. Internal error. The consistency of the data was lost." }
+ { HEX: 1034 "HPDF_INVALID_OBJ_ID\nInternal error. The consistency of the data was lost." }
+ { HEX: 1035 "HPDF_INVALID_OPERATION\nInvoked HPDF_Image_SetColorMask() against the image-object which was set a mask-image." }
+ { HEX: 1036 "HPDF_INVALID_OUTLINE\nAn invalid outline-handle was specified." }
+ { HEX: 1037 "HPDF_INVALID_PAGE\nAn invalid page-handle was specified." }
+ { HEX: 1038 "HPDF_INVALID_PAGES\nAn invalid pages-handle was specified. (internal error)" }
+ { HEX: 1039 "HPDF_INVALID_PARAMETER\nAn invalid value is set." }
+ { HEX: 103B "HPDF_INVALID_PNG_IMAGE\nInvalid PNG image format." }
+ { HEX: 103C "HPDF_INVALID_STREAM\nInternal error. The consistency of the data was lost." }
+ { HEX: 103D "HPDF_MISSING_FILE_NAME_ENTRY\nInternal error. The \"_FILE_NAME\" entry for delayed loading is missing." }
+ { HEX: 103F "HPDF_INVALID_TTC_FILE\nInvalid .TTC file format." }
+ { HEX: 1040 "HPDF_INVALID_TTC_INDEX\nThe index parameter was exceed the number of included fonts" }
+ { HEX: 1041 "HPDF_INVALID_WX_DATA\nCannot read a width-data from an afm file." }
+ { HEX: 1042 "HPDF_ITEM_NOT_FOUND\nInternal error. The consistency of the data was lost." }
+ { HEX: 1043 "HPDF_LIBPNG_ERROR\nAn error has returned from PNGLIB while loading an image." }
+ { HEX: 1044 "HPDF_NAME_INVALID_VALUE\nInternal error. The consistency of the data was lost." }
+ { HEX: 1045 "HPDF_NAME_OUT_OF_RANGE\nInternal error. The consistency of the data was lost." }
+ { HEX: 1049 "HPDF_PAGES_MISSING_KIDS_ENTRY\nInternal error. The consistency of the data was lost." }
+ { HEX: 104A "HPDF_PAGE_CANNOT_FIND_OBJECT\nInternal error. The consistency of the data was lost." }
+ { HEX: 104B "HPDF_PAGE_CANNOT_GET_ROOT_PAGES\nInternal error. The consistency of the data was lost." }
+ { HEX: 104C "HPDF_PAGE_CANNOT_RESTORE_GSTATE\nThere are no graphics-states to be restored." }
+ { HEX: 104D "HPDF_PAGE_CANNOT_SET_PARENT\nInternal error. The consistency of the data was lost." }
+ { HEX: 104E "HPDF_PAGE_FONT_NOT_FOUND\nThe current font is not set." }
+ { HEX: 104F "HPDF_PAGE_INVALID_FONT\nAn invalid font-handle was specified." }
+ { HEX: 1050 "HPDF_PAGE_INVALID_FONT_SIZE\nAn invalid font-size was set." }
+ { HEX: 1051 "HPDF_PAGE_INVALID_GMODE\nSee Graphics mode." }
+ { HEX: 1052 "HPDF_PAGE_INVALID_INDEX\nInternal error. The consistency of the data was lost." }
+ { HEX: 1053 "HPDF_PAGE_INVALID_ROTATE_VALUE\nThe specified value is not a multiple of 90." }
+ { HEX: 1054 "HPDF_PAGE_INVALID_SIZE\nAn invalid page-size was set." }
+ { HEX: 1055 "HPDF_PAGE_INVALID_XOBJECT\nAn invalid image-handle was set." }
+ { HEX: 1056 "HPDF_PAGE_OUT_OF_RANGE\nThe specified value is out of range." }
+ { HEX: 1057 "HPDF_REAL_OUT_OF_RANGE\nThe specified value is out of range." }
+ { HEX: 1058 "HPDF_STREAM_EOF\nUnexpected EOF marker was detected." }
+ { HEX: 1059 "HPDF_STREAM_READLN_CONTINUE\nInternal error. The consistency of the data was lost." }
+ { HEX: 105B "HPDF_STRING_OUT_OF_RANGE\nThe length of the specified text is too long." }
+ { HEX: 105C "HPDF_THIS_FUNC_WAS_SKIPPED\nThe execution of a function was skipped because of other errors." }
+ { HEX: 105D "HPDF_TTF_CANNOT_EMBEDDING_FONT\nThis font cannot be embedded. (restricted by license.)" }
+ { HEX: 105E "HPDF_TTF_INVALID_CMAP\nUnsupported ttf format. (cannot find unicode cmap.)" }
+ { HEX: 105F "HPDF_TTF_INVALID_FOMAT\nUnsupported ttf format." }
+ { HEX: 1060 "HPDF_TTF_MISSING_TABLE\nUnsupported ttf format. (cannot find a necessary table.)" }
+ { HEX: 1061 "HPDF_UNSUPPORTED_FONT_TYPE\nInternal error. The consistency of the data was lost." }
+ { HEX: 1062 "HPDF_UNSUPPORTED_FUNC\n1. The library is not configured to use PNGLIB.\n2. Internal error. The consistency of the data was lost." }
+ { HEX: 1063 "HPDF_UNSUPPORTED_JPEG_FORMAT\nUnsupported Jpeg format." }
+ { HEX: 1064 "HPDF_UNSUPPORTED_TYPE1_FONT\nFailed to parse .PFB file." }
+ { HEX: 1065 "HPDF_XREF_COUNT_ERR\nInternal error. The consistency of the data was lost." }
+ { HEX: 1066 "HPDF_ZLIB_ERROR\nAn error has occurred while executing a function of Zlib." }
+ { HEX: 1067 "HPDF_INVALID_PAGE_INDEX\nAn error returned from Zlib." }
+ { HEX: 1068 "HPDF_INVALID_URI\nAn invalid URI was set." }
+ { HEX: 1069 "HPDF_PAGELAYOUT_OUT_OF_RANGE\nAn invalid page-layout was set." }
+ { HEX: 1070 "HPDF_PAGEMODE_OUT_OF_RANGE\nAn invalid page-mode was set." }
+ { HEX: 1071 "HPDF_PAGENUM_STYLE_OUT_OF_RANGE\nAn invalid page-num-style was set." }
+ { HEX: 1072 "HPDF_ANNOT_INVALID_ICON\nAn invalid icon was set." }
+ { HEX: 1073 "HPDF_ANNOT_INVALID_BORDER_STYLE\nAn invalid border-style was set." }
+ { HEX: 1074 "HPDF_PAGE_INVALID_DIRECTION\nAn invalid page-direction was set." }
+ { HEX: 1075 "HPDF_INVALID_FONT\nAn invalid font-handle was specified." }
+} ;
+
+LIBRARY: libhpdf
+
+! ===============================================
+! hpdf.h
+! ===============================================
+
+FUNCTION: void* HPDF_New ( void* user_error_fn, void* user_data ) ;
+
+FUNCTION: void* HPDF_Free ( void* pdf ) ;
+
+FUNCTION: ulong HPDF_SetCompressionMode ( void* pdf, uint mode ) ;
+
+FUNCTION: ulong HPDF_SetPageMode ( void* pdf, uint mode ) ;
+
+FUNCTION: void* HPDF_AddPage ( void* pdf ) ;
+
+FUNCTION: ulong HPDF_SaveToFile ( void* pdf, char* file_name ) ;
+
+FUNCTION: float HPDF_Page_GetHeight ( void* page ) ;
+
+FUNCTION: float HPDF_Page_GetWidth ( void* page ) ;
+
+FUNCTION: ulong HPDF_Page_SetLineWidth ( void* page, float line_width ) ;
+
+FUNCTION: ulong HPDF_Page_Rectangle ( void* page, float x, float y,
+ float width, float height ) ;
+
+FUNCTION: ulong HPDF_Page_Stroke ( void* page ) ;
+
+FUNCTION: void* HPDF_GetFont ( void* pdf, char* font_name,
+ char* encoding_name ) ;
+
+FUNCTION: ulong HPDF_Page_SetFontAndSize ( void* page, void* font,
+ float size ) ;
+
+FUNCTION: float HPDF_Page_TextWidth ( void* page, char* text ) ;
+
+FUNCTION: ulong HPDF_Page_BeginText ( void* page ) ;
+
+FUNCTION: ulong HPDF_Page_TextOut ( void* page, float xpos, float ypos,
+ char* text ) ;
+
+FUNCTION: ulong HPDF_Page_EndText ( void* page ) ;
+
+FUNCTION: ulong HPDF_Page_MoveTextPos ( void* page, float x, float y ) ;
+
+FUNCTION: ulong HPDF_Page_ShowText ( void* page, char* text ) ;
--- /dev/null
+USING: io.files kernel math namespaces pdf pdf.libhpdf prettyprint sequences ;
+IN: pdf.tests
+
+SYMBOL: font
+
+SYMBOL: width
+SYMBOL: height
+SYMBOL: twidth
+
+: font-list ( -- seq ) {
+ "Courier"
+ "Courier-Bold"
+ "Courier-Oblique"
+ "Courier-BoldOblique"
+ "Helvetica"
+ "Helvetica-Bold"
+ "Helvetica-Oblique"
+ "Helvetica-BoldOblique"
+ "Times-Roman"
+ "Times-Bold"
+ "Times-Italic"
+ "Times-BoldItalic"
+ "Symbol"
+ "ZapfDingbats"
+} ;
+
+[
+ ! HPDF_COMP_ALL set-compression-mode
+
+ ! HPDF_PAGE_MODE_USE_OUTLINE set-page-mode
+
+ ! Add a new page object
+ add-page
+
+ get-page-height height set
+
+ get-page-width width set
+
+ ! Print the lines of the page
+ 1 set-page-line-width
+
+ 50 50 width get 100 - height get 110 - page-rectangle
+
+ page-stroke
+
+ ! Print the title of the page (with positioning center)
+ "Helvetica" f get-font font set
+
+ font get 24 set-page-font-and-size
+
+ "Font Demo" page-text-width twidth set
+
+ [
+ width get twidth get - 2 / height get 50 - "Font Demo" page-text-out
+
+ ] with-text
+
+ ! Print subtitle
+ [
+ font get 16 set-page-font-and-size
+
+ 60 height get 80 - "<Standard Type1 font samples>" page-text-out
+
+ ] with-text
+
+ ! Print font list
+ [
+ 60 height get 105 - page-move-text-pos
+
+ SYMBOL: fontname
+
+ font-list [
+
+ fontname set
+
+ fontname get f get-font font set
+
+ ! print a label of text
+ font get 9 set-page-font-and-size
+
+ fontname get page-show-text
+
+ 0 -18 page-move-text-pos
+
+ ! print a sample text
+ font get 20 set-page-font-and-size
+
+ "abcdefgABCDEFG12345!#$%&+-@?" page-show-text
+
+ 0 -20 page-move-text-pos
+
+ ] each
+
+ ] with-text
+
+ "font_test.pdf" temp-file save-to-file
+
+] with-pdf
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with libharu2 2.0.8 on Mac OS X 10.4.9 PowerPC
+
+USING: assocs continuations hashtables kernel math namespaces pdf.libhpdf ;
+
+IN: pdf
+
+SYMBOL: pdf
+SYMBOL: page
+
+! =========================================================
+! Error handling routines
+! =========================================================
+
+: check-status ( status -- )
+ dup zero? [
+ drop
+ ] [
+ error-code >hashtable at throw
+ ] if ;
+
+! =========================================================
+! Document handling routines
+! =========================================================
+
+: new-pdf ( error-handler user-data -- )
+ HPDF_New pdf set ;
+
+: free-pdf ( -- )
+ pdf get HPDF_Free drop ;
+
+: with-pdf ( quot -- )
+ [ f f new-pdf [ free-pdf ] [ ] cleanup ] with-scope ; inline
+
+: set-compression-mode ( mode -- )
+ pdf get swap HPDF_SetCompressionMode check-status ;
+
+: set-page-mode ( mode -- )
+ pdf get swap HPDF_SetPageMode check-status ;
+
+: add-page ( -- )
+ pdf get HPDF_AddPage page set ;
+
+: save-to-file ( filename -- )
+ pdf get swap HPDF_SaveToFile check-status ;
+
+: get-font ( fontname encoding -- font )
+ pdf get -rot HPDF_GetFont ;
+
+! =========================================================
+! Page Handling routines
+! =========================================================
+
+: get-page-height ( -- height )
+ page get HPDF_Page_GetHeight ;
+
+: get-page-width ( -- width )
+ page get HPDF_Page_GetWidth ;
+
+: page-text-width ( text -- width )
+ page get swap HPDF_Page_TextWidth ;
+
+! =========================================================
+! Graphics routines
+! =========================================================
+
+: set-page-line-width ( linewidth -- )
+ page get swap HPDF_Page_SetLineWidth check-status ;
+
+: page-rectangle ( x y width height -- )
+ >r >r >r >r page get r> r> r> r> HPDF_Page_Rectangle check-status ;
+
+: page-stroke ( -- )
+ page get HPDF_Page_Stroke check-status ;
+
+: set-page-font-and-size ( font size -- )
+ page get -rot HPDF_Page_SetFontAndSize check-status ;
+
+: page-begin-text ( -- )
+ page get HPDF_Page_BeginText check-status ;
+
+: page-text-out ( xpos ypos text -- )
+ page get -roll HPDF_Page_TextOut check-status ;
+
+: page-end-text ( -- )
+ page get HPDF_Page_EndText check-status ;
+
+: with-text ( -- )
+ [ page-begin-text [ page-end-text ] [ ] cleanup ] with-scope ; inline
+
+: page-move-text-pos ( x y -- )
+ page get -rot HPDF_Page_MoveTextPos check-status ;
+
+: page-show-text ( text -- )
+ page get swap HPDF_Page_ShowText check-status ;
--- /dev/null
+To build libharu as a shared dylib on Mac OS X, modify the Makefile after calling ./configure --shared\r\rHere are the relevant sections and the lines to be changed:\r\r...\rCC=cc\rPREFIX=/usr/local\r\rLIBNAME=libhpdf.a\rSONAME=libhpdf.dylib\rSOVER1=.1\rSOVER2=.0.0\rLIBTARGET=libhpdf.dylib\rCFLAGS=-Iinclude -fPIC -fno-common -c\r...\r$(SONAME): $(OBJS)\r$(CC) -dynamiclib -o $(SONAME)$(SOVER1)$(SOVER2) $(OBJS) $(LDFLAGS) -Wl\rln -sf $(SONAME)$(SOVER1)$(SOVER2) $(SONAME)$(SOVER1)\rln -sf $(SONAME)$(SOVER1) $(SONAME)
+
+Now you can build and install:
+
+make clean
+make
+make install
+
+Test PDF files from pdf-tests.factor are generated in the test folder.
\ No newline at end of file
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
+ if(word->profiling)
+ word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
+INLINE bool in_data_heap_p(CELL ptr)
+{
+ return (ptr >= data_heap->segment->start
+ && ptr <= data_heap->segment->end);
+}
+
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
- if((CELL)ptr > data_heap->segment->start
- && (CELL)ptr < data_heap->segment->end)
+ if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
projects / factor.git / commitdiff