steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-03-01 13:46:58 -06:00
parent fea927b343 e5c567c739
commit d4f37e175f
13 changed files with 204 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
core/io/files/files-docs.factor
View File

@ -57,8 +57,8 @@ ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"The operations for moving and copying files come in three flavors:"
{ $list
{ "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
{ "A word named " { $snippet { $emphasis "operation" } "-to" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
{ "A word named " { $snippet { $emphasis "operation" } "s-to" } " which takes a sequence of source paths and destination directory." }
{ "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
{ "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
}
"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file."
$nl
@ -68,16 +68,16 @@ $nl
{ $subsection delete-tree }
"Moving files:"
{ $subsection move-file }
{ $subsection move-file-to }
{ $subsection move-files-to }
{ $subsection move-file-into }
{ $subsection move-files-into }
"Copying files:"
{ $subsection copy-file }
{ $subsection copy-file-to }
{ $subsection copy-files-to }
{ $subsection copy-file-into }
{ $subsection copy-files-into }
"Copying directory trees recursively:"
{ $subsection copy-tree }
{ $subsection copy-tree-to }
{ $subsection copy-trees-to }
{ $subsection copy-tree-into }
{ $subsection copy-trees-into }
"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
ARTICLE: "io.files" "Basic file operations"
@ -267,12 +267,12 @@ HELP: move-file
{ $description "Moves or renames a file." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-file-to
HELP: move-file-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Moves a file to another directory without renaming it." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
HELP: move-files-to
HELP: move-files-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Moves a set of files to another directory." }
{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
@ -283,12 +283,12 @@ HELP: copy-file
{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-file-to
HELP: copy-file-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a file to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
HELP: copy-files-to
HELP: copy-files-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of files to another directory." }
{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
@ -299,12 +299,12 @@ HELP: copy-tree
{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
{ $errors "Throws an error if the copy operation fails." } ;
HELP: copy-tree-to
HELP: copy-tree-into
{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
{ $description "Copies a directory tree to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ;
HELP: copy-trees-to
HELP: copy-trees-into
{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
{ $description "Copies a set of directory trees to another directory, recursively." }
{ $errors "Throws an error if the copy operation fails." } ;

22
core/io/files/files.factor
View File

@ -137,37 +137,37 @@ HOOK: delete-directory io-backend ( path -- )
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
: move-file-to ( from to -- )
: move-file-into ( from to -- )
to-directory move-file ;
: move-files-to ( files to -- )
[ move-file-to ] curry each ;
: move-files-into ( files to -- )
[ move-file-into ] curry each ;
! Copying files
HOOK: copy-file io-backend ( from to -- )
: copy-file-to ( from to -- )
: copy-file-into ( from to -- )
to-directory copy-file ;
: copy-files-to ( files to -- )
[ copy-file-to ] curry each ;
: copy-files-into ( files to -- )
[ copy-file-into ] curry each ;
DEFER: copy-tree-to
DEFER: copy-tree-into
: copy-tree ( from to -- )
over directory? [
>r dup directory swap r> [
>r swap first path+ r> copy-tree-to
>r swap first path+ r> copy-tree-into
] 2curry each
] [
copy-file
] if ;
: copy-tree-to ( from to -- )
: copy-tree-into ( from to -- )
to-directory copy-tree ;
: copy-trees-to ( files to -- )
[ copy-tree-to ] curry each ;
: copy-trees-into ( files to -- )
[ copy-tree-into ] curry each ;
! Special paths
: resource-path ( path -- newpath )

11
extra/bootstrap/image/upload/upload.factor
View File

@ -4,7 +4,12 @@ IN: bootstrap.image.upload
USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io namespaces io.launcher math ;
: destination "slava@factorcode.org:www/images/latest/" ;
SYMBOL: upload-images-destination
: destination ( -- dest )
upload-images-destination get
"slava@/var/www/factorcode.org/w/images/latest/"
or ;
: checksums "checksums.txt" temp-file ;
@ -23,6 +28,8 @@ bootstrap.image sequences io namespaces io.launcher math ;
] { } make try-process ;
: new-images ( -- )
make-images compute-checksums upload-images ;
"" resource-path
[ make-images compute-checksums upload-images ]
with-directory ;
MAIN: new-images

94
extra/builder/builder.factor
View File

@ -39,29 +39,27 @@ IN: builder
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
: make-clean ( -- desc ) { "make" "clean" } ;
: do-make-clean ( -- desc ) { "make" "clean" } try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
! : target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ;
: make-vm ( -- desc )
<process*>
{ "make" target } to-strings >>arguments
"../compile-log" >>stdout
+stdout+ >>stderr
{ "make" } >>arguments
"../compile-log" >>stdout
+stdout+ >>stderr
>desc ;
: do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
"../../factor/" my-boot-image-name append
"../" my-boot-image-name append
copy-file
"../../factor/" my-boot-image-name append
my-boot-image-name
copy-file ;
builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -77,6 +75,9 @@ IN: builder
20 minutes >>timeout
>desc ;
: do-bootstrap ( -- )
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
: builder-test-cmd ( -- cmd )
{ "./factor" "-run=builder.test" } to-strings ;
@ -89,6 +90,9 @@ IN: builder
45 minutes >>timeout
>desc ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
@ -101,52 +105,46 @@ SYMBOL: build-status
enter-build-dir
"report" [
"report"
[
"Build machine: " write host-name print
"CPU: " write cpu print
"OS: " write os print
"Build directory: " write cwd print nl
"Build machine: " write host-name print
"CPU: " write cpu print
"OS: " write os print
"Build directory: " write cwd print nl
git-clone [ "git clone failed" print ] run-or-bail
git-clone [ "git clone failed" print ] run-or-bail
"factor"
[
record-git-id
do-make-clean
do-make-vm
copy-image
do-bootstrap
do-builder-test
]
with-directory
"factor" cd
"test-log" delete-file
record-git-id
"Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
make-clean run-process drop
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail
"Benchmarks: " print "benchmarks" eval-file benchmarks.
copy-image
nl
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
show-benchmark-deltas
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail
"benchmarks" ".." copy-file-into
"../test-log" delete-file
"Boot time: " write "../boot-time" eval-file milli-seconds>time print
"Load time: " write "../load-time" eval-file milli-seconds>time print
"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
"Benchmarks: " print
"../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks.
nl
show-benchmark-deltas
"../benchmarks" "../../benchmarks" copy-file
".." cd
maybe-release
] with-file-writer
maybe-release
]
with-file-writer
build-status on ;

95
extra/builder/release/release.factor
View File

@ -1,12 +1,17 @@
USING: kernel namespaces sequences combinators io.files io.launcher
USING: kernel system namespaces sequences splitting combinators
io.files io.launcher
bake combinators.cleave builder.common builder.util ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path ) builds "/releases" append dup make-directory ;
: releases ( -- path )
builds "releases" path+
dup exists? not
[ dup make-directory ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -34,8 +39,6 @@ IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: system sequences splitting ;
: cpu- ( -- cpu ) cpu "." split "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -57,70 +60,46 @@ USING: system sequences splitting ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-file ( source destination -- )
swap { "mv" , , } bake run-process drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: linux-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "tar" "-cvzf" archive-name "factor" } to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: windows-release ( -- )
"factor" cd
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
{ "zip" "-r" archive-name "factor" } to-strings run-process drop
archive-name releases move-file ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: macosx-release ( -- )
"factor" cd
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
: macosx-archive-cmd ( -- cmd )
{ "hdiutil" "create"
"-srcfolder" "factor"
"-fs" "HFS+"
"-volname" "factor"
archive-name }
to-strings run-process drop
archive-name } ;
archive-name releases move-file ;
: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: archive-cmd ( -- cmd )
{
{ [ windows? ] [ windows-archive-cmd ] }
{ [ macosx? ] [ macosx-archive-cmd ] }
{ [ unix? ] [ unix-archive-cmd ] }
}
cond ;
: make-archive ( -- ) archive-cmd to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remove-common-files ( -- )
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
: release ( -- )
os
{
{ "linux" [ linux-release ] }
{ "winnt" [ windows-release ] }
{ "macosx" [ macosx-release ] }
}
case ;
"factor"
[
remove-factor-app
remove-common-files
]
with-directory
make-archive
archive-name releases move-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/calendar/unix/unix.factor
View File

@ -1,5 +1,7 @@
USING: alien alien.c-types arrays calendar.backend
kernel structs math unix namespaces ;
kernel structs math unix.time namespaces ;
IN: calendar.unix
TUPLE: unix-calendar ;

5
extra/io/files/temporary/backend/backend.factor Normal file
View File

@ -0,0 +1,5 @@
USING: io.backend ;
IN: io.files.temporary.backend
HOOK: (temporary-file) io-backend ( path -- stream path )
HOOK: temporary-path io-backend ( -- path )

32
extra/io/files/temporary/temporary.factor Normal file
View File

@ -0,0 +1,32 @@
USING: kernel math math.bitfields combinators.lib math.parser
random sequences sequences.lib continuations namespaces
io.files io.backend io.nonblocking io arrays
io.files.temporary.backend system combinators vocabs.loader ;
IN: io.files.temporary
: random-letter ( -- ch ) 26 random { CHAR: a CHAR: A } random + ;
: random-ch ( -- ch )
{ t f } random [ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string ) [ drop random-ch ] "" map-as ;
: <temporary-file> ( prefix suffix -- path duplex-stream )
temporary-path -rot
[ 10 random-name swap 3append path+ dup (temporary-file) ] 3curry
10 retry ;
: with-temporary-file ( quot -- path )
>r f f <temporary-file> r> with-stream ;
: temporary-directory ( -- path )
[ temporary-path 10 random-name path+ dup make-directory ] 10 retry ;
: with-temporary-directory ( quot -- )
>r temporary-directory r>
[ with-directory ] 2keep drop delete-tree ;
{
{ [ unix? ] [ "io.unix.files.temporary" ] }
{ [ windows? ] [ "io.windows.files.temporary" ] }
} cond require

4
extra/io/unix/files/files.factor
View File

@ -1,8 +1,8 @@
! 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 kernel math continuations math.bitfields byte-arrays
alien combinators combinators.cleave calendar ;
unix unix.stat unix.time kernel math continuations math.bitfields
byte-arrays alien combinators combinators.cleave calendar ;
IN: io.unix.files

10
extra/io/windows/files/temporary/temporary.factor Normal file
View File

@ -0,0 +1,10 @@
USING: io.files.temporary.backend io.nonblocking io.windows
kernel system windows.kernel32 ;
IN: io.windows.files.temporary
M: windows-io (temporary-file) ( path -- stream )
GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ;
M: windows-io temporary-path ( -- path )
"TEMP" os-env ;

5
extra/io/windows/files/unique/unique.factor
View File

@ -1,8 +1,9 @@
USING: kernel system io.files.unique.backend ;
USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking ;
IN: io.windows.files.unique
M: windows-io (make-unique-file) ( path -- stream )
GENERIC_WRITE CREATE_NEW 0 open-file 0 <writer> ;
GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ;
M: windows-io temporary-path ( -- path )
"TEMP" os-env ;

32
extra/unix/time/time.factor Normal file
View File

@ -0,0 +1,32 @@
USING: kernel alien.syntax alien.c-types math ;
IN: unix.time
TYPEDEF: uint time_t
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
{ "int" "min" } ! Minutes: 0-59
{ "int" "hour" } ! Hours since midnight: 0-23
{ "int" "mday" } ! Day of the month: 1-31
{ "int" "mon" } ! Months *since* january: 0-11
{ "int" "year" } ! Years since 1900
{ "int" "wday" } ! Days since Sunday (0-6)
{ "int" "yday" } ! Days since Jan. 1: 0-365
{ "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
{ "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
{ "char*" "zone" } ;
C-STRUCT: timespec
{ "time_t" "sec" }
{ "long" "nsec" } ;
: make-timespec ( ms -- timespec )
1000 /mod 1000000 *
"timespec" <c-object>
[ set-timespec-nsec ] keep
[ set-timespec-sec ] keep ;
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;

26
extra/unix/unix.factor
View File

@ -8,32 +8,8 @@ IN: unix
TYPEDEF: uint in_addr_t
TYPEDEF: uint socklen_t
TYPEDEF: uint time_t
TYPEDEF: ulong size_t
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
{ "int" "min" } ! Minutes: 0-59
{ "int" "hour" } ! Hours since midnight: 0-23
{ "int" "mday" } ! Day of the month: 1-31
{ "int" "mon" } ! Months *since* january: 0-11
{ "int" "year" } ! Years since 1900
{ "int" "wday" } ! Days since Sunday (0-6)
{ "int" "yday" } ! Days since Jan. 1: 0-365
{ "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
{ "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
{ "char*" "zone" } ;
C-STRUCT: timespec
{ "time_t" "sec" }
{ "long" "nsec" } ;
: make-timespec ( ms -- timespec )
1000 /mod 1000000 *
"timespec" <c-object>
[ set-timespec-nsec ] keep
[ set-timespec-sec ] keep ;
: PROT_NONE 0 ; inline
: PROT_READ 1 ; inline
: PROT_WRITE 2 ; inline
@ -89,7 +65,6 @@ FUNCTION: ushort htons ( ushort n ) ;
FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ;
FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
FUNCTION: int munmap ( void* addr, size_t len ) ;
@ -117,7 +92,6 @@ FUNCTION: int setuid ( uid_t uid ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: char* strerror ( int errno ) ;
FUNCTION: int system ( char* command ) ;
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;