IN: documents.tests
-USING: documents namespaces tools.test ;
+USING: documents namespaces tools.test make arrays kernel fry ;
! Tests
+[ { } ] [
+ [
+ { 1 10 }
+ { 1 10 } [ , "HI" , ] each-line
+ ] { } make
+] unit-test
+
+[ { 1 "HI" } ] [
+ [
+ { 1 10 }
+ { 1 11 } [ , "HI" , ] each-line
+ ] { } make
+] unit-test
+
+[ { 1 "HI" 2 "HI" } ] [
+ [
+ { 1 10 }
+ { 2 11 } [ , "HI" , ] each-line
+ ] { } make
+] unit-test
+
+[ { { t f 1 } { t f 2 } } ] [
+ [
+ { 1 10 } { 2 11 }
+ t f
+ '[ [ _ _ ] dip 3array , ] each-line
+ ] { } make
+] unit-test
+
[ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test
[ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
-math.order ;
+math.order math.ranges ;
IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
2over = [
3drop
] [
- [ [ first ] bi@ 1+ dup <slice> ] dip each
+ [ [ first ] bi@ [a,b] ] dip each
] if ; inline
: start/end-on-line ( from to line# -- n1 n2 )
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
- <" USING: command-line namespaces io io.files io.files.listing
+ <" USING: command-line namespaces io io.files tools.files
sequences kernel ;
command-line get [
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string strings ;
-IN: io.files.listing
-
-HELP: directory.
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
-
-ARTICLE: "io.files.listing" "Listing files"
-"The " { $vocab-link "io.files.listing" } " vocabulary implements directory file listing in a cross-platform way." $nl
-"Listing a directory:"
-{ $subsection directory. } ;
-
-ABOUT: "io.files.listing"
+++ /dev/null
-! Copyright (C) 2008 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test io.files.listing strings kernel ;
-IN: io.files.listing.tests
-
-\ directory. must-infer
-
-[ ] [ "" directory. ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators io io.files kernel
-math.parser sequences system vocabs.loader calendar ;
-
-IN: io.files.listing
-
-<PRIVATE
-
-: ls-time ( timestamp -- string )
- [ hour>> ] [ minute>> ] bi
- [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
-
-: ls-timestamp ( timestamp -- string )
- [ month>> month-abbreviation ]
- [ day>> number>string 2 CHAR: \s pad-left ]
- [
- dup year>> dup now year>> =
- [ drop ls-time ] [ nip number>string ] if
- 5 CHAR: \s pad-left
- ] tri 3array " " join ;
-
-: read>string ( ? -- string ) "r" "-" ? ; inline
-
-: write>string ( ? -- string ) "w" "-" ? ; inline
-
-: execute>string ( ? -- string ) "x" "-" ? ; inline
-
-HOOK: (directory.) os ( path -- lines )
-
-PRIVATE>
-
-: directory. ( path -- )
- [ (directory.) ] with-directory-files [ print ] each ;
-
-{
- { [ os unix? ] [ "io.files.listing.unix" ] }
- { [ os windows? ] [ "io.files.listing.windows" ] }
-} cond require
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel system unicode.case
-io.unix.files io.files.listing generalizations strings
-arrays sequences io.files math.parser unix.groups unix.users
-io.files.listing.private unix.stat math ;
-IN: io.files.listing.unix
-
-<PRIVATE
-
-: unix-execute>string ( str bools -- str' )
- swap {
- { { t t } [ >lower ] }
- { { t f } [ >upper ] }
- { { f t } [ drop "x" ] }
- [ 2drop "-" ]
- } case ;
-
-: permissions-string ( permissions -- str )
- {
- [ type>> file-type>ch 1string ]
- [ user-read? read>string ]
- [ user-write? write>string ]
- [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
- [ group-read? read>string ]
- [ group-write? write>string ]
- [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
- [ other-read? read>string ]
- [ other-write? write>string ]
- [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
- } cleave 10 narray concat ;
-
-: mode>symbol ( mode -- ch )
- S_IFMT bitand
- {
- { [ dup S_IFDIR = ] [ drop "/" ] }
- { [ dup S_IFIFO = ] [ drop "|" ] }
- { [ dup any-execute? ] [ drop "*" ] }
- { [ dup S_IFLNK = ] [ drop "@" ] }
- { [ dup S_IFWHT = ] [ drop "%" ] }
- { [ dup S_IFSOCK = ] [ drop "=" ] }
- { [ t ] [ drop "" ] }
- } cond ;
-
-M: unix (directory.) ( path -- lines )
- [ [
- [
- dup file-info
- {
- [ permissions-string ]
- [ nlink>> number>string 3 CHAR: \s pad-left ]
- ! [ uid>> ]
- ! [ gid>> ]
- [ size>> number>string 15 CHAR: \s pad-left ]
- [ modified>> ls-timestamp ]
- } cleave 4 narray swap suffix " " join
- ] map
- ] with-group-cache ] with-user-cache ;
-
-PRIVATE>
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar.format combinators io.files
-kernel math.parser sequences splitting system io.files.listing
-generalizations io.files.listing.private ;
-IN: io.files.listing.windows
-
-<PRIVATE
-
-: directory-or-size ( file-info -- str )
- dup directory? [
- drop "<DIR>" 20 CHAR: \s pad-right
- ] [
- size>> number>string 20 CHAR: \s pad-left
- ] if ;
-
-M: windows (directory.) ( entries -- lines )
- [
- dup file-info {
- [ modified>> timestamp>ymdhms ]
- [ directory-or-size ]
- } cleave 2 narray swap suffix " " join
- ] map ;
-
-PRIVATE>
block-size preferred-block-size
blocks blocks-free blocks-available
files files-free files-available
-name-max flags id ;
+name-max flags id id0 id1 ;
HOOK: new-file-system-info os ( -- file-system-info )
: file-system-calculations ( file-system-info -- file-system-info' )
{
- [ dup [ blocks-available>> ] [ block-size>> ] bi * >>free-space drop ]
+ [ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ]
+ [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
[ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
+ [ dup id>> 2 c-uint-array> first2 [ >>id0 ] [ >>id1 ] bi* drop ]
+ [ f >>id drop ]
[ ]
} cleave ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.unix.files kernel math system unix
-unix.statvfs.freebsd ;
+unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
+sequences grouping alien.strings io.encodings.utf8 ;
IN: io.unix.files.freebsd
+TUPLE: freebsd-file-system-info < unix-file-system-info
+version io-size owner syncreads syncwrites asyncreads asyncwrites ;
+
+M: freebsd new-file-system-info freebsd-file-system-info new ;
+
+M: freebsd file-system-statfs ( path -- byte-array )
+ "statfs" <c-object> tuck statfs io-error ;
+
+M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
+ {
+ [ statfs-f_version >>version ]
+ [ statfs-f_type >>type ]
+ [ statfs-f_flags >>flags ]
+ [ statfs-f_bsize >>block-size ]
+ [ statfs-f_iosize >>io-size ]
+ [ statfs-f_blocks >>blocks ]
+ [ statfs-f_bfree >>blocks-free ]
+ [ statfs-f_bavail >>blocks-available ]
+ [ statfs-f_files >>files ]
+ [ statfs-f_ffree >>files-free ]
+ [ statfs-f_syncwrites >>syncwrites ]
+ [ statfs-f_asyncwrites >>asyncwrites ]
+ [ statfs-f_syncreads >>syncreads ]
+ [ statfs-f_asyncreads >>asyncreads ]
+ [ statfs-f_namemax >>name-max ]
+ [ statfs-f_owner >>owner ]
+ [ statfs-f_fsid >>id ]
+ [ statfs-f_fstypename utf8 alien>string >>type ]
+ [ statfs-f_mntfromname utf8 alien>string >>device-name ]
+ [ statfs-f_mntonname utf8 alien>string >>mount-point ]
+ } cleave ;
+
M: freebsd file-system-statvfs ( path -- byte-array )
"statvfs" <c-object> tuck statvfs io-error ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
- [ statvfs-f_bavail >>blocks-available ]
- [ statvfs-f_bfree >>blocks-free ]
- [ statvfs-f_blocks >>blocks ]
[ statvfs-f_favail >>files-available ]
- [ statvfs-f_ffree >>files-free ]
- [ statvfs-f_files >>files ]
- [ statvfs-f_bsize >>block-size ]
- [ statvfs-f_flag >>flags ]
[ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_fsid >>id ]
- [ statvfs-f_namemax >>name-max ]
} cleave ;
+
+M: freebsd file-systems ( -- array )
+ f 0 0 getfsstat dup io-error
+ "statfs" <c-array> dup dup length 0 getfsstat io-error
+ "statfs" heap-size group
+ [ statfs-f_mntonname alien>native-string file-system-info ] map ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators csv
-io.encodings.utf8 io.files io.streams.string io.unix.files
-kernel namespaces sequences system unix unix.statfs.linux
-unix.statvfs.linux ;
+io.backend io.encodings.utf8 io.files io.streams.string
+io.unix.files kernel math.order namespaces sequences sorting
+system unix unix.statfs.linux unix.statvfs.linux ;
IN: io.unix.files.linux
TUPLE: linux-file-system-info < unix-file-system-info
-namelen spare ;
+namelen ;
M: linux new-file-system-info linux-file-system-info new ;
[ statfs64-f_fsid >>id ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>preferred-block-size ]
- [ statfs64-f_spare >>spare ]
+ ! [ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
[ type>> >>type ]
} cleave
] map ;
+
+ERROR: file-system-not-found ;
+
+M: linux file-system-info ( path -- )
+ normalize-path
+ [
+ [ new-file-system-info ] dip
+ [ file-system-statfs statfs>file-system-info ]
+ [ file-system-statvfs statvfs>file-system-info ] bi
+ file-system-calculations
+ ] keep
+
+ parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
+ [ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
+ {
+ [ file-system-name>> >>device-name drop ]
+ [ mount-point>> >>mount-point drop ]
+ [ type>> >>type ]
+ } 2cleave ;
io-size owner type-id filesystem-subtype ;
M: macosx file-systems ( -- array )
- f 0 0 getfsstat64 dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat64 io-error
- "statfs" heap-size group
- [ statfs64-f_mntonname alien>native-string file-system-info ] map ;
+ f <void*> dup 0 getmntinfo64 dup io-error
+ [ *void* ] dip
+ "statfs64" heap-size [ * memory>byte-array ] keep group
+ [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
M: macosx new-file-system-info macosx-file-system-info new ;
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.unix.files
-io.files unix.statvfs.netbsd ;
+io.files unix.statvfs.netbsd unix.getfsstat.netbsd
+grouping sequences ;
IN: io.unix.files.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
blocks-reserved files-reserved
-owner io-size
-sync-reads sync-writes
-async-reads async-writes
-idx mount-from spare ;
+owner io-size sync-reads sync-writes async-reads async-writes
+idx mount-from ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
[ statvfs-f_fsid >>id ]
[ statvfs-f_namemax >>name-max ]
[ statvfs-f_owner >>owner ]
- [ statvfs-f_spare >>spare ]
+ ! [ statvfs-f_spare >>spare ]
[ statvfs-f_fstypename alien>native-string >>type ]
[ statvfs-f_mntonname alien>native-string >>mount-point ]
[ statvfs-f_mntfromname alien>native-string >>device-name ]
} cleave ;
-FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
+M: netbsd file-systems ( -- array )
+ f 0 0 getvfsstat dup io-error
+ "statvfs" <c-array> dup dup length 0 getvfsstat io-error
+ "statvfs" heap-size group
+ [ statvfs-f_mntonname alien>native-string file-system-info ] map ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string strings ;
+IN: tools.files
+
+HELP: directory.
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Prints information about all files in a directory to the output stream in a cross-platform way similar to the Unix " { $snippet "ls" } " command." } ;
+
+ARTICLE: "tools.files" "Files tools"
+"The " { $vocab-link "tools.files" } " vocabulary implements directory files and file-systems listing in a cross-platform way." $nl
+"Listing a directory:"
+{ $subsection directory. } ;
+
+ABOUT: "tools.files"
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test tools.files strings kernel ;
+IN: tools.files.tests
+
+\ directory. must-infer
+
+[ ] [ "" directory. ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators io io.files kernel
+math.parser sequences system vocabs.loader calendar ;
+IN: tools.files
+
+<PRIVATE
+
+: ls-time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] bi
+ [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
+
+: ls-timestamp ( timestamp -- string )
+ [ month>> month-abbreviation ]
+ [ day>> number>string 2 CHAR: \s pad-left ]
+ [
+ dup year>> dup now year>> =
+ [ drop ls-time ] [ nip number>string ] if
+ 5 CHAR: \s pad-left
+ ] tri 3array " " join ;
+
+: read>string ( ? -- string ) "r" "-" ? ; inline
+
+: write>string ( ? -- string ) "w" "-" ? ; inline
+
+: execute>string ( ? -- string ) "x" "-" ? ; inline
+
+HOOK: (directory.) os ( path -- lines )
+
+PRIVATE>
+
+: directory. ( path -- )
+ [ (directory.) ] with-directory-files [ print ] each ;
+
+{
+ { [ os unix? ] [ "tools.files.unix" ] }
+ { [ os windows? ] [ "tools.files.windows" ] }
+} cond require
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel system unicode.case
+io.unix.files tools.files generalizations strings
+arrays sequences io.files math.parser unix.groups unix.users
+tools.files.private unix.stat math ;
+IN: tools.files.unix
+
+<PRIVATE
+
+: unix-execute>string ( str bools -- str' )
+ swap {
+ { { t t } [ >lower ] }
+ { { t f } [ >upper ] }
+ { { f t } [ drop "x" ] }
+ [ 2drop "-" ]
+ } case ;
+
+: permissions-string ( permissions -- str )
+ {
+ [ type>> file-type>ch 1string ]
+ [ user-read? read>string ]
+ [ user-write? write>string ]
+ [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ]
+ [ group-read? read>string ]
+ [ group-write? write>string ]
+ [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ]
+ [ other-read? read>string ]
+ [ other-write? write>string ]
+ [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
+ } cleave 10 narray concat ;
+
+: mode>symbol ( mode -- ch )
+ S_IFMT bitand
+ {
+ { [ dup S_IFDIR = ] [ drop "/" ] }
+ { [ dup S_IFIFO = ] [ drop "|" ] }
+ { [ dup any-execute? ] [ drop "*" ] }
+ { [ dup S_IFLNK = ] [ drop "@" ] }
+ { [ dup S_IFWHT = ] [ drop "%" ] }
+ { [ dup S_IFSOCK = ] [ drop "=" ] }
+ { [ t ] [ drop "" ] }
+ } cond ;
+
+M: unix (directory.) ( path -- lines )
+ [ [
+ [
+ dup file-info
+ {
+ [ permissions-string ]
+ [ nlink>> number>string 3 CHAR: \s pad-left ]
+ ! [ uid>> ]
+ ! [ gid>> ]
+ [ size>> number>string 15 CHAR: \s pad-left ]
+ [ modified>> ls-timestamp ]
+ } cleave 4 narray swap suffix " " join
+ ] map
+ ] with-group-cache ] with-user-cache ;
+
+PRIVATE>
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar.format combinators io.files
+kernel math.parser sequences splitting system tools.files
+generalizations tools.files.private ;
+IN: tools.files.windows
+
+<PRIVATE
+
+: directory-or-size ( file-info -- str )
+ dup directory? [
+ drop "<DIR>" 20 CHAR: \s pad-right
+ ] [
+ size>> number>string 20 CHAR: \s pad-left
+ ] if ;
+
+M: windows (directory.) ( entries -- lines )
+ [
+ dup file-info {
+ [ modified>> timestamp>ymdhms ]
+ [ directory-or-size ]
+ } cleave 2 narray swap suffix " " join
+ ] map ;
+
+PRIVATE>
editor get selection-color>> gl-color
editor get selection-start/end
over first [
- 2dup [
+ 2dup '[
+ [ _ _ ] dip
draw-selected-line
1 translate-lines
- ] with with each-line
+ ] each-line
] with-editor-translation ;
M: editor draw-gadget*
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax ;
+IN: unix.getfsstat.freebsd
+
+: MNT_WAIT 1 ; inline ! synchronously wait for I/O to complete
+: MNT_NOWAIT 2 ; inline ! start all I/O, but do not wait for it
+: MNT_LAZY 3 ; inline ! push data not written by filesystem syncer
+: MNT_SUSPEND 4 ; inline ! Suspend file system after sync
+
+FUNCTION: int getfsstat ( statfs* buf, int bufsize, int flags ) ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax ;
+IN: unix.getfsstat.netbsd
+
+: MNT_WAIT 1 ; inline ! synchronously wait for I/O to complete
+: MNT_NOWAIT 2 ; inline ! start all I/O, but do not wait for it
+: MNT_LAZY 3 ; inline ! push data not written by filesystem syncer
+
+FUNCTION: int getvfsstat ( statfs* buf, int bufsize, int flags ) ;
--- /dev/null
+unportable
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.statfs.freebsd
+
+: MFSNAMELEN 16 ; inline ! length of type name including null */
+: MNAMELEN 88 ; inline ! size of on/from name bufs
+: STATFS_VERSION HEX: 20030518 ; inline ! current version number
+
+C-STRUCT: statfs
+ { "uint32_t" "f_version" }
+ { "uint32_t" "f_type" }
+ { "uint64_t" "f_flags" }
+ { "uint64_t" "f_bsize" }
+ { "uint64_t" "f_iosize" }
+ { "uint64_t" "f_blocks" }
+ { "uint64_t" "f_bfree" }
+ { "int64_t" "f_bavail" }
+ { "uint64_t" "f_files" }
+ { "int64_t" "f_ffree" }
+ { "uint64_t" "f_syncwrites" }
+ { "uint64_t" "f_asyncwrites" }
+ { "uint64_t" "f_syncreads" }
+ { "uint64_t" "f_asyncreads" }
+ { { "uint64_t" 10 } "f_spare" }
+ { "uint32_t" "f_namemax" }
+ { "uid_t" "f_owner" }
+ { "fsid_t" "f_fsid" }
+ { { "char" 80 } "f_charspare" }
+ { { "char" MFSNAMELEN } "f_fstypename" }
+ { { "char" MNAMELEN } "f_mntfromname" }
+ { { "char" MNAMELEN } "f_mntonname" } ;
+
+FUNCTION: int statfs ( char* path, statvfs* buf ) ;
{ { "uint32_t" 8 } "f_reserved" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
+FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays
-io.backend sequences.lib tools.hexdump io.files.listing
+io.backend sequences.lib tools.hexdump tools.files
io.streams.string ;
IN: ftp.server
+++ /dev/null
-! Copyright (C) 2008 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: lexer parser splitting kernel quotations namespaces make
-sequences assocs sequences.lib xml.generator xml.utilities
-xml.data ;
-IN: xml.syntax
-
-: parsed-name ( accum -- accum )
- scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
-
-: run-combinator ( accum quot1 quot2 -- accum )
- >r [ ] like parsed r> [ parsed ] each ;
-
-: parse-tag-contents ( accum contained? -- accum )
- [ \ contained*, parsed ] [
- scan-word \ [ =
- [ POSTPONE: [ \ tag*, parsed ]
- [ "Expected [ missing" throw ] if
- ] if ;
-
-DEFER: >>
-
-: attributes-parsed ( accum quot -- accum )
- [ f parsed ] [
- >r \ >r parsed r> parsed
- [ H{ } make-assoc r> swap ] [ parsed ] each
- ] if-empty ;
-
-: <<
- parsed-name [
- \ >> parse-until >quotation
- attributes-parsed \ contained? get
- ] with-scope parse-tag-contents ; parsing
-
-: ==
- \ call parsed parsed-name \ set parsed ; parsing
-
-: //
- \ contained? on ; parsing
-
-: parse-special ( accum end-token word -- accum )
- >r parse-tokens " " join parsed r> parsed ;
-
-: <!-- "-->" \ comment, parse-special ; parsing
-
-: <! ">" \ directive, parse-special ; parsing
-
-: <? "?>" \ instruction, parse-special ; parsing
-
-: >xml-document ( seq -- xml )
- dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap
- [ tag? ] split-around <xml> ;
-
-DEFER: XML>
-
-: <XML
- \ XML> [ >quotation ] parse-literal
- { } parsed \ make parsed \ >xml-document parsed ; parsing
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: lexer parser splitting kernel quotations namespaces make
+sequences assocs sequences.lib xml.generator xml.utilities
+xml.data ;
+IN: xml.syntax
+
+: parsed-name ( accum -- accum )
+ scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
+
+: run-combinator ( accum quot1 quot2 -- accum )
+ >r [ ] like parsed r> [ parsed ] each ;
+
+: parse-tag-contents ( accum contained? -- accum )
+ [ \ contained*, parsed ] [
+ scan-word \ [ =
+ [ POSTPONE: [ \ tag*, parsed ]
+ [ "Expected [ missing" throw ] if
+ ] if ;
+
+DEFER: >>
+
+: attributes-parsed ( accum quot -- accum )
+ [ f parsed ] [
+ >r \ >r parsed r> parsed
+ [ H{ } make-assoc r> swap ] [ parsed ] each
+ ] if-empty ;
+
+: <<
+ parsed-name [
+ \ >> parse-until >quotation
+ attributes-parsed \ contained? get
+ ] with-scope parse-tag-contents ; parsing
+
+: ==
+ \ call parsed parsed-name \ set parsed ; parsing
+
+: //
+ \ contained? on ; parsing
+
+: parse-special ( accum end-token word -- accum )
+ >r parse-tokens " " join parsed r> parsed ;
+
+: <!-- "-->" \ comment, parse-special ; parsing
+
+: <! ">" \ directive, parse-special ; parsing
+
+: <? "?>" \ instruction, parse-special ; parsing
+
+: >xml-document ( seq -- xml )
+ dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap
+ [ tag? ] split-around <xml> ;
+
+DEFER: XML>
+
+: <XML
+ \ XML> [ >quotation ] parse-literal
+ { } parsed \ make parsed \ >xml-document parsed ; parsing
projects / factor.git / commitdiff