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

2008-11-14 00:45:25 -06:00 · 2008-11-14 00:45:25 -06:00 · a6af48f812
parent dffbb120a3 867669f208
commit a6af48f812
21 changed files with 186 additions and 62 deletions
--- a/basis/io/files/listing/authors.txt
+++ b/basis/io/files/listing/authors.txt
--- a/basis/io/files/listing/listing-tests.factor
+++ b/basis/io/files/listing/listing-tests.factor
@ -0,0 +1,6 @@
+! 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. ] unit-test
--- a/basis/io/files/listing/listing.factor
+++ b/basis/io/files/listing/listing.factor
@ -0,0 +1,35 @@
+! 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
+
+: 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 )
+
+: directory. ( path -- )
+    [ (directory.) ] with-directory-files [ print ] each ;
+
+{
+    { [ os unix? ] [ "io.files.listing.unix" ] }
+    { [ os windows? ] [ "io.files.listing.windows" ] }
+} cond require
--- a/basis/io/files/listing/tags.txt
+++ b/basis/io/files/listing/tags.txt
@ -0,0 +1 @@
+unportable
--- a/basis/io/files/listing/unix/authors.txt
+++ b/basis/io/files/listing/unix/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/basis/io/files/listing/unix/tags.txt
+++ b/basis/io/files/listing/unix/tags.txt
@ -0,0 +1 @@
+unportable
--- a/basis/io/files/listing/unix/unix.factor
+++ b/basis/io/files/listing/unix/unix.factor
@ -0,0 +1,43 @@
+! 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 ;
+IN: io.files.listing.unix
+
+: 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 ;
+
+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 ;
--- a/basis/io/files/listing/windows/authors.txt
+++ b/basis/io/files/listing/windows/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/basis/io/files/listing/windows/tags.txt
+++ b/basis/io/files/listing/windows/tags.txt
@ -0,0 +1 @@
+unportable
--- a/basis/io/files/listing/windows/windows.factor
+++ b/basis/io/files/listing/windows/windows.factor
@ -0,0 +1,21 @@
+! 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 ;
+IN: io.files.listing.windows
+
+: 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 ;
--- a/basis/io/unix/files/files.factor
+++ b/basis/io/unix/files/files.factor
@ -172,6 +172,30 @@ M: unix (directory-entries) ( path -- seq )

 PRIVATE>

+: ch>file-type ( ch -- type )
+    {
+        { CHAR: b [ +block-device+ ] }
+        { CHAR: c [ +character-device+ ] }   
+        { CHAR: d [ +directory+ ] }
+        { CHAR: l [ +symbolic-link+ ] }
+        { CHAR: s [ +socket+ ] }
+        { CHAR: p [ +fifo+ ] }
+        { CHAR: - [ +regular-file+ ] }
+        [ drop +unknown+ ]
+    } case ;
+
+: file-type>ch ( type -- string )
+    {
+        { +block-device+ [ CHAR: b ] }
+        { +character-device+ [ CHAR: c ] }
+        { +directory+ [ CHAR: d ] }
+        { +symbolic-link+ [ CHAR: l ] }
+        { +socket+ [ CHAR: s ] }
+        { +fifo+ [ CHAR: p ] }
+        { +regular-file+ [ CHAR: - ] }
+        [ drop CHAR: - ]
+    } case ;
+
 : UID           OCT: 0004000 ; inline
 : GID           OCT: 0002000 ; inline
 : STICKY        OCT: 0001000 ; inline
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@ -149,35 +149,39 @@ SYMBOLS: +read-only+ +hidden+ +system+
 +sparse-file+ +reparse-point+ +compressed+ +offline+
 +not-content-indexed+ +encrypted+ ;

-: win32-file-attribute ( n attr symbol -- n )
-    >r dupd mask? r> swap [ , ] [ drop ] if ;
+TUPLE: windows-file-info < file-info attributes ;
+
+: win32-file-attribute ( n attr symbol -- )
+    rot mask? [ , ] [ drop ] if ;

 : win32-file-attributes ( n -- seq )
    [
-        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
+        {
+            [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
+            [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
+            [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
+            [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
+            [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
+            [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
+            [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
+            [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
+            [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
+            [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
+            [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
+            [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
+            [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
+            [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
+        } cleave
    ] { } make ;

 : win32-file-type ( n -- symbol )
    FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;

 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
-    [ \ file-info new ] dip
+    [ \ windows-file-info new ] dip
    {
        [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
+        [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
        [
            [ WIN32_FIND_DATA-nFileSizeLow ]
            [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
@ -196,9 +200,10 @@ SYMBOLS: +read-only+ +hidden+ +system+
    ] keep ;

 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
-    [ \ file-info new ] dip
+    [ \ windows-file-info new ] dip
    {
        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
+        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
        [
            [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
            [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
--- a/basis/tools/hexdump/authors.txt
+++ b/basis/tools/hexdump/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/basis/tools/hexdump/hexdump-docs.factor
+++ b/basis/tools/hexdump/hexdump-docs.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences strings ;
-IN: hexdump
+IN: tools.hexdump

 HELP: hexdump.
 { $values { "seq" sequence } }
@ -12,11 +12,11 @@ HELP: hexdump
 { $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time.  Lines are separated by a newline character." }
 { $see-also hexdump. } ;

-ARTICLE: "hexdump" "Hexdump"
-"The " { $vocab-link "hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
+ARTICLE: "tools.hexdump" "Hexdump"
+"The " { $vocab-link "tools.hexdump" } " vocabulary provides a traditional hexdump view of a sequence." $nl
 "Write hexdump to string:"
 { $subsection hexdump }
 "Write the hexdump to the output stream:"
 { $subsection hexdump. } ;

-ABOUT: "hexdump"
+ABOUT: "tools.hexdump"
--- a/basis/tools/hexdump/hexdump-tests.factor
+++ b/basis/tools/hexdump/hexdump-tests.factor
@ -1,5 +1,5 @@
-IN: hexdump.tests
-USING: hexdump kernel sequences tools.test ;
+USING: tools.hexdump kernel sequences tools.test ;
+IN: tools.hexdump.tests

 [ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test
 [ t ] [ "abcdefghijklmnopqrstuvwxyz" hexdump "Length: 26, 1ah\n00000000h: 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f 70 abcdefghijklmnop\n00000010h: 71 72 73 74 75 76 77 78 79 7a                   qrstuvwxyz\n" = ] unit-test
--- a/basis/tools/hexdump/hexdump.factor
+++ b/basis/tools/hexdump/hexdump.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays io io.streams.string kernel math math.parser
 namespaces sequences splitting grouping strings ascii ;
-IN: hexdump
+IN: tools.hexdump

 <PRIVATE

--- a/basis/tools/hexdump/summary.txt
+++ b/basis/tools/hexdump/summary.txt
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.singleton combinators
 continuations io io.encodings.binary io.encodings.utf8
-io.files io.sockets kernel io.streams.duplex math
+io.files io.sockets kernel io.streams.duplex math ls
 math.parser sequences splitting namespaces strings fry ftp ;
 IN: ftp.client

--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators io io.files kernel
-math.parser sequences strings ;
+math.parser sequences strings ls ;
 IN: ftp

 SINGLETON: active
@ -32,35 +32,7 @@ TUPLE: ftp-response n strings parsed ;
    over strings>> push ;

 : ftp-send ( string -- ) write "\r\n" write flush ;
-
 : ftp-ipv4 1 ; inline
 : ftp-ipv6 2 ; inline

-: ch>type ( ch -- type )
-    {
-        { CHAR: d [ +directory+ ] }
-        { CHAR: l [ +symbolic-link+ ] }
-        { CHAR: - [ +regular-file+ ] }
-        [ drop +unknown+ ]
-    } case ;
-
-: type>ch ( type -- string )
-    {   
-        { +directory+ [ CHAR: d ] }
-        { +symbolic-link+ [ CHAR: l ] }
-        { +regular-file+ [ CHAR: - ] }
-        [ drop CHAR: - ]
-    } case ;
-
-: file-info>string ( file-info name -- string )
-    [
-        [
-            [ type>> type>ch 1string ]
-            [ drop "rwx------" append ] bi
-        ]
-        [ size>> number>string 15 CHAR: \s pad-left ] bi
-    ] dip 3array " " join ;
-
-: directory-list ( -- seq )
-    "" directory-files
-    [ [ link-info ] keep file-info>string ] map ;
+: directory-list ( -- seq ) "" ls ;
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@ -6,12 +6,16 @@ io.encodings.utf8 io.files io.sockets kernel math.parser
 namespaces make sequences ftp io.unix.launcher.parser
 unicode.case splitting assocs classes io.servers.connection
 destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays sequences.lib
-hexdump ;
+continuations math concurrency.promises byte-arrays
+io.backend sequences.lib tools.hexdump ;
 IN: ftp.server

 SYMBOL: client

+: ftp-server-directory ( -- str )
+    \ ftp-server-directory get-global "resource:temp" or
+    normalize-path ;
+
 TUPLE: ftp-command raw tokenized ;

 : <ftp-command> ( -- obj )
@ -238,10 +242,16 @@ M: ftp-put service-command ( stream obj -- )
 ! : handle-LPRT ( obj -- ) tokenized>> "," split ;

 ERROR: not-a-directory ;
+ERROR: no-permissions ;

 : handle-CWD ( obj -- )
    [
-        tokenized>> second dup directory? [
+        tokenized>> second dup normalize-path
+        dup ftp-server-directory head? [
+            no-permissions
+        ] unless
+
+        file-info directory? [
            set-current-directory
            250 "Directory successully changed." server-response
        ] [
@ -256,6 +266,7 @@ ERROR: not-a-directory ;

 : handle-client-loop ( -- )
    <ftp-command> readln
+    USE: prettyprint    global [ dup . flush ] bind
    [ >>raw ]
    [ tokenize-command >>tokenized ] bi
    dup tokenized>> first >upper {
@ -313,7 +324,7 @@ TUPLE: ftp-server < threaded-server ;
 M: ftp-server handle-client* ( server -- )
    drop
    [
-        "" [
+        ftp-server-directory [
            host-name <ftp-client> client set
            send-banner handle-client-loop
        ] with-directory
@ -323,6 +334,7 @@ M: ftp-server handle-client* ( server -- )
    ftp-server new-threaded-server
        swap >>insecure
        "ftp.server" >>name
+        5 minutes >>timeout
        latin1 >>encoding ;

 : ftpd ( port -- )
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@ -1,6 +1,6 @@
 USING: combinators io io.files io.streams.string kernel math
 math.parser continuations namespaces pack prettyprint sequences
-strings system hexdump io.encodings.binary summary accessors
+strings system tools.hexdump io.encodings.binary summary accessors
 io.backend symbols byte-arrays ;
 IN: tar