EXE_OBJS = $(PLAF_EXE_OBJS)
default: misc/wordsize
- make `./misc/target`
+ $(MAKE) `./misc/target`
help:
- @echo "Run 'make' with one of the following parameters:"
+ @echo "Run '$(MAKE)' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"
H{ } clone update-map set
! Builtin classes
-: builtin-predicate ( class predicate -- )
+: builtin-predicate-quot ( class -- quot )
[
- over "type" word-prop dup
+ "type" word-prop dup
\ tag-mask get < \ tag \ type ? , , \ eq? ,
- ] [ ] make define-predicate* ;
+ ] [ ] make ;
-: register-builtin ( class -- )
- dup "type" word-prop builtins get set-nth ;
+: define-builtin-predicate ( class -- )
+ dup
+ dup builtin-predicate-quot define-predicate
+ predicate-word make-inline ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
-: define-builtin ( symbol predicate slotspec -- )
- >r dup make-inline >r
- dup dup lookup-type-number "type" set-word-prop
+: register-builtin ( class -- )
+ dup
+ dup lookup-type-number "type" set-word-prop
+ dup "type" word-prop builtins get set-nth ;
+
+: define-builtin-slots ( symbol slotspec -- )
+ dupd 1 simple-slots
+ 2dup "slots" set-word-prop
+ define-slots ;
+
+: define-builtin ( symbol slotspec -- )
+ >r
+ dup register-builtin
dup f f builtin-class define-class
- dup r> builtin-predicate
- dup r> 1 simple-slots 2dup "slots" set-word-prop
- dupd define-slots
- register-builtin ;
+ dup define-builtin-predicate
+ r> define-builtin-slots ;
H{ } clone typemap set
num-types get f <array> builtins set
"null" "kernel" create drop
-"fixnum" "math" create "fixnum?" "math" create { } define-builtin
+"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
-"bignum" "math" create "bignum?" "math" create { } define-builtin
+"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
-"tuple" "kernel" create "tuple?" "kernel" create
-{ } define-builtin
+"tuple" "kernel" create { } define-builtin
-"ratio" "math" create "ratio?" "math" create
-{
+"ratio" "math" create {
{
{ "integer" "math" }
"numerator"
}
} define-builtin
-"float" "math" create "float?" "math" create { } define-builtin
+"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
-"complex" "math" create "complex?" "math" create
-{
+"complex" "math" create {
{
{ "real" "math" }
"real-part"
}
} define-builtin
-"f" "syntax" lookup "not" "kernel" create
-{ } define-builtin
+"f" "syntax" lookup { } define-builtin
-"array" "arrays" create "array?" "arrays" create
-{ } define-builtin
+! do not word...
-"wrapper" "kernel" create "wrapper?" "kernel" create
-{
+"array" "arrays" create { } define-builtin
+
+"wrapper" "kernel" create {
{
{ "object" "kernel" }
"wrapped"
}
} define-builtin
-"string" "strings" create "string?" "strings" create
-{
+"string" "strings" create {
{
{ "array-capacity" "sequences.private" }
"length"
}
} define-builtin
-"quotation" "quotations" create "quotation?" "quotations" create
-{
+"quotation" "quotations" create {
{
{ "object" "kernel" }
"array"
}
} define-builtin
-"dll" "alien" create "dll?" "alien" create
-{
+"dll" "alien" create {
{
{ "byte-array" "byte-arrays" }
"path"
}
define-builtin
-"alien" "alien" create "alien?" "alien" create
-{
+"alien" "alien" create {
{
{ "c-ptr" "alien" }
"alien"
}
define-builtin
-"word" "words" create "word?" "words" create
-{
+"word" "words" create {
f
{
{ "object" "kernel" }
}
} define-builtin
-"byte-array" "byte-arrays" create
-"byte-array?" "byte-arrays" create
-{ } define-builtin
+"byte-array" "byte-arrays" create { } define-builtin
-"bit-array" "bit-arrays" create
-"bit-array?" "bit-arrays" create
-{ } define-builtin
+"bit-array" "bit-arrays" create { } define-builtin
-"float-array" "float-arrays" create
-"float-array?" "float-arrays" create
-{ } define-builtin
+"float-array" "float-arrays" create { } define-builtin
-"callstack" "kernel" create "callstack?" "kernel" create
-{ } define-builtin
+"callstack" "kernel" create { } define-builtin
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
"f" "syntax" lookup builtins get remove [ ] subset f union-class
define-class
+"f" "syntax" create [ not ] "predicate" set-word-prop
+"f?" "syntax" create "syntax" vocab-words delete-at
+
+"general-t" "kernel" create [ ] "predicate" set-word-prop
+"general-t?" "kernel" create "syntax" vocab-words delete-at
+
! Catch-all class for providing a default method.
"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create
USING: help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes.union classes.mixin
-classes.predicate ;
+classes.predicate quotations ;
IN: classes
ARTICLE: "builtin-classes" "Built-in classes"
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
-HELP: define-predicate*
-{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
-{ $description
- "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
- { $list
- { "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
- { "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
- { "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
- }
- "These properties are used by method dispatch and the help system."
-}
-$low-level-note ;
-
HELP: define-predicate
-{ $values { "class" class } { "quot" "a quotation" } }
-{ $description
- "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
-}
+{ $values { "class" class } { "quot" quotation } }
+{ $description "Defines a predicate word for a class." }
$low-level-note ;
HELP: superclass
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
-DEFER: mixin-forget-test-g
-
-[ "mixin-forget-test" forget-source ] with-compilation-unit
-
-[ ] [
- {
- "USING: sequences ;"
- "IN: classes.tests"
- "MIXIN: mixin-forget-test"
- "INSTANCE: sequence mixin-forget-test"
- "GENERIC: mixin-forget-test-g ( x -- y )"
- "M: mixin-forget-test mixin-forget-test-g ;"
- } "\n" join <string-reader> "mixin-forget-test"
- parse-stream drop
-] unit-test
-
-[ { } ] [ { } mixin-forget-test-g ] unit-test
-[ H{ } mixin-forget-test-g ] must-fail
-
-[ ] [
- {
- "USING: hashtables ;"
- "IN: classes.tests"
- "MIXIN: mixin-forget-test"
- "INSTANCE: hashtable mixin-forget-test"
- "GENERIC: mixin-forget-test-g ( x -- y )"
- "M: mixin-forget-test mixin-forget-test-g ;"
- } "\n" join <string-reader> "mixin-forget-test"
- parse-stream drop
-] unit-test
-
-[ { } mixin-forget-test-g ] must-fail
-[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
+2 [
+ [ "mixin-forget-test" forget-source ] with-compilation-unit
+
+ [ ] [
+ {
+ "USING: sequences ;"
+ "IN: classes.tests"
+ "MIXIN: mixin-forget-test"
+ "INSTANCE: sequence mixin-forget-test"
+ "GENERIC: mixin-forget-test-g ( x -- y )"
+ "M: mixin-forget-test mixin-forget-test-g ;"
+ } "\n" join <string-reader> "mixin-forget-test"
+ parse-stream drop
+ ] unit-test
+
+ [ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
+ [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
+
+ [ ] [
+ {
+ "USING: hashtables ;"
+ "IN: classes.tests"
+ "MIXIN: mixin-forget-test"
+ "INSTANCE: hashtable mixin-forget-test"
+ "GENERIC: mixin-forget-test-g ( x -- y )"
+ "M: mixin-forget-test mixin-forget-test-g ;"
+ } "\n" join <string-reader> "mixin-forget-test"
+ parse-stream drop
+ ] unit-test
+
+ [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
+ [ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
+] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1
PREDICATE: word predicate "predicating" word-prop >boolean ;
-: define-predicate* ( class predicate quot -- )
- over [
- dupd predicate-effect define-declared
- 2dup 1quotation "predicate" set-word-prop
- swap "predicating" set-word-prop
- ] [ 3drop ] if ;
-
: define-predicate ( class quot -- )
- over "forgotten" word-prop [ 2drop ] [
- >r dup predicate-word r> define-predicate*
- ] if ;
+ >r "predicate" word-prop first
+ r> predicate-effect define-declared ;
: superclass ( class -- super )
"superclass" word-prop ;
over reset-class
over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
+ dup predicate-word 2dup 1quotation "predicate" set-word-prop
+ over "predicating" set-word-prop
t "class" set-word-prop ;
GENERIC: update-predicate ( class -- )
{ $subsection :errors }
{ $subsection :warnings }
{ $subsection :linkage }
-"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
+"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
{ $link with-compiler-errors } ;
HELP: compiler-errors
{ $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:"
USING: help.markup help.syntax io io.styles strings
-io.backend io.files.private quotations ;
+ io.backend io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
{ $subsection make-directory }
{ $subsection make-directories } ;
+! ARTICLE: "file-types" "File Types"
+
+! { $table { +directory+ "" } }
+
+! ;
+
ARTICLE: "fs-meta" "File meta-data"
+
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
-{ $subsection file-length }
-{ $subsection file-modified }
+! { $subsection file-modified }
{ $subsection stat } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
! need a $class-description file-info
HELP: file-info
+
{ $values { "path" "a pathname string" }
- { "info" "a file-info tuple" } }
+ { "info" file-info } }
{ $description "Queries the file system for meta data. "
"If path refers to a symbolic link, it is followed."
- "If the file does not exist, an exception is thrown." } ;
+ "If the file does not exist, an exception is thrown." }
+
+ { $class-description "File meta data" }
+
+ { $table
+ { "type" { "One of the following:"
+ { $list { $link +regular-file+ }
+ { $link +directory+ }
+ { $link +symbolic-link+ } } } }
+
+ { "size" "Size of the file in bytes" }
+ { "modified" "Last modification timestamp." } }
+
+ ;
+
! need a see also to link-info
HELP: link-info
"If the file does not exist, an exception is thrown." } ;
! need a see also to file-info
+{ file-info link-info } related-words
+
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "stream" "an input stream" } }
"Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
} ;
-{ stat exists? directory? file-length file-modified } related-words
+{ stat exists? directory? } related-words
HELP: path+
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
-HELP: file-length
-{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
-{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
-
-HELP: file-modified
-{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
-{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
+! HELP: file-modified
+! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
+! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
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-length ( path -- n ) stat drop 2nip ;
: file-modified ( path -- n ) stat >r 3drop r> ;
-: file-permissions ( path -- perm ) stat 2drop nip ;
+! : file-permissions ( path -- perm ) stat 2drop nip ;
: exists? ( path -- ? ) file-modified >boolean ;
-: directory? ( path -- ? ) stat 3drop ;
+! : 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-length read ] with-file-reader ;
+ dupd [ file-info file-info-size read ] with-file-reader ;
+
+! : file-contents ( path encoding -- str )
+! dupd [ file-length read ] with-file-reader ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline
{ $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" } }
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ]
must-fail-with
+
+2 [
+ [ ] [
+ "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
+ <string-reader> "d-f-s-test" parse-stream drop
+ ] unit-test
+
+ [ ] [
+ "IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s"
+ <string-reader> "d-f-s-test" parse-stream drop
+ ] unit-test
+
+ [ ] [
+ "IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
+ <string-reader> "d-f-s-test" parse-stream drop
+ ] unit-test
+] times
"tools.test"
"tools.threads"
"tools.time"
+ "tools.vocabs"
"vocabs"
"vocabs.loader"
"words"
: finish-parsing ( lines quot -- )
file get
[ record-form ] keep
- [ record-modified ] keep
[ record-definitions ] keep
record-checksum ;
IN: source-files
ARTICLE: "source-files" "Source files"
-"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement features such as " { $link refresh-all } "."
+"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "."
$nl
"The source file database:"
{ $subsection source-files }
"The class of source files:"
{ $subsection source-file }
-"Testing if a source file has been changed on disk:"
-{ $subsection source-modified? }
"Words intended for the parser:"
-{ $subsection record-modified }
{ $subsection record-checksum }
{ $subsection record-form }
{ $subsection xref-source }
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
{ $list
{ { $link source-file-path } " - a pathname string." }
- { { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." }
{ { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
{ { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." }
{ { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
}
} ;
-HELP: source-modified?
-{ $values { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's modification time and CRC32 checksum of the file's contents against previously-recorded values." } ;
-
-HELP: record-modified
-{ $values { "source-file" source-file } }
-{ $description "Records the modification time of the source file." }
-$low-level-note ;
-
HELP: record-checksum
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
HELP: reset-checksums
-{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link refresh } "." } ;
+{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
HELP: forget-source
{ $values { "path" "a pathname string" } }
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs kernel math
-namespaces prettyprint sequences strings vectors words
-quotations inspector io.styles io combinators sorting
-splitting math.parser effects continuations debugger
-io.files io.crc32 io.streams.string vocabs
-hashtables graphs compiler.units io.encodings.utf8 ;
+USING: arrays definitions generic assocs kernel math namespaces
+prettyprint sequences strings vectors words quotations inspector
+io.styles io combinators sorting splitting math.parser effects
+continuations debugger io.files io.crc32 vocabs hashtables
+graphs compiler.units io.encodings.utf8 ;
IN: source-files
SYMBOL: source-files
TUPLE: source-file
path
-modified checksum
+checksum
uses definitions ;
-: (source-modified?) ( path modified checksum -- ? )
- pick file-modified rot [ 0 or ] 2apply >
- [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ;
-
-: source-modified? ( path -- ? )
- dup source-files get at [
- dup source-file-path ?resource-path
- over source-file-modified
- rot source-file-checksum
- (source-modified?)
- ] [
- resource-exists?
- ] ?if ;
-
-: record-modified ( source-file -- )
- dup source-file-path ?resource-path file-modified
- swap set-source-file-modified ;
-
: record-checksum ( lines source-file -- )
- swap lines-crc32 swap set-source-file-checksum ;
+ >r lines-crc32 r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
- dup source-file-path <pathname> swap source-file-uses
- [ crossref? ] subset ;
+ dup source-file-path <pathname>
+ swap source-file-uses [ crossref? ] subset ;
: xref-source ( source-file -- )
(xref-source) crossref get add-vertex ;
: reset-checksums ( -- )
source-files get [
- swap ?resource-path dup exists?
- [
- over record-modified
+ swap ?resource-path dup exists? [
utf8 file-lines swap record-checksum
] [ 2drop ] if
] assoc-each ;
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
{ $subsection POSTPONE: MAIN: }
{ $subsection run }
-"Reloading source files changed on disk:"
-{ $subsection refresh }
-{ $subsection refresh-all }
{ $see-also "vocabularies" "parser-files" "source-files" } ;
ABOUT: "vocabs.loader"
HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
-HELP: vocab-tests
-{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
-{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
-
HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
{ vocab-root find-vocab-root } related-words
-HELP: vocab-files
-{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
-{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
-
HELP: no-vocab
{ $values { "name" "a vocabulary name" } }
{ $description "Throws a " { $link no-vocab } "." }
HELP: require
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Loads a vocabulary if it has not already been loaded." }
-{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files, use " { $link refresh } " or " { $link refresh-all } "." } ;
+{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ;
HELP: run
{ $values { "vocab" "a vocabulary specifier" } }
HELP: vocab-docs-path
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
{ $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
-
-HELP: refresh
-{ $values { "prefix" string } }
-{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
-
-HELP: refresh-all
-{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
-
-{ refresh refresh-all } related-words
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs tuples definitions
-debugger compiler.units ;
+debugger compiler.units tools.vocabs ;
! This vocab should not exist, but just in case...
[ ] [
M: vocab-link vocab-root
vocab-link-root ;
-: vocab-tests ( vocab -- tests )
- dup vocab-root [
- [
- f >vocab-link dup
-
- dup "-tests.factor" vocab-dir+ vocab-path+
- dup resource-exists? [ , ] [ drop ] if
-
- dup vocab-dir "tests" path+ vocab-path+ dup
- ?resource-path directory keys [ ".factor" tail? ] subset
- [ path+ , ] with each
- ] { } make
- ] [ drop f ] if ;
-
-: vocab-files ( vocab -- seq )
- f >vocab-link [
- dup vocab-source-path [ , ] when*
- dup vocab-docs-path [ , ] when*
- vocab-tests %
- ] { } make ;
-
SYMBOL: load-help?
: source-was-loaded t swap set-vocab-source-loaded? ;
"To define one, refer to \\ MAIN: help" print
] ?if ;
-: modified ( seq quot -- seq )
- [ dup ] swap compose { } map>assoc
- [ nip ] assoc-subset
- [ nip source-modified? ] assoc-subset keys ; inline
-
-: modified-sources ( vocabs -- seq )
- [ vocab-source-path ] modified ;
-
-: modified-docs ( vocabs -- seq )
- [ vocab-docs-path ] modified ;
-
-: update-roots ( vocabs -- )
- [ dup find-vocab-root swap vocab set-vocab-root ] each ;
-
-: to-refresh ( prefix -- modified-sources modified-docs )
- child-vocabs
- dup update-roots
- dup modified-sources swap modified-docs ;
-
-: vocab-heading. ( vocab -- )
- nl
- "==== " write
- dup vocab-name swap vocab write-object ":" print
- nl ;
-
-: load-error. ( triple -- )
- dup first vocab-heading.
- dup second print-error
- drop ;
-
-: load-failures. ( failures -- )
- [ load-error. nl ] each ;
-
SYMBOL: blacklist
-SYMBOL: failures
-
-: require-all ( vocabs -- failures )
- [
- V{ } clone blacklist set
- V{ } clone failures set
- [
- [ require ]
- [ swap vocab-name failures get set-at ]
- recover
- ] each
- failures get
- ] with-compiler-errors ;
-
-: do-refresh ( modified-sources modified-docs -- )
- 2dup
- [ f swap set-vocab-docs-loaded? ] each
- [ f swap set-vocab-source-loaded? ] each
- append prune require-all load-failures. ;
-
-: refresh ( prefix -- ) to-refresh do-refresh ;
-
-SYMBOL: sources-changed?
-
-[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
-
-: refresh-all ( -- )
- "" refresh f sources-changed? set-global ;
GENERIC: (load-vocab) ( name -- vocab )
-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 ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel vocabs vocabs.loader tools.time tools.browser
+USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger ;
+continuations debugger combinators.cleave ;
IN: benchmark
: run-benchmark ( vocab -- result )
- [ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ;
+ [ [ require ] [ [ run ] benchmark nip ] bi ] curry
+ [ error. f ] recover ;
: run-benchmarks ( -- assoc )
- "benchmark" all-child-vocabs values concat [ vocab-name ] map
+ "benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
- [ "Run time (ms)" write ] with-cell
- [ "GC time (ms)" write ] with-cell
+ [ "Time (ms)" write ] with-cell
] with-row
[
[
- swap [ dup ($vocab-link) ] with-cell
- first2 pprint-cell pprint-cell
+ [ [ 1array $vocab-link ] with-cell ]
+ [ pprint-cell ] bi*
] with-row
] assoc-each
] tabular-output ;
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
-:: select-random ( seed chars floats -- elt )
+:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
write-description
[ make-random-fasta ] 2curry split-lines ; inline
-:: make-repeat-fasta ( k len alu -- )
+:: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +
"tools.test"
"tools.time"
"tools.threads"
+ "tools.vocabs"
+ "tools.vocabs.browser"
"editors"
} [ require ] each
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
- "../../benchmarks" "../benchmarks" [ eval-file ] 2apply
+ "../benchmarks" "benchmarks" [ eval-file ] 2apply
compare-tables
sort-values ;
bootstrap.image benchmark vars bake smtp builder.util accessors
io.encodings.utf8
calendar
+ tools.test
builder.common
builder.benchmark
builder.release ;
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
+
"Did not pass test-all: " print "test-all-vocabs" cat
+ "test-failures" cat
+
+! "test-failures" eval-file test-failures.
+
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.
io
io.files
prettyprint
- tools.browser
+ tools.vocabs
tools.test
io.encodings.utf8
combinators.cleave
: do-tests ( -- )
run-all-tests
- "../test-all-vocabs" utf8
- [
- [ keys . ]
- [ test-failures. ]
- bi
- ]
- with-file-writer ;
+ [ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
+ [ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
+ bi ;
+
+! : do-tests ( -- )
+! run-all-tests
+! "../test-all-vocabs" utf8
+! [
+! [ keys . ]
+! [ test-failures. ]
+! bi
+! ]
+! with-file-writer ;
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
USING: tools.deploy.config ;
-V{
+H{
+ { deploy-math? t }
+ { deploy-reflection 1 }
+ { deploy-name "Bunny" }
+ { deploy-threads? t }
+ { deploy-word-props? f }
+ { "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-io 3 }
- { deploy-reflection 1 }
{ deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
+ { deploy-word-defs? f }
{ deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Bunny" }
}
USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl
-opengl.capabilities sequences ui.gadgets ;
+opengl.capabilities sequences ui.gadgets combinators.cleave ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
[ bunny-outlined-normal-texture [ delete-texture ] when* ]
[ bunny-outlined-depth-texture [ delete-texture ] when* ]
[ f swap set-bunny-outlined-framebuffer-dim ]
- } call-with
+ } cleave
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
[ dispose-framebuffer ]
- } call-with ;
+ } cleave ;
! 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 ;
+! 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 ;
: 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 ;
+! M: cairo-gadget ungraft* ( gadget -- )
+! cairo-gadget-cairo-t cairo_destroy ;
: <cairo-gadget> ( -- gadget )
cairo-gadget construct-gadget ;
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 ;
ARTICLE: "cleave-combinators" "Cleave Combinators"
+"Basic cleavers:"
+
{ $subsection bi }
{ $subsection tri }
+"General cleave: "
+{ $subsection cleave }
+
+"Cleave combinators for quotations with arity 2:"
+{ $subsection 2bi }
+{ $subsection 2tri }
+
{ $notes
"From the Merriam-Webster Dictionary: "
$nl
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+HELP: cleave
+
+{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+{ bi tri cleave 2bi 2tri } related-words
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
ARTICLE: "spread-combinators" "Spread Combinators"
{ $subsection bi* }
-{ $subsection tri* } ;
+{ $subsection tri* }
+{ $subsection spread } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ "p(x)" "p applied to x" }
{ "q(y)" "q applied to y" }
{ "r(z)" "r applied to z" } } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: spread
+
+{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;
\ No newline at end of file
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
+: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline
+
+: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
+ >r >r 2keep r> 2keep r> call ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ drop ]
append ;
+MACRO: 2cleave ( seq -- )
+ dup
+ [ drop [ 2dup ] ] map concat
+ swap
+ dup
+ [ drop [ >r >r ] ] map concat
+ swap
+ [ [ r> r> ] append ] map concat
+ 3append
+ [ 2drop ]
+ append ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 ] ;
: (make-call-with) ( quots -- quot )
[ [ keep ] curry ] map concat [ drop ] append ;
-MACRO: call-with ( quots -- )
- (make-call-with) ;
-
MACRO: map-call-with ( quots -- )
[ (make-call-with) ] keep length [ narray ] curry compose ;
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
[ 2drop ] append ;
-MACRO: call-with2 ( quots -- )
- (make-call-with2) ;
-
MACRO: map-call-with2 ( quots -- )
[ (make-call-with2) ] keep length [ narray ] curry append ;
--- /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
: 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 )
[
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 ) ;
[ 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-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep
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 ;
-
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
-: reset-statement ( statement -- )
- statement-handle sqlite-reset ;
+: reset-statement ( statement -- ) statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
dup statement-bound? [ dup reset-statement ] when
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 )
[
{ +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 ]
{ FACTOR-BLOB "blob" }
} ;
-M: sqlite-db create-type-table
- type-table ;
+M: sqlite-db create-type-table ( symbol -- str ) type-table ;
SYMBOL: person4
: test-tuples ( -- )
- [ person drop-table ] [ drop ] recover
+ [ ] [ person ensure-table ] unit-test
+ [ ] [ person drop-table ] unit-test
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
+ [ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
[ 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
+! [ native-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-tuples ] test-postgresql
TUPLE: serialize-me id data ;
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
[ test-serialize ] test-sqlite
-[ test-serialize ] test-postgresql
+! [ test-serialize ] test-postgresql
TUPLE: exam id name score ;
;
! [ test-ranges ] test-sqlite
+
+\ insert-tuple must-infer
+\ update-tuple must-infer
+\ delete-tuple must-infer
+\ select-tuple must-infer
+\ define-persistent must-infer
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots math
math.parser io prettyprint db.types continuations
-mirrors sequences.lib tools.walker combinators.lib ;
+mirrors sequences.lib tools.walker combinators.lib
+combinators.cleave ;
IN: db.tuples
: define-persistent ( class table columns -- )
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-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
+: ensure-table ( class -- )
+ [ dup drop-table ] ignore-errors create-table ;
+
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
: 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 -- )
[
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tuples tools.crossref tools.browser
+inspector continuations tuples tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader ;
IN: editors
SYMBOL: edit-hook
: available-editors ( -- seq )
- "editors" all-child-vocabs
- values concat [ vocab-name ] map ;
+ "editors" all-child-vocabs-seq [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors
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 }
}
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
- "\"mydata.dat\" dup file-length ["
+ "\"mydata.dat\" dup file-info file-info-length ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
+{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "editor" }
{ $subsection "tools.crossref" }
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences parser kernel help help.markup help.topics
-words strings classes tools.browser namespaces io
+words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
] if
] ($subsection) ;
-: $vocab-link ( element -- ) first dup ($vocab-link) ;
+: $vocab-link ( element -- )
+ first dup vocab-name swap ($vocab-link) ;
: $vocabulary ( element -- )
first word-vocabulary [
TUPLE: link name ;
+MIXIN: topic
+INSTANCE: link topic
+INSTANCE: word topic
+
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
-kernel sequences prettyprint tools.test strings
+kernel sequences prettyprint tools.test tools.vocabs strings
unicode.categories unicode.case ;
IN: help.tutorial
port: 80
version: "1.1"
cookies: V{ }
+ header: H{ }
}
] [
[
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
- #! The content is URL encoded for you.
- >r url-encode r> <post-request> http-request contents ;
+ <post-request> http-request contents ;
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting new-slots accessors calendar
-calendar.format quotations arrays ;
+calendar.format quotations arrays combinators.cleave
+combinators.lib byte-arrays ;
IN: http
: http-port 80 ; inline
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
- dup letter?
- over LETTER? or
- over digit? or
- swap "/_-." member? or ; foldable
+ {
+ [ dup letter? ]
+ [ dup LETTER? ]
+ [ dup digit? ]
+ [ dup "/_-.:" member? ]
+ } || nip ; foldable
: push-utf8 ( ch -- )
- 1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+ 1string utf8 encode
+ [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
- [ [
- dup url-quotable? [ , ] [ push-utf8 ] if
- ] each ] "" make ;
+ [
+ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
] when ;
: assoc>query ( hash -- str )
- [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
+ [
+ [ url-encode ]
+ [ dup number? [ number>string ] when url-encode ]
+ bi*
+ "=" swap 3append
+ ] { } assoc>map
"&" join ;
TUPLE: cookie name value path domain expires http-only ;
: <request>
request construct-empty
- "1.1" >>version
- http-port >>port
- H{ } clone >>query
- V{ } clone >>cookies ;
+ "1.1" >>version
+ http-port >>port
+ H{ } clone >>header
+ H{ } clone >>query
+ V{ } clone >>cookies ;
: query-param ( request key -- value )
swap query>> at ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
+: parse-post-data ( request -- request )
+ dup post-data-type>> "application/x-www-form-urlencoded" =
+ [ dup post-data>> query>assoc >>post-data ] when ;
+
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
read-post-data
extract-host
extract-post-data-type
+ parse-post-data
extract-cookies ;
: write-method ( request -- request )
dup method>> write bl ;
-: write-url ( request -- request )
- dup path>> url-encode write
- dup query>> dup assoc-empty? [ drop ] [
- "?" write
- assoc>query write
- ] if ;
+: (link>string) ( url query -- url' )
+ [ url-encode ] [ assoc>query ] bi*
+ dup empty? [ drop ] [ "?" swap 3append ] if ;
+
+: write-url ( request -- )
+ [ path>> ] [ query>> ] bi (link>string) write ;
: write-request-url ( request -- request )
- write-url bl ;
+ dup write-url bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
+: unparse-post-data ( request -- request )
+ dup post-data>> dup sequence? [ drop ] [
+ assoc>query >>post-data
+ "application/x-www-form-urlencoded" >>post-data-type
+ ] if ;
+
: write-request-header ( request -- request )
dup header>> >hashtable
over host>> [ "host" pick set-at ] when*
dup post-data>> [ write ] when* ;
: write-request ( request -- )
+ unparse-post-data
write-method
write-request-url
write-version
: request-url ( request -- url )
[
- dup host>> [
- "http://" write
- dup host>> url-encode write
- ":" write
- dup port>> number>string write
- ] when
- dup path>> "/" head? [ "/" write ] unless
- write-url
- drop
+ [
+ dup host>> [
+ [ "http://" write host>> url-encode write ]
+ [ ":" write port>> number>string write ]
+ bi
+ ] [ drop ] if
+ ]
+ [ path>> "/" head? [ "/" write ] unless ]
+ [ write-url ]
+ tri
] with-string-writer ;
: set-header ( request/response value key -- request/response )
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
POST http://foo/bar/baz HTTP/1.1
content-length: 5
+content-type: application/x-www-form-urlencoded
xxx=4
;
! 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
-: extract-params ( path -- assoc )\r
- +path+ associate\r
- request get dup method>> {\r
- { "GET" [ query>> ] }\r
- { "HEAD" [ query>> ] }\r
- { "POST" [ post-data>> query>assoc ] }\r
- } case union ;\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
- [ extract-params params set ]\r
- [\r
- action set\r
- request get method>> {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] bi* ;\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
--- /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
\r
TUPLE: login users ;\r
\r
+: users login get users>> ;\r
+\r
SYMBOL: post-login-url\r
SYMBOL: login-failed?\r
\r
\r
: successful-login ( user -- response )\r
logged-in-user sset\r
- post-login-url sget f <permanent-redirect> ;\r
+ post-login-url sget "" or f <permanent-redirect>\r
+ f post-login-url sset ;\r
\r
:: <login-action> ( -- action )\r
[let | form [ <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
] >>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
+ "password" value empty? [\r
+ logged-in-user sget\r
+ ] [\r
+ same-password-twice\r
+\r
+ "password" value uid users check-login\r
+ [ login-failed? on validation-failed ] unless\r
+\r
+ "new-password" value uid users set-password\r
+ [ "User deleted" throw ] unless*\r
+ ] if\r
+\r
+ "realname" value >>realname\r
+ "email" value >>email\r
+\r
+ dup users update-user\r
+ logged-in-user sset\r
+\r
+ previous-page sget f <permanent-redirect>\r
+ ] >>submit\r
+ ] ;\r
+\r
! ! ! Password recovery\r
\r
SYMBOL: lost-password-from\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
+ 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
-<% USING: http.server.auth.login http.server.components kernel\r
-namespaces ; %>\r
+<% USING: http.server.auth.login http.server.components http.server\r
+kernel namespaces ; %>\r
<html>\r
<body>\r
<h1>Login required</h1>\r
\r
<form method="POST" action="login">\r
+\r
+<% hidden-form-field %>\r
+\r
<table>\r
\r
<tr>\r
\r
<p>\r
<% allow-registration? [ %>\r
- <a href="register">Register</a>\r
+ <a href="<% "register" f write-link %>">Register</a>\r
<% ] when %>\r
<% allow-password-recovery? [ %>\r
- <a href="recover-password">Recover Password</a>\r
+ <a href="<% "recover-password" f write-link %>">\r
+ Recover Password\r
+ </a>\r
<% ] when %>\r
</p>\r
\r
-<% USING: http.server.components ; %>\r
+<% USING: http.server.components http.server ; %>\r
<html>\r
<body>\r
<h1>Recover lost password: step 1 of 4</h1>\r
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>\r
\r
<form method="POST" action="recover-password">\r
+\r
+<% hidden-form-field %>\r
+\r
<table>\r
\r
<tr>\r
-<% USING: http.server.components http.server.auth.login\r
+<% USING: http.server.components http.server.auth.login http.server\r
namespaces kernel combinators ; %>\r
<html>\r
<body>\r
<p>Choose a new password for your account.</p>\r
\r
<form method="POST" action="new-password">\r
+\r
+<% hidden-form-field %>\r
+\r
<table>\r
\r
<% "username" component render-edit %>\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
<p><input type="submit" value="Set password" />\r
\r
<% password-mismatch? get [\r
-"passwords do not match" render-error\r
+ "passwords do not match" render-error\r
] when %>\r
\r
</p>\r
-<% USING: http.server.components http.server.auth.login\r
-namespaces kernel combinators ; %>\r
+<% USING: http.server ; %>\r
<html>\r
<body>\r
<h1>Recover lost password: step 4 of 4</h1>\r
\r
-<p>Your password has been reset. You may now <a href="login">log in</a>.</p>\r
+<p>Your password has been reset.\r
+You may now <a href="<% "login" f write-link %>">log in</a>.</p>\r
\r
</body>\r
</html>\r
<% USING: http.server.components http.server.auth.login\r
-namespaces kernel combinators ; %>\r
+http.server namespaces kernel combinators ; %>\r
<html>\r
<body>\r
<h1>New user registration</h1>\r
\r
<form method="POST" action="register">\r
+<% hidden-form-field %>\r
+\r
<table>\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 ] [ "xx" "blah" "provider" get set-password ] unit-test\r
\r
-[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test\r
+[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] 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
\r
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test\r
\r
- [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test\r
+ [ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] 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
{ "profile" "PROFILE" FACTOR-BLOB }\r
} define-persistent\r
\r
-: init-users-table ( -- )\r
- [ user drop-table ] ignore-errors\r
- user create-table ;\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
: 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
+:: set-password ( password username provider -- user/f )\r
[let | user [ username provider get-user ] |\r
user [\r
user\r
password >>password\r
- provider update-user t\r
+ dup provider update-user\r
] [ f ] if\r
] ;\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
\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
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
-vocabs.loader debugger html continuations random combinators
+tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
GENERIC: call-responder ( path responder -- response )
+: request-params ( -- assoc )
+ request get dup method>> {
+ { "GET" [ query>> ] }
+ { "HEAD" [ query>> ] }
+ { "POST" [ post-data>> ] }
+ } case ;
+
: <content> ( content-type -- response )
<response>
200 >>code
+ "Document follows" >>message
swap set-content-type ;
TUPLE: trivial-responder response ;
[ <404> ] <trivial-responder> 404-responder set-global
-: url-redirect ( to query -- url )
- #! Different host.
- dup assoc-empty? [
- drop
- ] [
- assoc>query "?" swap 3append
- ] if ;
+SYMBOL: link-hook
+
+: modify-query ( query -- query )
+ link-hook get [ ] or call ;
+
+: link>string ( url query -- url' )
+ modify-query (link>string) ;
+
+: write-link ( url query -- )
+ link>string write ;
+
+SYMBOL: form-hook
+
+: hidden-form-field ( -- )
+ form-hook get [ ] or call ;
: absolute-redirect ( to query -- url )
#! Same host.
request get clone
swap [ >>query ] when*
- swap >>path
+ swap url-encode >>path
request-url ;
: replace-last-component ( path with -- path' )
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
+ dup query>> modify-query >>query
request-url ;
: derive-url ( to query -- url )
{
- { [ over "http://" head? ] [ url-redirect ] }
+ { [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ t ] [ relative-redirect ] }
} cond ;
: <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
: 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 math namespaces kernel accessors prettyprint\r
+io.streams.string splitting destructors ;\r
+\r
+[ H{ } ] [ H{ } add-session-id ] unit-test\r
\r
: with-session \ session swap with-variable ; inline\r
\r
\r
M: foo init-session* drop 0 "x" sset ;\r
\r
-f <session> [\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
\r
[ 9 ] [ "x" sget sq ] 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
! 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
-quotations hashtables sequences fry combinators.cleave ;
+new-slots accessors http http.server
+http.server.sessions.storage http.server.sessions.storage.assoc
+quotations hashtables sequences fry combinators.cleave
+html.elements symbols continuations destructors ;
IN: http.server.sessions
! ! ! ! ! !
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>> ;
-
-: 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 ;
-
-GENERIC: session-link* ( url query sessions -- string )
-
-M: object session-link* 2drop url-encode ;
-
-: session-link ( url query -- string ) sessions session-link* ;
+: call-responder/session ( path responder id session -- response )
+ [ <session-saver> add-always-destructor ]
+ [ [ 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 request -- session )
- sess-id query-param swap 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-id get [ session-id-key associate union ] when* ;
+
+: session-form-field ( -- )
+ <input
+ "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 )
- dup request get current-session [
+ [ add-session-id ] link-hook set
+ [ session-form-field ] form-hook set
+ dup current-url-session dup [
call-responder/session
] [
- nip
- f swap new-session sess-id associate <temporary-redirect>
- ] if* ;
-
-M: url-sessions session-link*
- drop
- url-encode
- \ session get id>> sess-id associate union assoc>query
- dup assoc-empty? [ drop ] [ "?" swap 3append ] 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
+USING: namespaces io prettyprint ;\r
+M: sessions-in-db get-session ( id storage -- namespace/f )\r
+ global [ "get " write over print flush ] bind\r
+ drop\r
+ dup [\r
+ <session>\r
+ select-tuple dup [ namespace>> ] when global [ dup . ] bind\r
+ ] when ;\r
+\r
+M: sessions-in-db update-session ( namespace id storage -- )\r
+ global [ "update " write over print flush ] bind\r
+ drop\r
+ <session>\r
+ swap global [ dup . ] bind >>namespace\r
+ dup update-tuple\r
+ id>> <session> select-tuple global [ . flush ] bind\r
+ ;\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
+ global [ "new " print flush ] bind\r
+ drop\r
+ f <session>\r
+ swap global [ dup . ] bind >>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
combinators.cleave fry ;\r
IN: http.server.static\r
\r
-SYMBOL: responder\r
-\r
! special maps mime types to quots with effect ( path -- )\r
TUPLE: file-responder root hook special ;\r
\r
-: unix-time>timestamp ( n -- timestamp )\r
- >r unix-1970 r> seconds time+ ;\r
-\r
: file-http-date ( filename -- string )\r
- file-modified unix-time>timestamp timestamp>http-string ;\r
+ file-info file-info-modified timestamp>http-string ;\r
\r
: last-modified-matches? ( filename -- ? )\r
file-http-date dup [\r
[\r
<content>\r
swap\r
- [ file-length "content-length" set-header ]\r
+ [ file-info file-info-size "content-length" set-header ]\r
[ file-http-date "last-modified" set-header ]\r
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
tri\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 ;
--- /dev/null
+USING: io.encodings.string io.encodings.ascii tools.test strings arrays ;
+IN: io.encodings.ascii.tests
+
+[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
+[ { 128 } >string ascii encode ] must-fail
+[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
+
+[ "bar" ] [ "bar" ascii decode ] unit-test
+[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
IN: io.encodings.ascii
-: encode-check<= ( string stream max -- )
+: encode-check< ( string stream max -- )
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
+: push-if< ( sbuf character max -- )
+ over <= [ drop HEX: fffd ] when swap push ;
+
TUPLE: ascii ;
M: ascii stream-write-encoded ( string stream encoding -- )
- drop 128 encode-check<= ;
+ drop 128 encode-check< ;
M: ascii decode-step
- drop dup 128 >= [ decode-error ] [ swap push ] if ;
+ drop 128 push-if< ;
--- /dev/null
+USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
+IN: io.encodings.latin1.tests
+
+[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
+[ { 256 } >string latin1 encode ] must-fail
+[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
+
+[ "bar" ] [ "bar" latin1 decode ] unit-test
+[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
TUPLE: latin1 ;
M: latin1 stream-write-encoded
- drop 256 encode-check<= ;
+ drop 256 encode-check< ;
M: latin1 decode-step
drop swap push ;
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.nonblocking io.unix.backend io.files io
-unix unix.stat unix.time kernel math continuations math.bitfields
-byte-arrays alien combinators combinators.cleave calendar
-io.encodings.binary ;
+unix unix.stat unix.time kernel math continuations
+math.bitfields byte-arrays alien combinators combinators.cleave
+calendar io.encodings.binary ;
IN: io.unix.files
M: unix-io cwd
- MAXPATHLEN dup <byte-array> swap
- getcwd [ (io-error) ] unless* ;
+ MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
+ [ (io-error) ] unless* ;
M: unix-io cd
chdir io-error ;
] with-disposal ;
M: unix-io copy-file ( from to -- )
- [ (copy-file) ] 2keep swap file-permissions chmod io-error ;
+ [ (copy-file) ]
+ [ swap file-info file-info-permissions chmod io-error ]
+ 2bi ;
: stat>type ( stat -- type )
stat-st_mode {
{ [ t ] [ +unknown+ ] }
} cond nip ;
-M: unix-io file-info ( path -- info )
- stat* {
+: stat>file-info ( stat -- info )
+ {
[ stat>type ]
[ stat-st_size ]
[ stat-st_mode ]
} cleave
\ file-info construct-boa ;
+M: unix-io file-info ( path -- info )
+ stat* stat>file-info ;
+
M: unix-io link-info ( path -- info )
- lstat* {
- [ stat>type ]
- [ stat-st_size ]
- [ stat-st_mode ]
- [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
- } cleave
- \ file-info construct-boa ;
+ lstat* stat>file-info ;
IN: io.unix.freebsd
-USING: io.unix.bsd io.backend core-foundation.fsevents ;
+USING: io.unix.bsd io.backend ;
TUPLE: freebsd-io ;
"io.unix." os append require
-"vocabs.monitor" require
+"tools.vocabs.monitor" require
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
-sequences combinators.lib namespaces words symbols ;
+sequences namespaces words symbols ;
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+ ;
-: expand-constants ( word/obj -- obj'/obj )
- dup word? [ execute ] when ;
+: win32-file-attribute ( n attr symbol -- n )
+ >r dupd mask? [ r> , ] [ r> drop ] if ;
-: get-flags ( n seq -- seq' )
+: win32-file-attributes ( n -- seq )
[
- [
- first2 expand-constants
- [ swapd mask? [ , ] [ drop ] if ] 2curry
- ] map call-with
+ FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
+ FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
+ FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
+ FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
+ FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
+ FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
+ FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
+ FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
+ FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
+ FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
+ FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
+ FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
+ FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
+ drop
] { } make ;
-: win32-file-attributes ( n -- seq )
- {
- { +read-only+ FILE_ATTRIBUTE_READONLY }
- { +hidden+ FILE_ATTRIBUTE_HIDDEN }
- { +system+ FILE_ATTRIBUTE_SYSTEM }
- { +directory+ FILE_ATTRIBUTE_DIRECTORY }
- { +archive+ FILE_ATTRIBUTE_ARCHIVE }
- { +device+ FILE_ATTRIBUTE_DEVICE }
- { +normal+ FILE_ATTRIBUTE_NORMAL }
- { +temporary+ FILE_ATTRIBUTE_TEMPORARY }
- { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
- { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
- { +compressed+ FILE_ATTRIBUTE_COMPRESSED }
- { +offline+ FILE_ATTRIBUTE_OFFLINE }
- { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
- { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
- } get-flags ;
-
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
-io.backend new-slots accessors ;
+io.backend new-slots accessors concurrency.flags ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
+SYMBOL: wait-flag
+
: wait-loop ( -- )
processes get dup assoc-empty?
- [ drop f sleep-until ]
+ [ drop wait-flag get-global lower-flag ]
[ wait-for-processes [ 100 sleep ] when ] if ;
-SYMBOL: wait-thread
-
: start-wait-thread ( -- )
- [ wait-loop t ] "Process wait" spawn-server
- wait-thread set-global ;
+ <flag> wait-flag set-global
+ [ wait-loop t ] "Process wait" spawn-server drop ;
M: windows-io register-process
- drop wait-thread get-global interrupt ;
+ drop wait-flag get-global raise-flag ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook
T{ windows-nt-io } set-io-backend
-"vocabs.monitor" require
+"tools.vocabs.monitor" require
] when drop ;
: open-append ( path -- handle length )
- dup file-length 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 ;
USE: vocabs.loader
jamshred-gadget H{
- { T{ key-down f f "r" } [ jamshred-restart refresh-all ] }
+ { T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
{ T{ motion } [ handle-mouse-motion ] }
} set-gestures
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
arrays macros splitting combinators prettyprint.backend
definitions prettyprint hashtables combinators.lib
prettyprint.sections sequences.private effects generic
-compiler.units ;
+compiler.units combinators.cleave ;
IN: locals
! Inspired by
if ;
: (point-free) ( quot args -- newquot )
- { [ load-locals ] [ point-free-body ] [ point-free-end ] }
- map-call-with2 concat >quotation ;
+ [ load-locals ] [ point-free-body ] [ point-free-end ]
+ 2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
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
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions
-math.vectors ;
+math.vectors combinators.cleave ;
IN: math.matrices
! Matrices
: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
-: cross-i ( vec1 vec2 -- i )
- over third over second * >r
- swap second swap third * r> - ;
+<PRIVATE
-: cross-j ( vec1 vec2 -- j )
- over first over third * >r
- swap third swap first * r> - ;
+: x first ; inline
+: y second ; inline
+: z third ; inline
-: cross-k ( vec1 vec2 -- k )
- over first over second * >r
- swap second swap first * r> - ;
+: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
+: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
+: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
-: cross ( vec1 vec2 -- vec3 )
- [ cross-i ] 2keep [ cross-j ] 2keep cross-k 3array ;
+PRIVATE>
+
+: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
: proj ( v u -- w )
- [ [ v. ] keep norm-sq / ] keep n*v ;
+ [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
: (gram-schmidt) ( v seq -- newseq )
[ dupd proj v- ] each ;
--- /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
+ ]
+ ] ;
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
- opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
+ opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render combinators.cleave ;
IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_MODELVIEW glMatrixMode
glLoadIdentity
- { [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
- [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
- [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ;
+ [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
+ [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
+ [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
+ tri ;
: reset-last-drag-rel ( -- )
- { 0 0 } last-drag-loc set ;
+ { 0 0 } last-drag-loc set-global ;
: last-drag-rel ( -- rel )
- drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
+ drag-loc [ last-drag-loc get v- ] keep last-drag-loc set-global ;
: drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
--- /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" } ;
+
+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 } } } } } ;
\ No newline at end of file
{ $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 -- )
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien libc opengl math sequences combinators.lib
-macros arrays ;
+macros arrays combinators.cleave ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
: (make-with-gl-program) ( uniforms quot -- q )
[
\ dup ,
- [ swap (with-gl-program-uniforms) , \ call-with , % ]
+ [ swap (with-gl-program-uniforms) , \ cleave , % ]
[ ] make ,
\ (with-gl-program) ,
] [ ] make ;
IN: openssl.libcrypto
+<<
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "stdcall" ] }
+ { [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ 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" "stdcall" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
+ { [ unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
read [ zero? ] right-trim dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n )
- 1 read first
+ read1
[ >r 7 shift r> 7 clear-bit bitor ] keep
7 bit? [ (read-128-ber) ] when ;
+++ /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
[ { 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.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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax io strings ;
-IN: tools.browser
-
-ARTICLE: "vocab-index" "Vocabulary index"
-{ $tags }
-{ $authors }
-{ $describe-vocab "" } ;
-
-ARTICLE: "tools.browser" "Vocabulary browser"
-"Getting and setting vocabulary meta-data:"
-{ $subsection vocab-file-contents }
-{ $subsection set-vocab-file-contents }
-{ $subsection vocab-summary }
-{ $subsection set-vocab-summary }
-{ $subsection vocab-tags }
-{ $subsection set-vocab-tags }
-{ $subsection add-vocab-tags }
-"Global meta-data:"
-{ $subsection all-vocabs }
-{ $subsection all-vocabs-seq }
-{ $subsection all-tags }
-{ $subsection all-authors }
-"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
-{ $subsection reset-cache } ;
-
-HELP: vocab-file-contents
-{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
-{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
-
-HELP: set-vocab-file-contents
-{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
-{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
-
-HELP: vocab-summary
-{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
-{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
-
-HELP: set-vocab-summary
-{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
-{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
-
-HELP: vocab-tags
-{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
-{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
-
-HELP: set-vocab-tags
-{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
-{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
-
-HELP: all-vocabs
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
+++ /dev/null
-IN: tools.browser.tests
-USING: tools.browser tools.test help.markup ;
-
-[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces splitting sequences io.files kernel assocs
-words vocabs vocabs.loader definitions parser continuations
-inspector debugger io io.styles hashtables
-sorting prettyprint source-files arrays combinators strings
-system math.parser help.markup help.topics help.syntax
-help.stylesheet memoize io.encodings.utf8 ;
-IN: tools.browser
-
-MEMO: (vocab-file-contents) ( path -- lines )
- ?resource-path dup exists?
- [ utf8 file-lines ] [ drop f ] if ;
-
-: vocab-file-contents ( vocab name -- seq )
- vocab-path+ dup [ (vocab-file-contents) ] when ;
-
-: set-vocab-file-contents ( seq vocab name -- )
- dupd vocab-path+ [
- ?resource-path utf8 set-file-lines
- ] [
- "The " swap vocab-name
- " vocabulary was not loaded from the file system"
- 3append throw
- ] ?if ;
-
-: vocab-summary-path ( vocab -- string )
- vocab-dir "summary.txt" path+ ;
-
-: vocab-summary ( vocab -- summary )
- dup dup vocab-summary-path vocab-file-contents
- dup empty? [
- drop vocab-name " vocabulary" append
- ] [
- nip first
- ] if ;
-
-M: vocab summary
- [
- dup vocab-summary %
- " (" %
- vocab-words assoc-size #
- " words)" %
- ] "" make ;
-
-M: vocab-link summary vocab-summary ;
-
-: set-vocab-summary ( string vocab -- )
- >r 1array r>
- dup vocab-summary-path
- set-vocab-file-contents ;
-
-: vocab-tags-path ( vocab -- string )
- vocab-dir "tags.txt" path+ ;
-
-: vocab-tags ( vocab -- tags )
- dup vocab-tags-path vocab-file-contents ;
-
-: set-vocab-tags ( tags vocab -- )
- dup vocab-tags-path set-vocab-file-contents ;
-
-: add-vocab-tags ( tags vocab -- )
- [ vocab-tags append prune ] keep set-vocab-tags ;
-
-: vocab-authors-path ( vocab -- string )
- vocab-dir "authors.txt" path+ ;
-
-: vocab-authors ( vocab -- authors )
- dup vocab-authors-path vocab-file-contents ;
-
-: set-vocab-authors ( authors vocab -- )
- dup vocab-authors-path set-vocab-file-contents ;
-
-: subdirs ( dir -- dirs )
- directory [ second ] subset keys natural-sort ;
-
-: (all-child-vocabs) ( root name -- vocabs )
- [ vocab-dir path+ ?resource-path subdirs ] keep
- dup empty? [
- drop
- ] [
- swap [ "." swap 3append ] with map
- ] if ;
-
-: vocabs-in-dir ( root name -- )
- dupd (all-child-vocabs) [
- 2dup vocab-dir? [ 2dup swap >vocab-link , ] when
- vocabs-in-dir
- ] with each ;
-
-: all-vocabs ( -- assoc )
- vocab-roots get [
- dup [ "" vocabs-in-dir ] { } make
- ] { } map>assoc ;
-
-MEMO: all-vocabs-seq ( -- seq )
- all-vocabs values concat ;
-
-: dangerous? ( name -- ? )
- #! Hack
- {
- { [ "cpu." ?head ] [ t ] }
- { [ "io.unix" ?head ] [ t ] }
- { [ "io.windows" ?head ] [ t ] }
- { [ "ui.x11" ?head ] [ t ] }
- { [ "ui.windows" ?head ] [ t ] }
- { [ "ui.cocoa" ?head ] [ t ] }
- { [ "cocoa" ?head ] [ t ] }
- { [ "core-foundation" ?head ] [ t ] }
- { [ "vocabs.loader.test" ?head ] [ t ] }
- { [ "editors." ?head ] [ t ] }
- { [ ".windows" ?tail ] [ t ] }
- { [ ".unix" ?tail ] [ t ] }
- { [ "unix." ?head ] [ t ] }
- { [ ".linux" ?tail ] [ t ] }
- { [ ".bsd" ?tail ] [ t ] }
- { [ ".macosx" ?tail ] [ t ] }
- { [ "windows." ?head ] [ t ] }
- { [ "cocoa" ?head ] [ t ] }
- { [ ".test" ?tail ] [ t ] }
- { [ "raptor" ?head ] [ t ] }
- { [ dup "tools.deploy.app" = ] [ t ] }
- { [ t ] [ f ] }
- } cond nip ;
-
-: filter-dangerous ( seq -- seq' )
- [ vocab-name dangerous? not ] subset ;
-
-: try-everything ( -- failures )
- all-vocabs-seq
- filter-dangerous
- require-all ;
-
-: load-everything ( -- )
- try-everything load-failures. ;
-
-: unrooted-child-vocabs ( prefix -- seq )
- dup empty? [ CHAR: . add ] unless
- vocabs
- [ vocab-root not ] subset
- [
- vocab-name swap ?head CHAR: . rot member? not and
- ] with subset
- [ vocab ] map ;
-
-: all-child-vocabs ( prefix -- assoc )
- vocab-roots get [
- over dupd dupd (all-child-vocabs)
- swap [ >vocab-link ] curry map
- ] { } map>assoc
- f rot unrooted-child-vocabs 2array add ;
-
-: load-children ( prefix -- )
- all-child-vocabs values concat
- filter-dangerous
- require-all
- load-failures. ;
-
-: vocab-status-string ( vocab -- string )
- {
- { [ dup not ] [ drop "" ] }
- { [ dup vocab-main ] [ drop "[Runnable]" ] }
- { [ t ] [ drop "[Loaded]" ] }
- } cond ;
-
-: write-status ( vocab -- )
- vocab vocab-status-string write ;
-
-: vocab. ( vocab -- )
- [
- dup [ write-status ] with-cell
- dup [ ($link) ] with-cell
- [ vocab-summary write ] with-cell
- ] with-row ;
-
-: vocab-headings. ( -- )
- [
- [ "State" write ] with-cell
- [ "Vocabulary" write ] with-cell
- [ "Summary" write ] with-cell
- ] with-row ;
-
-: root-heading. ( root -- )
- [ "Children from " swap append ] [ "Children" ] if*
- $heading ;
-
-: vocabs. ( assoc -- )
- [
- dup empty? [
- 2drop
- ] [
- swap root-heading.
- standard-table-style [
- vocab-headings. [ vocab. ] each
- ] ($grid)
- ] if
- ] assoc-each ;
-
-: describe-summary ( vocab -- )
- vocab-summary [
- "Summary" $heading print-element
- ] when* ;
-
-TUPLE: vocab-tag name ;
-
-C: <vocab-tag> vocab-tag
-
-: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
-
-: describe-tags ( vocab -- )
- vocab-tags f like [
- "Tags" $heading tags.
- ] when* ;
-
-TUPLE: vocab-author name ;
-
-C: <vocab-author> vocab-author
-
-: authors. ( seq -- ) [ <vocab-author> ] map $links ;
-
-: describe-authors ( vocab -- )
- vocab-authors f like [
- "Authors" $heading authors.
- ] when* ;
-
-: describe-help ( vocab -- )
- vocab-help [
- "Documentation" $heading nl ($link)
- ] when* ;
-
-: describe-children ( vocab -- )
- vocab-name all-child-vocabs vocabs. ;
-
-: describe-files ( vocab -- )
- vocab-files [ <pathname> ] map [
- "Files" $heading
- [
- snippet-style get [
- code-style get [
- stack.
- ] with-nesting
- ] with-style
- ] ($block)
- ] when* ;
-
-: describe-words ( vocab -- )
- words dup empty? [
- "Words" $heading
- dup natural-sort $links
- ] unless drop ;
-
-: map>set ( seq quot -- )
- map concat prune natural-sort ; inline
-
-: vocab-xref ( vocab quot -- vocabs )
- >r dup vocab-name swap words r> map
- [ [ word? ] subset [ word-vocabulary ] map ] map>set
- remove [ ] subset [ vocab ] map ; inline
-
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
-
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
-
-: describe-uses ( vocab -- )
- vocab-uses dup empty? [
- "Uses" $heading
- dup $links
- ] unless drop ;
-
-: describe-usage ( vocab -- )
- vocab-usage dup empty? [
- "Used by" $heading
- dup $links
- ] unless drop ;
-
-: $describe-vocab ( element -- )
- first
- dup describe-children
- dup vocab-root over vocab-dir? [
- dup describe-summary
- dup describe-tags
- dup describe-authors
- dup describe-files
- ] when
- dup vocab [
- dup describe-help
- dup describe-words
- dup describe-uses
- dup describe-usage
- ] when drop ;
-
-: keyed-vocabs ( str quot -- seq )
- all-vocabs [
- swap >r
- [ >r 2dup r> swap call member? ] subset
- r> swap
- ] assoc-map 2nip ; inline
-
-: tagged ( tag -- assoc )
- [ vocab-tags ] keyed-vocabs ;
-
-: authored ( author -- assoc )
- [ vocab-authors ] keyed-vocabs ;
-
-: $tagged-vocabs ( element -- )
- first tagged vocabs. ;
-
-MEMO: all-tags ( -- seq )
- all-vocabs-seq [ vocab-tags ] map>set ;
-
-: $authored-vocabs ( element -- )
- first authored vocabs. ;
-
-MEMO: all-authors ( -- seq )
- all-vocabs-seq [ vocab-authors ] map>set ;
-
-: $tags ( element -- )
- drop "Tags" $heading all-tags tags. ;
-
-: $authors ( element -- )
- drop "Authors" $heading all-authors authors. ;
-
-M: vocab-spec article-title vocab-name " vocabulary" append ;
-
-M: vocab-spec article-name vocab-name ;
-
-M: vocab-spec article-content
- vocab-name \ $describe-vocab swap 2array ;
-
-M: vocab-spec article-parent drop "vocab-index" ;
-
-M: vocab-tag >link ;
-
-M: vocab-tag article-title
- vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
-
-M: vocab-tag article-name vocab-tag-name ;
-
-M: vocab-tag article-content
- \ $tagged-vocabs swap vocab-tag-name 2array ;
-
-M: vocab-tag article-parent drop "vocab-index" ;
-
-M: vocab-tag summary article-title ;
-
-M: vocab-author >link ;
-
-M: vocab-author article-title
- vocab-author-name "Vocabularies by " swap append ;
-
-M: vocab-author article-name vocab-author-name ;
-
-M: vocab-author article-content
- \ $authored-vocabs swap vocab-author-name 2array ;
-
-M: vocab-author article-parent drop "vocab-index" ;
-
-M: vocab-author summary article-title ;
-
-: reset-cache ( -- )
- \ (vocab-file-contents) reset-memoized
- \ all-vocabs-seq reset-memoized
- \ all-authors reset-memoized
- \ all-tags reset-memoized ;
: ?, [ , ] [ drop ] if ;
-: bootstrap-profile ( config -- profile )
+: bootstrap-profile ( -- profile )
[
- [
- "math" deploy-math? get ?,
- "compiler" deploy-compiler? get ?,
- "ui" deploy-ui? get ?,
- "io" native-io? ?,
- ] { } make
- ] bind ;
+ "math" deploy-math? get ?,
+ "compiler" deploy-compiler? get ?,
+ "ui" deploy-ui? get ?,
+ "io" native-io? ?,
+ ] { } make ;
-: staging-image-name ( profile -- name )
- "staging." swap bootstrap-profile "-" join ".image" 3append ;
+: staging-image-name ( -- name )
+ "staging."
+ bootstrap-profile strip-word-names? [ "strip" add ] when
+ "-" join ".image" 3append ;
: staging-command-line ( config -- flags )
[
- "-i=" my-boot-image-name append ,
+ [
+ "-i=" my-boot-image-name append ,
- "-output-image=" over staging-image-name append ,
+ "-output-image=" staging-image-name append ,
- "-include=" swap bootstrap-profile " " join append ,
+ "-include=" bootstrap-profile " " join append ,
- "-no-stack-traces" ,
+ strip-word-names? [ "-no-stack-traces" , ] when
- "-no-user-init" ,
- ] { } make ;
+ "-no-user-init" ,
+ ] { } make
+ ] bind ;
: 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 )
[
- "-i=" swap staging-image-name append ,
+ [
+ "-i=" staging-image-name append ,
- "-run=tools.deploy.shaker" ,
+ "-run=tools.deploy.shaker" ,
- "-deploy-vocab=" swap append ,
+ "-deploy-vocab=" swap append ,
- "-output-image=" swap append ,
+ "-output-image=" swap append ,
- "-no-stack-traces" ,
- ] { } make ;
+ strip-word-names? [ "-no-stack-traces" , ] when
+ ] { } make
+ ] bind ;
: 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
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader io.files io kernel sequences assocs
splitting parser prettyprint namespaces math vocabs
-hashtables tools.browser ;
+hashtables tools.vocabs ;
IN: tools.deploy.config
SYMBOL: deploy-name
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
-tools.deploy.backend math ;\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
- "hello.image" temp-file\r
- rot dup deploy-config make-deploy-image\r
+ >r vm\r
+ "test.image" temp-file\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-length 500000 <=\r
+ 500000 small-enough?\r
+] unit-test\r
+\r
+[ ] [ "sudoku" shake-and-bake ] unit-test\r
+\r
+[ t ] [\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-length 2000000 <=\r
+ 2000000 small-enough?\r
+] unit-test\r
+\r
+[ ] [ "bunny" shake-and-bake ] unit-test\r
+\r
+[ t ] [\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 2array try-process\r
+] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.2" shake-and-bake\r
+ vm "-i=" "test.image" temp-file append 2array try-process\r
] unit-test\r
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces continuations.private kernel.private init
-assocs kernel vocabs words sequences memory io system arrays
-continuations math definitions mirrors splitting parser classes
-inspector layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.streams.duplex io.files io.backend
-quotations words.private tools.deploy.config compiler.units ;
+USING: qualified io.streams.c init fry namespaces assocs kernel
+parser tools.deploy.config vocabs sequences words words.private
+memory kernel.private continuations io prettyprint
+vocabs.loader debugger system strings ;
+QUALIFIED: bootstrap.stage2
+QUALIFIED: classes
+QUALIFIED: compiler.errors.private
+QUALIFIED: compiler.units
+QUALIFIED: continuations
+QUALIFIED: definitions
+QUALIFIED: init
+QUALIFIED: inspector
+QUALIFIED: io.backend
+QUALIFIED: io.thread
+QUALIFIED: layouts
+QUALIFIED: libc.private
+QUALIFIED: libc.private
+QUALIFIED: listener
+QUALIFIED: prettyprint.config
+QUALIFIED: random.private
+QUALIFIED: source-files
+QUALIFIED: threads
+QUALIFIED: vocabs
IN: tools.deploy.shaker
: strip-init-hooks ( -- )
run-file
] when ;
-: strip-assoc ( retained-keys assoc -- newassoc )
- swap [ nip member? ] curry assoc-subset ;
-
: strip-word-names ( words -- )
"Stripping word names" show
[ f over set-word-name f swap set-word-vocabulary ] each ;
: strip-word-props ( retain-props words -- )
"Stripping word properties" show
[
- [ word-props strip-assoc f assoc-like ] keep
- set-word-props
+ [
+ word-props swap
+ '[ , nip member? ] assoc-subset
+ f assoc-like
+ ] keep set-word-props
] with each ;
: retained-props ( -- seq )
strip-word-names? [ dup strip-word-names ] when
2drop ;
-: strip-environment ( retain-globals -- )
+: strip-recompile-hook ( -- )
+ [ [ f ] { } map>assoc ]
+ compiler.units:recompile-hook
+ set-global ;
+
+: strip-vocab-globals ( except names -- words )
+ [ child-vocabs [ words ] map concat ] map concat seq-diff ;
+
+: stripped-globals ( -- seq )
+ [
+ random.private:mt ,
+
+ {
+ bootstrap.stage2:bootstrap-time
+ continuations:error
+ continuations:error-continuation
+ continuations:error-thread
+ continuations:restarts
+ error-hook
+ init:init-hooks
+ inspector:inspector-hook
+ io.thread:io-thread
+ libc.private:mallocs
+ source-files:source-files
+ stderr
+ stdio
+ } %
+
+ deploy-threads? [
+ threads:initial-thread ,
+ ] unless
+
+ strip-io? [ io.backend:io-backend , ] when
+
+ [
+ io.backend:io-backend
+ "default-buffer-size" "io.nonblocking" lookup ,
+ ] { "alarms" "io" "tools" } strip-vocab-globals %
+
+ strip-dictionary? [
+ { } { "cpu" } strip-vocab-globals %
+
+ {
+ vocabs:dictionary
+ lexer-factory
+ vocabs:load-vocab-hook
+ layouts:num-tags
+ layouts:num-types
+ layouts:tag-mask
+ layouts:tag-numbers
+ layouts:type-numbers
+ classes:typemap
+ vocab-roots
+ definitions:crossref
+ compiled-crossref
+ interactive-vocabs
+ word
+ compiler.units:recompile-hook
+ listener:listener-hook
+ lexer-factory
+ classes:update-map
+ classes:class<map
+ } %
+ ] when
+
+ strip-prettyprint? [
+ {
+ prettyprint.config:margin
+ prettyprint.config:string-limit
+ prettyprint.config:tab-size
+ } %
+ ] when
+
+ strip-debugger? [
+ {
+ compiler.errors.private:compiler-errors
+ continuations:thread-error-hook
+ } %
+ ] when
+
+ deploy-c-types? get [
+ "c-types" "alien.c-types" lookup ,
+ ] unless
+
+ deploy-ui? get [
+ "ui-error-hook" "ui.gadgets.worlds" lookup ,
+ ] when
+ ] { } make ;
+
+: strip-globals ( stripped-globals -- )
strip-globals? [
- "Stripping environment" show
- global strip-assoc 21 setenv
+ "Stripping globals" show
+ global swap
+ '[ drop , member? not ] assoc-subset
+ [ drop string? not ] assoc-subset ! strip CLI args
+ dup keys .
+ 21 setenv
] [ drop ] if ;
: finish-deploy ( final-image -- )
] [ ] make "Boot quotation: " write dup . flush
set-boot-quot ;
-: retained-globals ( -- seq )
- [
- builtins ,
- strip-io? [ io-backend , ] unless
-
- strip-dictionary? [
- {
- dictionary
- inspector-hook
- lexer-factory
- load-vocab-hook
- num-tags
- num-types
- tag-bits
- tag-mask
- tag-numbers
- typemap
- vocab-roots
- } %
- ] unless
-
- strip-prettyprint? [
- {
- tab-size
- margin
- } %
- ] unless
-
- deploy-c-types? get [
- "c-types" "alien.c-types" lookup ,
- ] when
-
- native-io? [
- "default-buffer-size" "io.nonblocking" lookup ,
- ] when
-
- deploy-ui? get [
- "ui" child-vocabs
- "cocoa" child-vocabs
- deploy-vocab get child-vocabs 3append
- global keys [ word? ] subset
- swap [ >r word-vocabulary r> member? ] curry
- subset %
- ] when
- ] { } make dup . ;
-
-: strip-recompile-hook ( -- )
- [ [ f ] { } map>assoc ] recompile-hook set-global ;
-
: strip ( -- )
strip-libc
strip-cocoa
strip-init-hooks
deploy-vocab get vocab-main set-boot-quot*
retained-props >r
- retained-globals strip-environment
+ stripped-globals strip-globals
r> strip-words ;
: (deploy) ( final-image vocab config -- )
--- /dev/null
+IN: tools.deploy.test.1\r
+USING: threads ;\r
+\r
+: deploy-test-1 1000 sleep ;\r
+\r
+MAIN: deploy-test-1\r
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-c-types? f }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
+ { deploy-threads? t }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-name "tools.deploy.test.1" }
+ { deploy-math? t }
+ { deploy-compiler? t }
+ { "stop-after-last-window?" t }
+ { deploy-ui? f }
+}
--- /dev/null
+IN: tools.deploy.test.2\r
+USING: calendar calendar.format ;\r
+\r
+: deploy-test-2 now (timestamp>string) ;\r
+\r
+MAIN: deploy-test-2\r
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-c-types? f }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
+ { deploy-threads? t }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-name "tools.deploy.test.2" }
+ { deploy-math? t }
+ { deploy-compiler? t }
+ { "stop-after-last-window?" t }
+ { deploy-ui? f }
+}
--- /dev/null
+IN: tools.deploy.test.3\r
+USING: io.encodings.ascii io.files kernel ;\r
+\r
+: deploy-test-3\r
+ "resource:extra/tools/deploy/test/3/3.factor"\r
+ ?resource-path ascii file-contents drop ;\r
+\r
+MAIN: deploy-test-3\r
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-reflection 1 }
+ { deploy-name "tools.deploy.test.3" }
+ { deploy-threads? t }
+ { deploy-word-props? f }
+ { "stop-after-last-window?" t }
+ { deploy-ui? f }
+ { deploy-io 3 }
+ { deploy-compiler? t }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+}
--- /dev/null
+IN: tools.disassembler.tests\r
+USING: math tuples prettyprint.backend tools.disassembler\r
+tools.test strings ;\r
+\r
+[ ] [ \ + disassemble ] unit-test\r
+[ ] [ { string pprint* } disassemble ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
-system math generator.fixup io.encodings.ascii accessors ;
+system math generator.fixup io.encodings.ascii accessors
+generic ;
IN: tools.disassembler
: in-file "gdb-in.txt" temp-file ;
[ number>string write bl ] each
] with-file-writer ;
+M: method-spec make-disassemble-cmd
+ first2 method make-disassemble-cmd ;
+
: run-gdb ( -- lines )
<process>
+closed+ >>stdin
vectors quotations words parser assocs combinators
continuations debugger io io.files vocabs tools.time
vocabs.loader source-files compiler.units inspector
-inference effects ;
+inference effects tools.vocabs ;
IN: tools.test
SYMBOL: failures
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax io strings ;
+IN: tools.vocabs.browser
+
+ARTICLE: "vocab-index" "Vocabulary index"
+{ $tags }
+{ $authors }
+{ $describe-vocab "" } ;
--- /dev/null
+IN: tools.vocabs.browser.tests
+USING: tools.vocabs.browser tools.test help.markup ;
+
+[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators vocabs vocabs.loader tools.vocabs io
+io.files io.styles help.markup help.stylesheet sequences assocs
+help.topics namespaces prettyprint words sorting definitions
+arrays inspector ;
+IN: tools.vocabs.browser
+
+: vocab-status-string ( vocab -- string )
+ {
+ { [ dup not ] [ drop "" ] }
+ { [ dup vocab-main ] [ drop "[Runnable]" ] }
+ { [ t ] [ drop "[Loaded]" ] }
+ } cond ;
+
+: write-status ( vocab -- )
+ vocab vocab-status-string write ;
+
+: vocab. ( vocab -- )
+ [
+ dup [ write-status ] with-cell
+ dup [ ($link) ] with-cell
+ [ vocab-summary write ] with-cell
+ ] with-row ;
+
+: vocab-headings. ( -- )
+ [
+ [ "State" write ] with-cell
+ [ "Vocabulary" write ] with-cell
+ [ "Summary" write ] with-cell
+ ] with-row ;
+
+: root-heading. ( root -- )
+ [ "Children from " swap append ] [ "Children" ] if*
+ $heading ;
+
+: vocabs. ( assoc -- )
+ [
+ dup empty? [
+ 2drop
+ ] [
+ swap root-heading.
+ standard-table-style [
+ vocab-headings. [ vocab. ] each
+ ] ($grid)
+ ] if
+ ] assoc-each ;
+
+: describe-summary ( vocab -- )
+ vocab-summary [
+ "Summary" $heading print-element
+ ] when* ;
+
+TUPLE: vocab-tag name ;
+
+INSTANCE: vocab-tag topic
+
+C: <vocab-tag> vocab-tag
+
+: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
+
+: describe-tags ( vocab -- )
+ vocab-tags f like [
+ "Tags" $heading tags.
+ ] when* ;
+
+TUPLE: vocab-author name ;
+
+INSTANCE: vocab-author topic
+
+C: <vocab-author> vocab-author
+
+: authors. ( seq -- ) [ <vocab-author> ] map $links ;
+
+: describe-authors ( vocab -- )
+ vocab-authors f like [
+ "Authors" $heading authors.
+ ] when* ;
+
+: describe-help ( vocab -- )
+ vocab-help [
+ "Documentation" $heading nl ($link)
+ ] when* ;
+
+: describe-children ( vocab -- )
+ vocab-name all-child-vocabs vocabs. ;
+
+: describe-files ( vocab -- )
+ vocab-files [ <pathname> ] map [
+ "Files" $heading
+ [
+ snippet-style get [
+ code-style get [
+ stack.
+ ] with-nesting
+ ] with-style
+ ] ($block)
+ ] when* ;
+
+: describe-words ( vocab -- )
+ words dup empty? [
+ "Words" $heading
+ dup natural-sort $links
+ ] unless drop ;
+
+: vocab-xref ( vocab quot -- vocabs )
+ >r dup vocab-name swap words r> map
+ [ [ word? ] subset [ word-vocabulary ] map ] map>set
+ remove [ ] subset [ vocab ] map ; inline
+
+: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
+
+: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
+
+: describe-uses ( vocab -- )
+ vocab-uses dup empty? [
+ "Uses" $heading
+ dup $links
+ ] unless drop ;
+
+: describe-usage ( vocab -- )
+ vocab-usage dup empty? [
+ "Used by" $heading
+ dup $links
+ ] unless drop ;
+
+: $describe-vocab ( element -- )
+ first
+ dup describe-children
+ dup vocab-root over vocab-dir? [
+ dup describe-summary
+ dup describe-tags
+ dup describe-authors
+ dup describe-files
+ ] when
+ dup vocab [
+ dup describe-help
+ dup describe-words
+ dup describe-uses
+ dup describe-usage
+ ] when drop ;
+
+: keyed-vocabs ( str quot -- seq )
+ all-vocabs [
+ swap >r
+ [ >r 2dup r> swap call member? ] subset
+ r> swap
+ ] assoc-map 2nip ; inline
+
+: tagged ( tag -- assoc )
+ [ vocab-tags ] keyed-vocabs ;
+
+: authored ( author -- assoc )
+ [ vocab-authors ] keyed-vocabs ;
+
+: $tagged-vocabs ( element -- )
+ first tagged vocabs. ;
+
+: $authored-vocabs ( element -- )
+ first authored vocabs. ;
+
+: $tags ( element -- )
+ drop "Tags" $heading all-tags tags. ;
+
+: $authors ( element -- )
+ drop "Authors" $heading all-authors authors. ;
+
+INSTANCE: vocab topic
+
+INSTANCE: vocab-link topic
+
+M: vocab-spec article-title vocab-name " vocabulary" append ;
+
+M: vocab-spec article-name vocab-name ;
+
+M: vocab-spec article-content
+ vocab-name \ $describe-vocab swap 2array ;
+
+M: vocab-spec article-parent drop "vocab-index" ;
+
+M: vocab-tag >link ;
+
+M: vocab-tag article-title
+ vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
+
+M: vocab-tag article-name vocab-tag-name ;
+
+M: vocab-tag article-content
+ \ $tagged-vocabs swap vocab-tag-name 2array ;
+
+M: vocab-tag article-parent drop "vocab-index" ;
+
+M: vocab-tag summary article-title ;
+
+M: vocab-author >link ;
+
+M: vocab-author article-title
+ vocab-author-name "Vocabularies by " swap append ;
+
+M: vocab-author article-name vocab-author-name ;
+
+M: vocab-author article-content
+ \ $authored-vocabs swap vocab-author-name 2array ;
+
+M: vocab-author article-parent drop "vocab-index" ;
+
+M: vocab-author summary article-title ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: threads io.files io.monitors init kernel\r
+vocabs.loader tools.vocabs namespaces continuations ;\r
+IN: tools.vocabs.monitor\r
+\r
+! Use file system change monitoring to flush the tags/authors\r
+! cache\r
+SYMBOL: vocab-monitor\r
+\r
+: monitor-thread ( -- )\r
+ vocab-monitor get-global\r
+ next-change 2drop\r
+ t sources-changed? set-global reset-cache ;\r
+\r
+: start-monitor-thread\r
+ #! Silently ignore errors during monitor creation since\r
+ #! monitors are not supported on all platforms.\r
+ [\r
+ "" resource-path t <monitor> vocab-monitor set-global\r
+ [ monitor-thread t ] "Vocabulary monitor" spawn-server drop\r
+ ] ignore-errors ;\r
+\r
+[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook\r
--- /dev/null
+Use io.monitors to clear tools.browser authors/tags/summary cache
--- /dev/null
+USING: help.markup help.syntax strings ;\r
+IN: tools.vocabs\r
+\r
+ARTICLE: "tools.vocabs" "Vocabulary tools"\r
+"Reloading source files changed on disk:"\r
+{ $subsection refresh }\r
+{ $subsection refresh-all }\r
+"Vocabulary summaries:"\r
+{ $subsection vocab-summary }\r
+{ $subsection set-vocab-summary }\r
+"Vocabulary tags:"\r
+{ $subsection vocab-tags }\r
+{ $subsection set-vocab-tags }\r
+{ $subsection add-vocab-tags }\r
+"Getting and setting vocabulary meta-data:"\r
+{ $subsection vocab-file-contents }\r
+{ $subsection set-vocab-file-contents }\r
+"Global meta-data:"\r
+{ $subsection all-vocabs }\r
+{ $subsection all-vocabs-seq }\r
+{ $subsection all-tags }\r
+{ $subsection all-authors }\r
+"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"\r
+{ $subsection reset-cache } ;\r
+\r
+ABOUT: "tools.vocabs"\r
+\r
+HELP: vocab-files\r
+{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }\r
+{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;\r
+\r
+HELP: vocab-tests\r
+{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }\r
+{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;\r
+\r
+HELP: source-modified?\r
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }\r
+{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ;\r
+\r
+HELP: refresh\r
+{ $values { "prefix" string } }\r
+{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;\r
+\r
+HELP: refresh-all\r
+{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;\r
+\r
+{ refresh refresh-all } related-words\r
+\r
+HELP: vocab-file-contents\r
+{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }\r
+{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;\r
+\r
+HELP: set-vocab-file-contents\r
+{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }\r
+{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;\r
+\r
+HELP: vocab-summary\r
+{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }\r
+{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;\r
+\r
+HELP: set-vocab-summary\r
+{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }\r
+{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;\r
+\r
+HELP: vocab-tags\r
+{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }\r
+{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;\r
+\r
+HELP: set-vocab-tags\r
+{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }\r
+{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;\r
+\r
+HELP: all-vocabs\r
+{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
+{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs\r
+sequences namespaces math.parser arrays hashtables assocs\r
+memoize inspector sorting splitting combinators source-files\r
+io debugger continuations compiler.errors init io.crc32 ;\r
+IN: tools.vocabs\r
+\r
+: vocab-tests-file, ( vocab -- )\r
+ dup "-tests.factor" vocab-dir+ vocab-path+\r
+ dup resource-exists? [ , ] [ drop ] if ;\r
+\r
+: vocab-tests-dir, ( vocab -- )\r
+ dup vocab-dir "tests" path+ vocab-path+\r
+ dup resource-exists? [\r
+ dup ?resource-path directory keys\r
+ [ ".factor" tail? ] subset\r
+ [ path+ , ] with each\r
+ ] [ drop ] if ;\r
+\r
+: vocab-tests ( vocab -- tests )\r
+ dup vocab-root [\r
+ [\r
+ f >vocab-link dup\r
+ vocab-tests-file,\r
+ vocab-tests-dir,\r
+ ] { } make\r
+ ] [ drop f ] if ;\r
+\r
+: vocab-files ( vocab -- seq )\r
+ f >vocab-link [\r
+ dup vocab-source-path [ , ] when*\r
+ dup vocab-docs-path [ , ] when*\r
+ vocab-tests %\r
+ ] { } make ;\r
+\r
+: source-modified? ( path -- ? )\r
+ dup source-files get at [\r
+ dup source-file-path ?resource-path utf8 file-lines lines-crc32\r
+ swap source-file-checksum = not\r
+ ] [\r
+ resource-exists?\r
+ ] ?if ;\r
+\r
+: modified ( seq quot -- seq )\r
+ [ dup ] swap compose { } map>assoc\r
+ [ nip ] assoc-subset\r
+ [ nip source-modified? ] assoc-subset keys ; inline\r
+\r
+: modified-sources ( vocabs -- seq )\r
+ [ vocab-source-path ] modified ;\r
+\r
+: modified-docs ( vocabs -- seq )\r
+ [ vocab-docs-path ] modified ;\r
+\r
+: update-roots ( vocabs -- )\r
+ [ dup find-vocab-root swap vocab set-vocab-root ] each ;\r
+\r
+: to-refresh ( prefix -- modified-sources modified-docs )\r
+ child-vocabs\r
+ dup update-roots\r
+ dup modified-sources swap modified-docs ;\r
+\r
+: vocab-heading. ( vocab -- )\r
+ nl\r
+ "==== " write\r
+ dup vocab-name swap vocab write-object ":" print\r
+ nl ;\r
+\r
+: load-error. ( triple -- )\r
+ dup first vocab-heading.\r
+ dup second print-error\r
+ drop ;\r
+\r
+: load-failures. ( failures -- )\r
+ [ load-error. nl ] each ;\r
+\r
+SYMBOL: failures\r
+\r
+: require-all ( vocabs -- failures )\r
+ [\r
+ V{ } clone blacklist set\r
+ V{ } clone failures set\r
+ [\r
+ [ require ]\r
+ [ swap vocab-name failures get set-at ]\r
+ recover\r
+ ] each\r
+ failures get\r
+ ] with-compiler-errors ;\r
+\r
+: do-refresh ( modified-sources modified-docs -- )\r
+ 2dup\r
+ [ f swap set-vocab-docs-loaded? ] each\r
+ [ f swap set-vocab-source-loaded? ] each\r
+ append prune require-all load-failures. ;\r
+\r
+: refresh ( prefix -- ) to-refresh do-refresh ;\r
+\r
+SYMBOL: sources-changed?\r
+\r
+[ t sources-changed? set-global ] "tools.vocabs" add-init-hook\r
+\r
+: refresh-all ( -- )\r
+ "" refresh f sources-changed? set-global ;\r
+\r
+MEMO: (vocab-file-contents) ( path -- lines )\r
+ ?resource-path dup exists?\r
+ [ utf8 file-lines ] [ drop f ] if ;\r
+\r
+: vocab-file-contents ( vocab name -- seq )\r
+ vocab-path+ dup [ (vocab-file-contents) ] when ;\r
+\r
+: set-vocab-file-contents ( seq vocab name -- )\r
+ dupd vocab-path+ [\r
+ ?resource-path utf8 set-file-lines\r
+ ] [\r
+ "The " swap vocab-name\r
+ " vocabulary was not loaded from the file system"\r
+ 3append throw\r
+ ] ?if ;\r
+\r
+: vocab-summary-path ( vocab -- string )\r
+ vocab-dir "summary.txt" path+ ;\r
+\r
+: vocab-summary ( vocab -- summary )\r
+ dup dup vocab-summary-path vocab-file-contents\r
+ dup empty? [\r
+ drop vocab-name " vocabulary" append\r
+ ] [\r
+ nip first\r
+ ] if ;\r
+\r
+M: vocab summary\r
+ [\r
+ dup vocab-summary %\r
+ " (" %\r
+ vocab-words assoc-size #\r
+ " words)" %\r
+ ] "" make ;\r
+\r
+M: vocab-link summary vocab-summary ;\r
+\r
+: set-vocab-summary ( string vocab -- )\r
+ >r 1array r>\r
+ dup vocab-summary-path\r
+ set-vocab-file-contents ;\r
+\r
+: vocab-tags-path ( vocab -- string )\r
+ vocab-dir "tags.txt" path+ ;\r
+\r
+: vocab-tags ( vocab -- tags )\r
+ dup vocab-tags-path vocab-file-contents ;\r
+\r
+: set-vocab-tags ( tags vocab -- )\r
+ dup vocab-tags-path set-vocab-file-contents ;\r
+\r
+: add-vocab-tags ( tags vocab -- )\r
+ [ vocab-tags append prune ] keep set-vocab-tags ;\r
+\r
+: vocab-authors-path ( vocab -- string )\r
+ vocab-dir "authors.txt" path+ ;\r
+\r
+: vocab-authors ( vocab -- authors )\r
+ dup vocab-authors-path vocab-file-contents ;\r
+\r
+: set-vocab-authors ( authors vocab -- )\r
+ dup vocab-authors-path set-vocab-file-contents ;\r
+\r
+: subdirs ( dir -- dirs )\r
+ directory [ second ] subset keys natural-sort ;\r
+\r
+: (all-child-vocabs) ( root name -- vocabs )\r
+ [ vocab-dir path+ ?resource-path subdirs ] keep\r
+ dup empty? [\r
+ drop\r
+ ] [\r
+ swap [ "." swap 3append ] with map\r
+ ] if ;\r
+\r
+: vocabs-in-dir ( root name -- )\r
+ dupd (all-child-vocabs) [\r
+ 2dup vocab-dir? [ 2dup swap >vocab-link , ] when\r
+ vocabs-in-dir\r
+ ] with each ;\r
+\r
+: all-vocabs ( -- assoc )\r
+ vocab-roots get [\r
+ dup [ "" vocabs-in-dir ] { } make\r
+ ] { } map>assoc ;\r
+\r
+MEMO: all-vocabs-seq ( -- seq )\r
+ all-vocabs values concat ;\r
+\r
+: dangerous? ( name -- ? )\r
+ #! Hack\r
+ {\r
+ { [ "cpu." ?head ] [ t ] }\r
+ { [ "io.unix" ?head ] [ t ] }\r
+ { [ "io.windows" ?head ] [ t ] }\r
+ { [ "ui.x11" ?head ] [ t ] }\r
+ { [ "ui.windows" ?head ] [ t ] }\r
+ { [ "ui.cocoa" ?head ] [ t ] }\r
+ { [ "cocoa" ?head ] [ t ] }\r
+ { [ "core-foundation" ?head ] [ t ] }\r
+ { [ "vocabs.loader.test" ?head ] [ t ] }\r
+ { [ "editors." ?head ] [ t ] }\r
+ { [ ".windows" ?tail ] [ t ] }\r
+ { [ ".unix" ?tail ] [ t ] }\r
+ { [ "unix." ?head ] [ t ] }\r
+ { [ ".linux" ?tail ] [ t ] }\r
+ { [ ".bsd" ?tail ] [ t ] }\r
+ { [ ".macosx" ?tail ] [ t ] }\r
+ { [ "windows." ?head ] [ t ] }\r
+ { [ "cocoa" ?head ] [ t ] }\r
+ { [ ".test" ?tail ] [ t ] }\r
+ { [ "raptor" ?head ] [ t ] }\r
+ { [ dup "tools.deploy.app" = ] [ t ] }\r
+ { [ t ] [ f ] }\r
+ } cond nip ;\r
+\r
+: filter-dangerous ( seq -- seq' )\r
+ [ vocab-name dangerous? not ] subset ;\r
+\r
+: try-everything ( -- failures )\r
+ all-vocabs-seq\r
+ filter-dangerous\r
+ require-all ;\r
+\r
+: load-everything ( -- )\r
+ try-everything load-failures. ;\r
+\r
+: unrooted-child-vocabs ( prefix -- seq )\r
+ dup empty? [ CHAR: . add ] unless\r
+ vocabs\r
+ [ vocab-root not ] subset\r
+ [\r
+ vocab-name swap ?head CHAR: . rot member? not and\r
+ ] with subset\r
+ [ vocab ] map ;\r
+\r
+: all-child-vocabs ( prefix -- assoc )\r
+ vocab-roots get [\r
+ over dupd dupd (all-child-vocabs)\r
+ swap [ >vocab-link ] curry map\r
+ ] { } map>assoc\r
+ f rot unrooted-child-vocabs 2array add ;\r
+\r
+: all-child-vocabs-seq ( prefix -- assoc )\r
+ vocab-roots get swap [\r
+ dupd (all-child-vocabs)\r
+ [ vocab-dir? ] with subset\r
+ ] curry map concat ;\r
+\r
+: map>set ( seq quot -- )\r
+ map concat prune natural-sort ; inline\r
+\r
+MEMO: all-tags ( -- seq )\r
+ all-vocabs-seq [ vocab-tags ] map>set ;\r
+\r
+MEMO: all-authors ( -- seq )\r
+ all-vocabs-seq [ vocab-authors ] map>set ;\r
+\r
+: reset-cache ( -- )\r
+ \ (vocab-file-contents) reset-memoized\r
+ \ all-vocabs-seq reset-memoized\r
+ \ all-authors reset-memoized\r
+ \ all-tags reset-memoized ;\r
math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype
ui.gadgets.worlds ui.render ui.backend byte-arrays ;
+
IN: ui.freetype
TUPLE: freetype-renderer ;
: open-face ( font style -- face )
ttf-name ttf-path
dup malloc-file-contents
- swap file-length
+ swap file-info file-info-size
(open-face) ;
SYMBOL: dpi
USING: ui.gadgets ui.gestures help.markup help.syntax
-kernel classes strings opengl.gl ;
+kernel classes strings opengl.gl models ;
IN: ui.render
HELP: gadget
{ { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
- { { $link gadget-model } " - XXX" }
+ { { $link gadget-model } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
}
"Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
{ $notes
editors tools.profiler tools.test tools.time tools.walker
ui.commands ui.gadgets.editors ui.gestures ui.operations
ui.tools.deploy vocabs vocabs.loader words sequences
-tools.browser classes compiler.units ;
+tools.vocabs classes compiler.units ;
IN: ui.tools.operations
V{ } clone operations set-global
{ +secondary+ t }
} define-operation
-[
- class
- { link word vocab vocab-link vocab-tag vocab-author }
- memq?
-] \ com-follow H{
+[ topic? ] \ com-follow H{
{ +keyboard+ T{ key-down f { C+ } "H" } }
{ +primary+ t }
} define-operation
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
-tools.browser unicode.case calendar ui ;
+tools.vocabs unicode.case calendar ui ;
IN: ui.tools.search
TUPLE: live-search field list ;
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gestures words vocabs.loader
-tools.test ui.gadgets.buttons ui.gadgets.status-bar mirrors ;
+tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
+mirrors ;
IN: ui.tools
: <workspace-tabs> ( -- tabs )
key-modifiers swap message>button
[ <button-down> ] [ <button-up> ] if ;
-: mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ;
-
-: capture-mouse? ( umsg -- ? )
- mouse-buttons member? ;
-
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
nip >r mouse-event>gesture r> >lo-hi rot window ;
mouse-captured off ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
- >r >r dup capture-mouse? [ over set-capture ] when r> r>
- prepare-mouse send-button-down ;
+ >r >r
+ over set-capture
+ dup message>button drop nc-buttons get delete
+ r> r> prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when
IN: unix.types
+! FreeBSD 7 x86.32
+
+! Need to verify on 64-bit
+
TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: int __int32_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
TYPEDEF: __uint32_t blksize_t
-TYPEDEF: __uint32_t fflags_t
\ No newline at end of file
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: threads io.files io.monitors init kernel\r
-tools.browser namespaces continuations vocabs.loader ;\r
-IN: vocabs.monitor\r
-\r
-! Use file system change monitoring to flush the tags/authors\r
-! cache\r
-SYMBOL: vocab-monitor\r
-\r
-: monitor-thread ( -- )\r
- vocab-monitor get-global\r
- next-change 2drop\r
- t sources-changed? set-global reset-cache ;\r
-\r
-: start-monitor-thread\r
- #! Silently ignore errors during monitor creation since\r
- #! monitors are not supported on all platforms.\r
- [\r
- "" resource-path t <monitor> vocab-monitor set-global\r
- [ monitor-thread t ] "Vocabulary monitor" spawn-server drop\r
- ] ignore-errors ;\r
-\r
-[ start-monitor-thread ] "vocabs.monitor" add-init-hook\r
+++ /dev/null
-Use io.monitors to clear tools.browser authors/tags/summary cache
(" !.*$" . 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:"
-#!/bin/bash
+#!/bin/sh
-if [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
+if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
+then
+ echo freebsd-x86-32
+elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
then
echo macosx-ppc
elif [ `uname -s` = Darwin ]
echo winnt-x86-`./misc/wordsize`
else
echo help
-fi
\ No newline at end of file
+fi
--- /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
projects / factor.git / commitdiff