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

Merge commit 'origin/master' into emacs

db4
Jose A. Ortega Ruiz 2008-12-19 01:33:49 +01:00
parent 98203729ed cc027b8b1a
commit 615a7a9a99
9 changed files with 136 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/core-foundation/run-loop/run-loop.factor
View File

@ -19,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
FUNCTION: SInt32 CFRunLoopRunInMode (
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
) ;
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
@ -31,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
) ;
FUNCTION: void CFRunLoopAddSource (
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveSource (
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopAddTimer (
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveTimer (
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
) ;
: CFRunLoopDefaultMode ( -- alien )

24
basis/core-foundation/strings/strings.factor
View File

@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
) ;
: <CFString> ( string -- alien )

19
basis/io/files/info/unix/linux/linux.factor
View File

@ -3,8 +3,9 @@
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux
specialized-arrays.direct.uint arrays io.files.info.unix ;
system unix unix.statfs.linux unix.statvfs.linux io.files.links.unix
specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames ;
IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info
@ -70,6 +71,16 @@ M: linux file-systems
} cleave
] map ;
: (find-mount-point) ( path mtab-paths -- mtab-entry )
[ follow-links ] dip 2dup at* [
2nip
] [
drop [ parent-directory ] dip (find-mount-point)
] if ;
: find-mount-point ( path -- mtab-entry )
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ;
M: linux file-system-info ( path -- )
@ -80,9 +91,7 @@ M: linux file-system-info ( path -- )
[ 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*
find-mount-point
{
[ file-system-name>> >>device-name drop ]
[ mount-point>> >>mount-point drop ]

5
basis/io/files/info/windows/windows.factor
View File

@ -102,10 +102,7 @@ M: windows link-info ( path -- info )
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
{
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
[ ]
} cleave ;
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;

33
basis/io/files/links/links-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io.files.info ;
USING: help.markup help.syntax io.files.info math ;
IN: io.files.links
HELP: make-link
@ -15,9 +15,38 @@ HELP: copy-link
{ make-link read-link copy-link } related-words
HELP: follow-link
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Returns an absolute path from " { $link read-link } "." } ;
HELP: follow-links
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
HELP: symlink-depth
{ $values
{ "value" integer }
}
{ $description "The number of redirections " { $link follow-links } " will follow." } ;
HELP: too-many-symlinks
{ $values
{ "path" "a pathname string" } { "n" integer }
}
{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ;
ARTICLE: "io.files.links" "Symbolic links"
"Reading and creating links:"
"Reading links:"
{ $subsection read-link }
{ $subsection follow-link }
{ $subsection follow-links }
"Creating links:"
{ $subsection make-link }
"Copying links:"
{ $subsection copy-link }

31
basis/io/files/links/links-tests.factor Normal file
View File

@ -0,0 +1,31 @@
USING: io.directories io.files.links tools.test
io.files.unique tools.files ;
IN: io.files.links.tests
: make-test-links ( n path -- )
[ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
[
5 "lol" make-test-links
"lol1" follow-links
current-directory get "lol5" append-path =
] with-unique-directory
] unit-test
[
[
100 "laf" make-test-links "laf1" follow-links
] with-unique-directory
] [ too-many-symlinks? ] must-fail-with
[ t ] [
110 symlink-depth [
[
100 "laf" make-test-links
"laf1" follow-links
current-directory get "laf100" append-path =
] with-unique-directory
] with-variable
] unit-test

27
basis/io/files/links/links.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel vocabs.loader ;
USING: accessors io.backend io.files.info
io.files.links.private io.files.types io.pathnames kernel math
namespaces system unix vocabs.loader ;
IN: io.files.links
HOOK: make-link os ( target symlink -- )
@ -10,4 +12,25 @@ HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- )
[ read-link ] dip make-link ;
os unix? [ "io.files.links.unix" require ] when
os unix? [ "io.files.links.unix" require ] when
: follow-link ( path -- path' )
[ parent-directory ] [ read-symbolic-link ] bi append-path ;
SYMBOL: symlink-depth
10 symlink-depth set-global
ERROR: too-many-symlinks path n ;
<PRIVATE
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
[ [ 1- ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
: follow-links ( path -- path' )
[ symlink-depth get ] dip normalize-path (follow-links) ;

2
basis/io/files/links/unix/unix.factor
View File

@ -7,4 +7,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
normalize-path read-symbolic-link ;

12
basis/x11/xim/xim.factor
View File

@ -9,14 +9,14 @@ IN: x11.xim
SYMBOL: xim
: (init-xim) ( classname medifier -- im )
XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
[ dpy get f ] dip dup XOpenIM ;
XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
[ dpy get f ] dip dup XOpenIM ;
: init-xim ( classname -- )
dup "" (init-xim)
[ nip ]
[ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
xim set-global ;
dup "" (init-xim)
[ nip ]
[ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
xim set-global ;
: close-xim ( -- )
xim get-global XCloseIM drop f xim set-global ;