diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index e4fe0fbc63..d7b0b49dd1 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -5,7 +5,7 @@ io.windows kernel math splitting fry alien.strings windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces make words symbols system io.ports destructors accessors math.bitwise continuations -windows.errors arrays ; +windows.errors arrays byte-arrays ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) @@ -246,20 +246,57 @@ M: winnt file-info ( path -- info ) M: winnt link-info ( path -- info ) file-info ; +HOOK: root-directory os ( string -- string' ) + TUPLE: winnt-file-system-info < file-system-info total-bytes total-free-bytes ; +: file-system-type ( normalized-path -- str ) + MAX_PATH 1+ + MAX_PATH 1+ + "DWORD" "DWORD" "DWORD" + MAX_PATH 1+ + MAX_PATH 1+ + [ GetVolumeInformation win32-error=0/f ] 2keep drop + utf16n alien>string ; + +: file-system-space ( normalized-path -- free-space total-bytes total-free-bytes ) + "ULARGE_INTEGER" + "ULARGE_INTEGER" + "ULARGE_INTEGER" + [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ; + M: winnt file-system-info ( path -- file-system-info ) - normalize-path - dup file-info directory? [ parent-directory ] unless - "ULARGE_INTEGER" - "ULARGE_INTEGER" - "ULARGE_INTEGER" - [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep + normalize-path root-directory + dup [ file-system-type ] [ file-system-space ] bi \ winnt-file-system-info new swap *ulonglong >>total-free-bytes swap *ulonglong >>total-bytes - swap *ulonglong >>free-space ; + swap *ulonglong >>free-space + swap >>type + swap >>name ; + +: find-first-volume ( word -- string handle ) + MAX_PATH 1+ dup length + dupd + FindFirstVolume dup win32-error=0/f + [ utf16n alien>string ] dip ; + +: find-next-volume ( handle -- string ) + MAX_PATH 1+ dup length + [ FindNextVolume win32-error=0/f ] 2keep drop + utf16n alien>string ; + +: mounted ( -- array ) + find-first-volume + [ + '[ + [ _ find-next-volume dup ] + [ ] + [ drop ] produce + swap prefix + ] + ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ; : file-times ( path -- timestamp timestamp timestamp ) [ diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 9b77a9f128..2fbc809263 100644 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -31,12 +31,13 @@ M: winnt root-directory? ( path -- ? ) ERROR: not-absolute-path ; -: root-directory ( string -- string' ) +M: winnt root-directory ( string -- string' ) + unicode-prefix ?head drop dup { [ length 2 >= ] [ second CHAR: : = ] [ first Letter? ] - } 1&& [ 2 head ] [ not-absolute-path ] if ; + } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ; : prepend-prefix ( string -- string' ) dup unicode-prefix head? [ diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index 6c5a45c4d2..64ee8716c2 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -23,7 +23,7 @@ C-STRUCT: statvfs FUNCTION: int statvfs ( char* path, statvfs* buf ) ; TUPLE: freebsd-file-system-info < file-system-info -bavail bfree blocks favail ffree ffiles +bavail bfree blocks favail ffree files bsize flag frsize fsid namemax ; M: freebsd >file-system-info ( struct -- statfs ) diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor index c6ec0bc658..6658d5942d 100644 --- a/basis/unix/statfs/linux/32/32.factor +++ b/basis/unix/statfs/linux/32/32.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types combinators kernel io.files unix.stat +USING: alien.c-types combinators kernel unix.stat math accessors system unix io.backend layouts vocabs.loader -alien.syntax ; +alien.syntax unix.statfs io.files ; IN: unix.statfs.linux C-STRUCT: statfs diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index b4413fba15..5e6e5360ef 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,10 +1,43 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types combinators kernel io.files unix.stat -math accessors system unix io.backend layouts vocabs.loader ; +math accessors system unix io.backend layouts vocabs.loader +sequences csv io.streams.string io.encodings.utf8 namespaces +unix.statfs io.files ; IN: unix.statfs.linux cell-bits { { 32 [ "unix.statfs.linux.32" require ] } { 64 [ "unix.statfs.linux.64" require ] } } case + +TUPLE: mtab-entry file-system-name mount-point type options +frequency pass-number ; + +: mtab-csv>mtab-entry ( csv -- mtab-entry ) + [ mtab-entry new ] dip + { + [ first >>file-system-name ] + [ second >>mount-point ] + [ third >>type ] + [ fourth csv first >>options ] + [ 4 swap nth >>frequency ] + [ 5 swap nth >>pass-number ] + } cleave ; + +: parse-mtab ( -- array ) + [ + "/etc/mtab" utf8 + CHAR: \s delimiter set csv + ] with-scope + [ mtab-csv>mtab-entry ] map ; + +M: linux mounted + parse-mtab [ + [ mount-point>> file-system-info ] keep + { + [ file-system-name>> >>device-name ] + [ mount-point>> >>name ] + [ type>> >>type ] + } cleave + ] map ; diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 4bd9f55132..e065fc6118 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -120,13 +120,13 @@ FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ; TUPLE: macosx-file-system-info < file-system-info block-size io-size blocks blocks-free blocks-available files -files-free file-system-id owner type flags filesystem-subtype -file-system-type-name mount-from ; +files-free file-system-id owner type-id flags filesystem-subtype ; -M: macosx mounted* ( -- array ) +M: macosx mounted ( -- array ) f dup 0 getmntinfo64 dup io-error [ *void* ] dip - "statfs64" heap-size [ * memory>byte-array ] keep group ; + "statfs64" heap-size [ * memory>byte-array ] keep group + [ >file-system-info ] map ; M: macosx >file-system-info ( byte-array -- file-system-info ) [ \ macosx-file-system-info new ] dip @@ -135,7 +135,7 @@ M: macosx >file-system-info ( byte-array -- file-system-info ) [ statfs64-f_bavail ] [ statfs64-f_bsize ] bi * >>free-space ] - [ statfs64-f_mntonname utf8 alien>string >>mount-on ] + [ statfs64-f_mntonname utf8 alien>string >>name ] [ statfs64-f_bsize >>block-size ] [ statfs64-f_iosize >>io-size ] @@ -146,16 +146,16 @@ M: macosx >file-system-info ( byte-array -- file-system-info ) [ statfs64-f_ffree >>files-free ] [ statfs64-f_fsid >>file-system-id ] [ statfs64-f_owner >>owner ] - [ statfs64-f_type >>type ] + [ statfs64-f_type >>type-id ] [ statfs64-f_flags >>flags ] [ statfs64-f_fssubtype >>filesystem-subtype ] [ statfs64-f_fstypename utf8 alien>string - >>file-system-type-name + >>type ] [ statfs64-f_mntfromname - utf8 alien>string >>mount-from + utf8 alien>string >>device-name ] } cleave ; diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index dd1ccd4c9a..5aff13cceb 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel io.files unix.stat math unix +USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types -io.encodings.utf8 alien.strings unix.types ; +io.encodings.utf8 alien.strings unix.types unix.statfs io.files ; IN: unix.statfs.netbsd : _VFS_NAMELEN 32 ; inline @@ -69,7 +69,7 @@ M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info ) [ statvfs-f_owner >>owner ] [ statvfs-f_spare >>spare ] [ statvfs-f_fstypename utf8 alien>string >>file-system-type-name ] - [ statvfs-f_mntonname utf8 alien>string >>mount-on ] + [ statvfs-f_mntonname utf8 alien>string >>name ] [ statvfs-f_mntfromname utf8 alien>string >>mount-from ] } cleave ; diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index f00ffe77cd..e77ef37b0f 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -4,25 +4,11 @@ USING: sequences system vocabs.loader combinators accessors kernel math.order sorting ; IN: unix.statfs -TUPLE: mounted block-size io-size blocks blocks-free -blocks-available files files-free file-system-id owner type -flags filesystem-subtype file-system-type-name mount-on -mount-from ; - -HOOK: mounted* os ( -- array ) -HOOK: mounted-struct>mounted os ( byte-array -- mounted ) - TUPLE: file-system-info root-directory total-free-size total-size ; HOOK: >file-system-info os ( struct -- statfs ) -: mounted ( -- array ) - mounted* [ mounted-struct>mounted ] map ; - -: mounted-drive ( path -- mounted/f ) - mounted - [ [ mount-on>> ] bi@ <=> ] sort - [ mount-on>> head? ] with find nip ; +HOOK: mounted os ( -- array ) os { { linux [ "unix.statfs.linux" require ] } diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index 156e756641..ac62776ed7 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/basis/unix/types/macosx/macosx.factor @@ -1,19 +1,13 @@ - USING: alien.syntax ; - IN: unix.types -! Darwin 9.1.0 ppc - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Darwin 9.1.0 TYPEDEF: ushort __uint16_t TYPEDEF: uint __uint32_t TYPEDEF: int __int32_t TYPEDEF: longlong __int64_t -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TYPEDEF: __int32_t dev_t TYPEDEF: __uint32_t ino_t TYPEDEF: __uint16_t mode_t diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 51db6f5da0..f7ce6406fe 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -2,15 +2,6 @@ USING: kernel system alien.syntax combinators vocabs.loader system ; IN: unix.types -TYPEDEF: void* caddr_t -TYPEDEF: uint in_addr_t -TYPEDEF: uint socklen_t - -TYPEDEF: __uint64_t fsblkcnt_t -TYPEDEF: fsblkcnt_t __fsblkcnt_t -TYPEDEF: __uint64_t fsfilcnt_t -TYPEDEF: fsfilcnt_t __fsfilcnt_t - TYPEDEF: char int8_t TYPEDEF: short int16_t TYPEDEF: int int32_t @@ -36,6 +27,16 @@ TYPEDEF: ushort __uint16_t TYPEDEF: uint __uint32_t TYPEDEF: ulonglong __uint64_t +TYPEDEF: void* caddr_t +TYPEDEF: uint in_addr_t +TYPEDEF: uint socklen_t + +TYPEDEF: __uint64_t fsblkcnt_t +TYPEDEF: fsblkcnt_t __fsblkcnt_t +TYPEDEF: __uint64_t fsfilcnt_t +TYPEDEF: fsfilcnt_t __fsfilcnt_t +TYPEDEF: __uint64_t rlim_t +TYPEDEF: uint32_t id_t os { { linux [ "unix.types.linux" require ] } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 2fcb83dc2c..4950daef2c 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -116,6 +116,13 @@ FUNCTION: passwd* getpwnam ( char* login ) ; FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ; FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ; +FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ; +FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ; + +FUNCTION: int getpriority ( int which, id_t who ) ; +FUNCTION: int setpriority ( int which, id_t who, int prio ) ; + +FUNCTION: int getrusage ( int who, rusage* r_usage ) ; FUNCTION: group* getgrent ; FUNCTION: int gethostname ( char* name, int len ) ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index dfac6a5236..eb90fb522e 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -812,22 +812,42 @@ FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFi ALIAS: FindFirstFile FindFirstFileW ! FUNCTION: FindFirstVolumeA ! FUNCTION: FindFirstVolumeMountPointA -! FUNCTION: FindFirstVolumeMountPointW -! FUNCTION: FindFirstVolumeW + +FUNCTION: HANDLE FindFirstVolumeMountPointW ( + LPTSTR lpszRootPathName, + LPTSTR lpszVolumeMountPoint, + DWORD cchBufferLength +) ; +ALIAS: FindFirstVolumeMountPoint FindFirstVolumeMountPointW + +FUNCTION: HANDLE FindFirstVolumeW ( LPTSTR lpszVolumeName, DWORD cchBufferLength ) ; +ALIAS: FindFirstVolume FindFirstVolumeW + FUNCTION: BOOL FindNextChangeNotification ( HANDLE hChangeHandle ) ; + ! FUNCTION: FindNextFileA FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileData ) ; ALIAS: FindNextFile FindNextFileW + ! FUNCTION: FindNextVolumeA ! FUNCTION: FindNextVolumeMountPointA -! FUNCTION: FindNextVolumeMountPointW -! FUNCTION: FindNextVolumeW + +FUNCTION: BOOL FindNextVolumeMountPointW ( + HANDLE hFindVolumeMountPoint, + LPTSTR lpszVolumeMountPoint, + DWORD cchBufferLength +) ; +ALIAS: FindNextVolumeMountPoint FindNextVolumeMountPointW + +FUNCTION: BOOL FindNextVolumeW ( HANDLE hFindVolume, LPTSTR lpszVolumeName, DWORD cchBufferLength ) ; +ALIAS: FindNextVolume FindNextVolumeW + ! FUNCTION: FindResourceA ! FUNCTION: FindResourceExA ! FUNCTION: FindResourceExW ! FUNCTION: FindResourceW -! FUNCTION: FindVolumeClose -! FUNCTION: FindVolumeMountPointClose +FUNCTION: BOOL FindVolumeClose ( HANDLE hFindVolume ) ; +FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ; ! FUNCTION: FlushConsoleInputBuffer ! FUNCTION: FlushFileBuffers ! FUNCTION: FlushInstructionCache @@ -1094,7 +1114,17 @@ FUNCTION: DWORD GetVersion ( ) ; FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ; ALIAS: GetVersionEx GetVersionExW ! FUNCTION: GetVolumeInformationA -! FUNCTION: GetVolumeInformationW +FUNCTION: BOOL GetVolumeInformationW ( + LPCTSTR lpRootPathName, + LPTSTR lpVolumNameBuffer, + DWORD nVolumeNameSize, + LPDWORD lpVolumeSerialNumber, + LPDWORD lpMaximumComponentLength, + LPDWORD lpFileSystemFlags, + LPCTSTR lpFileSystemNameBuffer, + DWORD nFileSystemNameSize +) ; +ALIAS: GetVolumeInformation GetVolumeInformationW ! FUNCTION: GetVolumeNameForVolumeMountPointA ! FUNCTION: GetVolumeNameForVolumeMountPointW ! FUNCTION: GetVolumePathNameA diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1f6a48b50e..f643f4ca3c 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -184,7 +184,7 @@ SYMBOL: +unknown+ ! File-system -TUPLE: file-system-info mount-on free-space ; +TUPLE: file-system-info device-name name type free-space ; HOOK: file-system-info os ( path -- file-system-info ) diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor new file mode 100644 index 0000000000..f7983965d5 --- /dev/null +++ b/extra/dns/resolver/resolver.factor @@ -0,0 +1,70 @@ + +USING: kernel accessors namespaces continuations + io io.sockets io.binary io.timeouts io.encodings.binary + destructors + locals strings sequences random prettyprint calendar dns dns.misc ; + +IN: dns.resolver + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: send-receive-udp ( BA SERVER -- ba ) + T{ inet4 f f 0 } + T{ duration { second 3 } } over set-timeout + [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ] + with-disposal ; + +:: send-receive-tcp ( BA SERVER -- ba ) + [let | BA [ BA length 2 >be BA append ] | + SERVER binary + [ + T{ duration { second 3 } } input-stream get set-timeout + BA write flush 2 read be> read + ] + with-client ] ; + +:: send-receive-server ( BA SERVER -- msg ) + [let | RESULT [ BA SERVER send-receive-udp parse-message ] | + RESULT tc>> 1 = + [ BA SERVER send-receive-tcp parse-message ] + [ RESULT ] + if ] ; + +: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 ] [ ] if ; + +:: send-receive-servers ( BA SERVERS -- msg ) + SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when + [let | SERVER [ SERVERS random >dns-inet4 ] | + ! if this throws an error ... + [ BA SERVER send-receive-server ] + ! we try with the other servers... + [ drop BA SERVER SERVERS remove send-receive-servers ] + recover ] ; + +:: ask-servers ( MSG SERVERS -- msg ) + MSG message->ba SERVERS send-receive-servers ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dns-servers ( -- seq ) + \ dns-servers get + [ ] + [ resolv-conf-servers \ dns-servers set dns-servers ] + if* ; + +! : dns-server ( -- server ) dns-servers random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dns-ip ( name -- ips ) + fully-qualified + [let | MSG [ A IN query boa query->message dns-servers ask-servers ] | + MSG rcode>> NO-ERROR = + [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ] + [ "dns-ip: rcode = " MSG rcode>> unparse append throw ] + if ] ; +