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

basis/db/sqlite/sqlite-tests.factor

@@ -127,3 +127,41 @@ hi "HELLO" {
         hi drop-table
     ] with-db
 ] unit-test
+
+TUPLE: show id ;
+TUPLE: user username data ;
+TUPLE: watch show user ;
+
+user "USER" {
+    { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
+    { "data" "DATA" TEXT }
+} define-persistent
+
+show "SHOW" {
+    { "id" "ID" +db-assigned-id+ }
+} define-persistent
+
+watch "WATCH" {
+    { "user" "USER" TEXT +not-null+
+        { +foreign-id+ user "USERNAME" } +user-assigned-id+ }
+    { "show" "SHOW" BIG-INTEGER +not-null+
+        { +foreign-id+ show "ID" } +user-assigned-id+ }
+} define-persistent
+
+[ T{ user { username "littledan" } { data "foo" } } ] [
+    test.db [
+        user create-table
+        show create-table
+        watch create-table
+        "littledan" "foo" user boa insert-tuple
+        "mark" "bar" user boa insert-tuple
+        show new insert-tuple
+        show new select-tuple
+        "littledan" f user boa select-tuple
+        watch boa insert-tuple
+        watch new select-tuple
+        user>> f user boa select-tuple
+    ] with-db
+] unit-test
+
+[ \ swap ensure-table ] must-fail

basis/endian/endian.factor

@@ -1,39 +1,39 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types namespaces io.binary fry
-kernel math ;
+kernel math grouping sequences ;
 IN: endian
 
 SINGLETONS: big-endian little-endian ;
 
-: native-endianness ( -- class )
+: compute-native-endianness ( -- class )
     1 <int> *char 0 = big-endian little-endian ? ;
 
 : >signed ( x n -- y )
     2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
 
-native-endianness \ native-endianness set-global
+SYMBOL: native-endianness
+native-endianness [ compute-native-endianness ] initialize
 
 SYMBOL: endianness
+endianness [ native-endianness get-global ] initialize
 
-\ native-endianness get-global endianness set-global
+HOOK: >native-endian native-endianness ( obj n -- bytes )
-
-HOOK: >native-endian native-endianness ( obj n -- str )
 
 M: big-endian >native-endian >be ;
 
 M: little-endian >native-endian >le ;
 
-HOOK: unsigned-native-endian> native-endianness ( obj -- str )
+HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
 
 M: big-endian unsigned-native-endian> be> ;
 
 M: little-endian unsigned-native-endian> le> ;
 
-: signed-native-endian> ( obj n -- str )
+: signed-native-endian> ( obj n -- n' )
     [ unsigned-native-endian> ] dip >signed ;
 
-HOOK: >endian endianness ( obj n -- str )
+HOOK: >endian endianness ( obj n -- bytes )
 
 M: big-endian >endian >be ;
 
@@ -45,13 +45,13 @@ M: big-endian endian> be> ;
 
 M: little-endian endian> le> ;
 
-HOOK: unsigned-endian> endianness ( obj -- str )
+HOOK: unsigned-endian> endianness ( obj -- bytes )
 
 M: big-endian unsigned-endian> be> ;
 
 M: little-endian unsigned-endian> le> ;
 
-: signed-endian> ( obj n -- str )
+: signed-endian> ( obj n -- bytes )
     [ unsigned-endian> ] dip >signed ;
 
 : with-endianness ( endian quot -- )
@@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ;
 
 : with-native-endian ( quot -- )
     \ native-endianness get-global swap with-endianness ; inline
+
+: seq>native-endianness ( seq n -- seq' )
+    native-endianness get-global dup endianness get = [
+        2drop
+    ] [
+        [ [ <sliced-groups> ] keep ] dip
+        little-endian = [
+            '[ be> _ >le ] map
+        ] [
+            '[ le> _ >be ] map
+        ] if concat
+    ] if ; inline

basis/http/server/static/static-docs.factor

@@ -38,7 +38,7 @@ $nl
 "If all you want to do is serve files from a directory, the following phrase does the trick:"
 { $code
     "USING: namespaces http.server http.server.static ;"
-    "/var/www/mysite.com/ <static> main-responder set"
+    "\"/var/www/mysite.com/\" <static> main-responder set"
     "8080 httpd"
 }
 { $subsection "http.server.static.extend" } ;

basis/http/server/static/static.factor

@@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ;
     [ file-responder get hook>> call ] [ 2drop <304> ] if ;
 
 : serving-path ( filename -- filename )
-    file-responder get root>> trim-tail-separators
+    [ file-responder get root>> trim-tail-separators "/" ] dip
-    "/"
+    "" or trim-head-separators 3append ;
-    rot "" or trim-head-separators 3append ;
 
 : serve-file ( filename -- response )
     dup mime-type

basis/images/bitmap/bitmap.factor

@@ -105,7 +105,6 @@ ERROR: unknown-component-order bitmap ;
     {
         [ [ width>> ] [ height>> ] bi 2array ]
         [ bitmap>component-order ]
-        [ drop little-endian ] ! XXX
         [ buffer>> ]
     } cleave bitmap-image boa ;
 

basis/images/images.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays ;
+math specialized-arrays.direct.uint byte-arrays
+specialized-arrays.direct.ushort ;
 IN: images
 
 SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 ;
 
-TUPLE: image dim component-order byte-order bitmap ;
+TUPLE: image dim component-order bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
@@ -28,6 +29,13 @@ GENERIC: load-image* ( path tuple -- image )
                 >byte-array add-dummy-alpha
             ] change-bitmap
         ] }
+        { R16G16B16 [
+            [
+                dup length 2 / <direct-ushort-array>
+                [ -8 shift ] map
+                >byte-array add-dummy-alpha
+            ] change-bitmap
+        ] }
         { BGRA [
             [
                 4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each

basis/images/tiff/tiff.factor

@@ -1,9 +1,11 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io io.encodings.binary io.files kernel
+USING: accessors arrays assocs byte-arrays classes combinators
-pack endian constructors sequences arrays math.order math.parser
+compression.lzw constructors endian fry grouping images io
-prettyprint classes io.binary assocs math math.bitwise byte-arrays
+io.binary io.encodings.ascii io.encodings.binary
-grouping images compression.lzw fry strings ;
+io.encodings.string io.encodings.utf8 io.files kernel math
+math.bitwise math.order math.parser pack prettyprint sequences
+strings ;
 IN: images.tiff
 
 TUPLE: tiff-image < image ;
@@ -249,13 +251,13 @@ ERROR: bad-small-ifd-type n ;
         { 283 [ first y-resolution ] }
         { 284 [ planar-configuration ] }
         { 296 [ lookup-resolution-unit resolution-unit ] }
-        { 305 [ >string software ] }
+        { 305 [ ascii decode software ] }
-        { 306 [ >string date-time ] }
+        { 306 [ ascii decode date-time ] }
         { 317 [ lookup-predictor predictor ] }
         { 330 [ sub-ifd ] }
         { 338 [ lookup-extra-samples extra-samples ] }
         { 339 [ lookup-sample-format sample-format ] }
-        { 700 [ >string xmp ] }
+        { 700 [ utf8 decode xmp ] }
         { 34377 [ photoshop ] }
         { 34665 [ exif-ifd ] }
         { 33723 [ iptc ] }
@@ -286,6 +288,18 @@ ERROR: unhandled-compression compression ;
 
 ERROR: unknown-component-order ifd ;
 
+: fix-bitmap-endianness ( ifd -- ifd )
+    dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
+    {
+        { { 32 32 32 32 } [ 4 seq>native-endianness ] }
+        { { 32 32 32 } [ 4 seq>native-endianness ] }
+        { { 16 16 16 16 } [ 2 seq>native-endianness ] }
+        { { 16 16 16 } [ 2 seq>native-endianness ] }
+        { { 8 8 8 8 } [ ] }
+        { { 8 8 8 } [ ] }
+        [ unknown-component-order ]
+    } case >>bitmap ;
+
 : ifd-component-order ( ifd -- byte-order )
     bits-per-sample find-tag {
         { { 32 32 32 } [ R32G32B32 ] }
@@ -299,7 +313,6 @@ ERROR: unknown-component-order ifd ;
     {
         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
         [ ifd-component-order ]
-        [ drop big-endian ] ! XXX
         [ bitmap>> ]
     } cleave tiff-image boa ;
 
@@ -314,7 +327,9 @@ ERROR: unknown-component-order ifd ;
             dup ifds>> [
                 process-ifd read-strips
                 uncompress-strips
-                strips>bitmap drop
+                strips>bitmap
+                fix-bitmap-endianness
+                drop
             ] each
         ] with-endianness
     ] with-file-reader ;

basis/xml/syntax/syntax.factor

@@ -174,6 +174,8 @@ PRIVATE>
 : [XML
     "XML]" [ string>chunk ] parse-def ; parsing
 
+<PRIVATE
+
 : remove-blanks ( seq -- newseq )
     [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
 
@@ -241,3 +243,5 @@ M: interpolated [undo-xml]
     [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
 
 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse
+
+PRIVATE>

basis/xml/tests/test.factor

@@ -3,7 +3,7 @@
 IN: xml.tests
 USING: kernel xml tools.test io namespaces make sequences
 xml.errors xml.entities.html parser strings xml.data io.files
-xml.traversal continuations assocs
+xml.traversal continuations assocs io.encodings.binary
 sequences.deep accessors io.streams.string ;
 
 ! This is insufficient
@@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ;
 \ string>xml must-infer
 
 SYMBOL: xml-file
-[ ] [ "resource:basis/xml/tests/test.xml"
+[ ] [
-    [ file>xml ] with-html-entities xml-file set ] unit-test
+    "resource:basis/xml/tests/test.xml"
+    [ file>xml ] with-html-entities xml-file set
+] unit-test
+[ t ] [
+    "resource:basis/xml/tests/test.xml" binary file-contents
+    [ bytes>xml ] with-html-entities xml-file get =
+] unit-test
 [ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
 [ f ] [ xml-file get prolog>> standalone>> ] unit-test
 [ "a" ] [ xml-file get space>> ] unit-test

basis/xml/xml-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data io strings ;
+USING: help.markup help.syntax xml.data io strings byte-arrays ;
 IN: xml
 
 HELP: string>xml
@@ -16,7 +16,11 @@ HELP: file>xml
 { $values { "filename" string } { "xml" xml } }
 { $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;
 
-{ string>xml read-xml file>xml } related-words
+HELP: bytes>xml
+{ $values { "byte-array" byte-array } { "xml" xml } }
+{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;
+
+{ string>xml read-xml file>xml bytes>xml } related-words
 
 HELP: read-xml-chunk
 { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
@@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML"
     { $subsection read-xml-chunk }
     { $subsection string>xml-chunk }
     { $subsection file>xml }
+    { $subsection bytes>xml }
     "To read a DTD:"
     { $subsection read-dtd }
     { $subsection file>dtd }

basis/xml/xml.factor

@@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files
 io.streams.string kernel namespaces sequences strings io.encodings.utf8
 xml.data xml.errors xml.elements ascii xml.entities
 xml.writer xml.state xml.autoencoding assocs xml.tokenize
-combinators.short-circuit xml.name splitting ;
+combinators.short-circuit xml.name splitting io.streams.byte-array ;
 IN: xml
 
 <PRIVATE
@@ -184,6 +184,9 @@ PRIVATE>
 : file>xml ( filename -- xml )
     binary <file-reader> read-xml ;
 
+: bytes>xml ( byte-array -- xml )
+    binary <byte-reader> read-xml ;
+
 : read-dtd ( stream -- dtd )
     [
         H{ } clone extra-entities set

extra/system-info/linux/linux.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: unix alien alien.c-types kernel math sequences strings
-io.backend.unix splitting ;
+io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
 IN: system-info.linux
 
 : (uname) ( buf -- int )
@@ -9,7 +9,7 @@ IN: system-info.linux
 
 : uname ( -- seq )
     65536 "char" <c-array> [ (uname) io-error ] keep
-    "\0" split harvest [ >string ] map
+    "\0" split harvest [ utf8 decode ] map
     6 "" pad-tail ;
 
 : sysname ( -- string ) uname first ;

extra/twitter/twitter.factor

@@ -1,12 +1,40 @@
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators hashtables http
 http.client json.reader kernel macros namespaces sequences
-urls.secure urls.encoding ;
+urls.secure fry ;
 IN: twitter
 
+! Configuration
 SYMBOLS: twitter-username twitter-password twitter-source ;
 
 twitter-source [ "factor" ] initialize
 
+: set-twitter-credentials ( username password -- )
+    [ twitter-username set ] [ twitter-password set ] bi* ;
+
+<PRIVATE
+
+! Utilities
+MACRO: keys-boa ( keys class -- )
+    [ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
+
+! Twitter requests
+
+: twitter-url ( string -- url )
+    "https://twitter.com/statuses/" ".json" surround ;
+
+: set-request-twitter-auth ( request -- request )
+    twitter-username get twitter-password get set-basic-auth ;
+
+: twitter-request ( request -- data )
+    set-request-twitter-auth
+    http-request nip ; inline
+
+PRIVATE>
+
+! Data types
+
 TUPLE: twitter-status
     created-at
     id
@@ -28,8 +56,7 @@ TUPLE: twitter-user
     protected?
     followers-count ;
 
-MACRO: keys-boa ( keys class -- )
+<PRIVATE
-    [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
 
 : <twitter-user> ( assoc -- user )
     {
@@ -64,37 +91,42 @@ MACRO: keys-boa ( keys class -- )
 : json>twitter-status ( json-object -- tweet )
     json> <twitter-status> ;
 
-: set-twitter-credentials ( username password -- )
+PRIVATE>
-    [ twitter-username set ] [ twitter-password set ] bi* ; 
 
-: set-request-twitter-auth ( request -- request )
+! Updates
-    twitter-username twitter-password [ get ] bi@ set-basic-auth ;
+<PRIVATE
 
 : update-post-data ( update -- assoc )
-    "status" associate
+    [
-    [ twitter-source get "source" ] dip [ set-at ] keep ;
+        "status" set
+        twitter-source get "source" set
+    ] H{ } make-assoc ;
 
 : (tweet) ( string -- json )
-    update-post-data "https://twitter.com/statuses/update.json" <post-request>
+    update-post-data "update" twitter-url
-        set-request-twitter-auth 
+    <post-request> twitter-request ;
-    http-request nip ;
+
+PRIVATE>
 
 : tweet* ( string -- tweet )
     (tweet) json>twitter-status ;
 
 : tweet ( string -- ) (tweet) drop ;
 
+! Timelines
+<PRIVATE
+
+: timeline ( url -- tweets )
+    twitter-url <get-request>
+    twitter-request json>twitter-statuses ;
+
+PRIVATE>
+
 : public-timeline ( -- tweets )
-    "https://twitter.com/statuses/public_timeline.json" <get-request>
+    "public_timeline" timeline ;
-        set-request-twitter-auth
-    http-request nip json>twitter-statuses ;
 
 : friends-timeline ( -- tweets )
-    "https://twitter.com/statuses/friends_timeline.json" <get-request>
+    "friends_timeline" timeline ;
-        set-request-twitter-auth
-    http-request nip json>twitter-statuses ;
 
 : user-timeline ( username -- tweets )
-    "https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
+    "user_timeline/" prepend timeline ;
-        set-request-twitter-auth
-    http-request nip json>twitter-statuses ;