1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.data alien.strings ascii
4 calendar classes.struct combinators combinators.short-circuit
5 continuations destructors fry io.backend io.files.info
6 io.files.windows kernel libc literals locals math sequences
7 splitting system windows.errors windows.kernel32 windows.shell32
8 windows.time windows.types ;
9 IN: io.files.info.windows
11 :: round-up-to ( n multiple -- n' )
18 TUPLE: windows-file-info < file-info-tuple attributes ;
20 : get-compressed-file-size ( path -- n )
21 { DWORD } [ GetCompressedFileSize ] with-out-parameters
22 over INVALID_FILE_SIZE = [ win32-error ] when >64bit ;
24 : set-windows-size-on-disk ( file-info path -- file-info )
25 over attributes>> +compressed+ swap member? [
26 get-compressed-file-size
28 drop dup size>> 4096 round-up-to
31 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
32 [ \ windows-file-info new ] dip
34 [ dwFileAttributes>> win32-file-type >>type ]
35 [ dwFileAttributes>> win32-file-attributes >>attributes ]
36 [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit >>size ]
37 [ dwFileAttributes>> >>permissions ]
38 [ ftCreationTime>> FILETIME>timestamp >>created ]
39 [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
40 [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
43 : find-first-file-stat ( path -- WIN32_FIND_DATA )
45 FindFirstFile check-invalid-handle
46 FindClose win32-error=0/f
49 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
50 [ \ windows-file-info new ] dip
52 [ dwFileAttributes>> win32-file-type >>type ]
53 [ dwFileAttributes>> win32-file-attributes >>attributes ]
56 [ nFileSizeHigh>> ] bi >64bit >>size
58 [ dwFileAttributes>> >>permissions ]
59 [ ftCreationTime>> FILETIME>timestamp >>created ]
60 [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
61 [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
62 ! [ nNumberOfLinks>> ]
65 ! [ nFileIndexHigh>> ] bi >64bit
69 : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
71 BY_HANDLE_FILE_INFORMATION new
72 [ GetFileInformationByHandle win32-error=0/f ] keep
73 ] keep CloseHandle win32-error=0/f ;
75 : valid-handle? ( handle -- boolean )
76 INVALID_HANDLE_VALUE = not ; inline
78 : open-read-handle ( path -- handle/f )
79 ! Parameters of CreateFileW here should match those in open-read.
80 GENERIC_READ share-mode f
81 OPEN_EXISTING 0 CreateFile-flags f
82 CreateFileW [ valid-handle? ] keep f ? ;
84 : get-file-information-stat ( path -- file-info )
85 dup open-read-handle dup [
87 get-file-information BY_HANDLE_FILE_INFORMATION>file-info
89 drop find-first-file-stat WIN32_FIND_DATA>file-info
94 [ get-file-information-stat ]
95 [ set-windows-size-on-disk ] bi ;
100 : file-executable-type ( path -- executable/f )
104 ! hi is zero means old style executable
105 0 SHGFI_EXETYPE SHGetFileInfoW
109 nip >lo-hi first2 zero? [
111 { 0x5A4D [ +dos-executable+ ] }
112 { 0x4550 [ +win32-console-executable+ ] }
117 { 0x454C [ +win32-vxd-executable+ ] }
118 { 0x454E [ +win32-os2-executable+ ] }
119 { 0x4550 [ +win32-nt-executable+ ] }
125 CONSTANT: path-length $[ MAX_PATH 1 + ]
127 : volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
128 { { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
129 [ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
131 [ alien>native-string ] 4dip alien>native-string ;
133 : file-system-space ( normalized-path -- available-space total-space free-space )
134 { ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
135 [ GetDiskFreeSpaceEx win32-error=0/f ]
136 with-out-parameters ;
138 : calculate-file-system-info ( file-system-info -- file-system-info' )
139 [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
141 TUPLE: win32-file-system-info < file-system-info-tuple max-component flags device-serial ;
143 ERROR: not-absolute-path ;
145 : root-directory ( string -- string' )
146 unicode-prefix ?head drop
151 } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
155 : (file-system-info) ( path -- file-system-info )
156 dup [ volume-information ] [ file-system-space ] bi
157 \ win32-file-system-info new
160 swap >>available-space
167 calculate-file-system-info ;
171 M: windows file-system-info
172 normalize-path root-directory (file-system-info) ;
174 CONSTANT: names-buf-length 16384
176 : find-first-volume ( -- string handle )
177 { { ushort path-length } }
178 [ path-length FindFirstVolume dup win32-error=0/f ]
179 with-out-parameters alien>native-string swap ;
181 : find-next-volume ( handle -- string/f )
182 { { ushort path-length } }
183 [ path-length FindNextVolume ] with-out-parameters
185 GetLastError ERROR_NO_MORE_FILES =
186 [ drop f ] [ win32-error ] if
187 ] [ alien>native-string ] if ;
189 : find-volumes ( -- array )
193 [ _ find-next-volume dup ] [ ] produce nip
196 ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi finally ;
198 ! Windows may return a volume which looks up to path ""
199 ! For now, treat it like there is not a volume here
200 : (volume>paths) ( string -- array )
203 [ ushort malloc-array &free ] keep
205 [ GetVolumePathNamesForVolumeName win32-error=0/f ] 3keep nip
206 uint deref head but-last-slice
207 { 0 } split-slice harvest
208 [ { } ] [ [ { 0 } append alien>native-string ] map ] if-empty
211 ! Suppress T{ windows-error f 2 "The system cannot find the file specified." }
212 : volume>paths ( string -- array/f )
213 '[ _ (volume>paths) ] [
214 { [ windows-error? ] [ n>> ERROR_FILE_NOT_FOUND = ] } 1&&
217 ! Can error with T{ windows-error f 21 "The device is not ready." }
218 ! if there is a D: that is not ready, for instance. Ignore these drives.
219 M: windows file-systems
220 find-volumes [ volume>paths ] map concat [
221 [ (file-system-info) ] [ 2drop f ] recover
224 : file-times ( path -- timestamp timestamp timestamp )
226 normalize-path open-read &dispose handle>>
227 { FILETIME FILETIME FILETIME }
228 [ GetFileTime win32-error=0/f ]
230 [ FILETIME>timestamp >local-time ] tri@
233 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
234 ! timestamp order: creation access write
237 normalize-path open-r/w &dispose handle>>
238 ] 3dip (set-file-times)
241 : set-file-create-time ( path timestamp -- )
244 : set-file-access-time ( path timestamp -- )
245 [ f ] dip f set-file-times ;
247 : set-file-write-time ( path timestamp -- )
248 [ f f ] dip set-file-times ;
250 M: windows file-readable?
251 normalize-path open-read-handle
252 dup [ CloseHandle win32-error=0/f ] when* >boolean ;
254 M: windows file-writable? file-info attributes>> +read-only+ swap member? not ;
255 M: windows file-executable? file-executable-type windows-executable? ;