basis/io/windows/files/files.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types io.binary io.backend io.files io.buffers
   4 io.windows kernel math splitting
   5 windows windows.kernel32 windows.time calendar combinators
   6 math.functions sequences namespaces words symbols system
   7 io.ports destructors accessors
   8 math.bitfields math.bitfields.lib ;
   9 IN: io.windows.files
  10
  11 : open-file ( path access-mode create-mode flags -- handle )
  12     [
  13         >r >r share-mode default-security-attributes r> r>
  14         CreateFile-flags f CreateFile opened-file
  15     ] with-destructors ;
  16
  17 : open-pipe-r/w ( path -- win32-file )
  18     { GENERIC_READ GENERIC_WRITE } flags
  19     OPEN_EXISTING 0 open-file ;
  20
  21 : open-read ( path -- win32-file )
  22     GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
  23
  24 : open-write ( path -- win32-file )
  25     GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
  26
  27 : (open-append) ( path -- win32-file )
  28     GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
  29
  30 : open-existing ( path -- win32-file )
  31     { GENERIC_READ GENERIC_WRITE } flags
  32     share-mode
  33     f
  34     OPEN_EXISTING
  35     FILE_FLAG_BACKUP_SEMANTICS
  36     f CreateFileW dup win32-error=0/f <win32-file> ;
  37
  38 : maybe-create-file ( path -- win32-file ? )
  39     #! return true if file was just created
  40     { GENERIC_READ GENERIC_WRITE } flags
  41     share-mode
  42     f
  43     OPEN_ALWAYS
  44     0 CreateFile-flags
  45     f CreateFileW dup win32-error=0/f <win32-file>
  46     GetLastError ERROR_ALREADY_EXISTS = not ;
  47
  48 : set-file-pointer ( handle length method -- )
  49     >r dupd d>w/w <uint> r> SetFilePointer
  50     INVALID_SET_FILE_POINTER = [
  51         CloseHandle "SetFilePointer failed" throw
  52     ] when drop ;
  53
  54 HOOK: open-append os ( path -- win32-file )
  55
  56 TUPLE: FileArgs
  57     hFile lpBuffer nNumberOfBytesToRead
  58     lpNumberOfBytesRet lpOverlapped ;
  59
  60 C: <FileArgs> FileArgs
  61
  62 : make-FileArgs ( port -- <FileArgs> )
  63     {
  64         [ handle>> check-disposed ]
  65         [ handle>> handle>> ]
  66         [ buffer>> ]
  67         [ buffer>> buffer-length ]
  68         [ drop "DWORD" <c-object> ]
  69         [ FileArgs-overlapped ]
  70     } cleave <FileArgs> ;
  71
  72 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
  73     {
  74         [ hFile>> ]
  75         [ lpBuffer>> buffer-end ]
  76         [ lpBuffer>> buffer-capacity ]
  77         [ lpNumberOfBytesRet>> ]
  78         [ lpOverlapped>> ]
  79     } cleave ;
  80
  81 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
  82     {
  83         [ hFile>> ]
  84         [ lpBuffer>> buffer@ ]
  85         [ lpBuffer>> buffer-length ]
  86         [ lpNumberOfBytesRet>> ]
  87         [ lpOverlapped>> ]
  88     } cleave ;
  89
  90 M: windows (file-reader) ( path -- stream )
  91     open-read <input-port> ;
  92
  93 M: windows (file-writer) ( path -- stream )
  94     open-write <output-port> ;
  95
  96 M: windows (file-appender) ( path -- stream )
  97     open-append <output-port> ;
  98
  99 M: windows move-file ( from to -- )
 100     [ normalize-path ] bi@ MoveFile win32-error=0/f ;
 101
 102 M: windows delete-file ( path -- )
 103     normalize-path DeleteFile win32-error=0/f ;
 104
 105 M: windows copy-file ( from to -- )
 106     dup parent-directory make-directories
 107     [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
 108
 109 M: windows make-directory ( path -- )
 110     normalize-path
 111     f CreateDirectory win32-error=0/f ;
 112
 113 M: windows delete-directory ( path -- )
 114     normalize-path
 115     RemoveDirectory win32-error=0/f ;
 116
 117 M: windows normalize-directory ( string -- string )
 118     normalize-path "\\" ?tail drop "\\*" append ;
 119
 120 SYMBOLS: +read-only+ +hidden+ +system+
 121 +archive+ +device+ +normal+ +temporary+
 122 +sparse-file+ +reparse-point+ +compressed+ +offline+
 123 +not-content-indexed+ +encrypted+ ;
 124
 125 : win32-file-attribute ( n attr symbol -- n )
 126     >r dupd mask? [ r> , ] [ r> drop ] if ;
 127
 128 : win32-file-attributes ( n -- seq )
 129     [
 130         FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
 131         FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
 132         FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
 133         FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
 134         FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
 135         FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
 136         FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
 137         FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
 138         FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
 139         FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
 140         FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
 141         FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
 142         FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
 143         FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
 144         drop
 145     ] { } make ;
 146
 147 : win32-file-type ( n -- symbol )
 148     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 149
 150 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
 151     {
 152         [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
 153         [
 154             [ WIN32_FIND_DATA-nFileSizeLow ]
 155             [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
 156         ]
 157         [ WIN32_FIND_DATA-dwFileAttributes ]
 158         ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
 159         [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
 160         ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
 161     } cleave
 162     \ file-info boa ;
 163
 164 : find-first-file-stat ( path -- WIN32_FIND_DATA )
 165     "WIN32_FIND_DATA" <c-object> [
 166         FindFirstFile
 167         [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
 168         FindClose win32-error=0/f
 169     ] keep ;
 170
 171 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
 172     {
 173         [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
 174         [
 175             [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
 176             [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
 177         ]
 178         [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
 179         ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
 180         [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
 181         ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
 182         ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
 183         ! [
 184           ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
 185           ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
 186         ! ]
 187     } cleave
 188     \ file-info boa ;
 189
 190 : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
 191     [
 192         "BY_HANDLE_FILE_INFORMATION" <c-object>
 193         [ GetFileInformationByHandle win32-error=0/f ] keep
 194     ] keep CloseHandle win32-error=0/f ;
 195
 196 : get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
 197     dup
 198     GENERIC_READ FILE_SHARE_READ f
 199     OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
 200     CreateFileW dup INVALID_HANDLE_VALUE = [
 201         drop find-first-file-stat WIN32_FIND_DATA>file-info
 202     ] [
 203         nip
 204         get-file-information BY_HANDLE_FILE_INFORMATION>file-info
 205     ] if ;
 206
 207 M: winnt file-info ( path -- info )
 208     normalize-path get-file-information-stat ;
 209
 210 M: winnt link-info ( path -- info )
 211     file-info ;
 212
 213 : file-times ( path -- timestamp timestamp timestamp )
 214     [
 215         normalize-path open-existing &dispose handle>>
 216         "FILETIME" <c-object>
 217         "FILETIME" <c-object>
 218         "FILETIME" <c-object>
 219         [ GetFileTime win32-error=0/f ] 3keep
 220         [ FILETIME>timestamp >local-time ] tri@
 221     ] with-destructors ;
 222
 223 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
 224     [ timestamp>FILETIME ] tri@
 225     SetFileTime win32-error=0/f ;
 226
 227 : set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
 228     #! timestamp order: creation access write
 229     [
 230         >r >r >r
 231             normalize-path open-existing &dispose handle>>
 232         r> r> r> (set-file-times)
 233     ] with-destructors ;
 234
 235 : set-file-create-time ( path timestamp -- )
 236     f f set-file-times ;
 237
 238 : set-file-access-time ( path timestamp -- )
 239     >r f r> f set-file-times ;
 240
 241 : set-file-write-time ( path timestamp -- )
 242     >r f f r> set-file-times ;
 243
 244 M: winnt touch-file ( path -- )
 245     [
 246         normalize-path
 247         maybe-create-file >r &dispose r>
 248         [ drop ] [ handle>> f now dup (set-file-times) ] if
 249     ] with-destructors ;