Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/SMLNJ/src/compiler/PervEnv/Win32/os-filesys.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/PervEnv/Win32/os-filesys.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 113 - (view) (download)

1 : monnier 16 (* os-filesys.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 Bell Laboratories.
4 :     *
5 :     * Win32 implementation of the OS.FileSys structure
6 :     *
7 :     *)
8 :    
9 :     structure OS_FileSys : OS_FILE_SYS =
10 :     struct
11 :     structure OSPath = OS_Path
12 :     structure W32G = Win32_General
13 :     structure W32FS = Win32_FileSys
14 :     structure S = String
15 :     structure C = Char
16 :     val not = Bool.not
17 :    
18 :     exception SysErr = Assembly.SysErr
19 :    
20 :     datatype dirstream = DS of {
21 :     hndlptr : W32G.hndl ref,
22 :     query : string,
23 :     isOpen : bool ref,
24 :     nextFile : string option ref
25 :     }
26 :    
27 :     fun rse name msg = raise SysErr(String.concat[name, ": ", msg], NONE)
28 :    
29 :     fun isDir s =
30 :     case W32FS.getFileAttributes s of
31 :     NONE =>
32 :     rse "isDir" "cannot get file attributes"
33 :     | SOME a =>
34 :     W32G.Word.andb(W32FS.FILE_ATTRIBUTE_DIRECTORY,a) <> 0wx0
35 :    
36 :     fun openDir s =
37 :     let fun rse' s = rse "openDir" s
38 :     val _ = not (isDir s) andalso rse' "invalid directory"
39 :     fun mkValidDir s =
40 :     if (S.sub(s,S.size s - 1) <> W32G.arcSepChar) then
41 :     s^(S.str W32G.arcSepChar)
42 :     else s
43 :     val p = (mkValidDir s)^"*"
44 :     val (h,firstName) = W32FS.findFirstFile p
45 :     in
46 :     if not (W32G.isValidHandle h) then
47 :     rse' "cannot find first file"
48 :     else
49 :     DS{hndlptr=ref h,query=p,
50 :     isOpen=ref true,nextFile=ref firstName}
51 :     end
52 :    
53 :     fun readDir (DS{isOpen=ref false,...}) =
54 :     rse "readDir" "stream not open"
55 :     | readDir (DS{nextFile=ref NONE,...}) = ""
56 :     | readDir (DS{hndlptr,nextFile=nF as ref (SOME name),...}) =
57 :     (nF := W32FS.findNextFile (!hndlptr);
58 :     name)
59 :     val readDir = (* OSPath.mkCanonical o *) readDir
60 :    
61 :     fun closeDir (DS{isOpen=ref false,...}) = ()
62 :     | closeDir (DS{hndlptr,isOpen,...}) =
63 :     (isOpen := false;
64 :     if W32FS.findClose (!hndlptr) then ()
65 :     else
66 :     rse "closeDir" "win32: unexpected closeDir failure")
67 :    
68 :     fun rewindDir (DS{isOpen=ref false,...}) =
69 :     rse "rewindDir" "rewinddir on closed directory stream"
70 :     | rewindDir (d as DS{hndlptr,query,isOpen,nextFile}) =
71 :     let val _ = closeDir d
72 :     val (h,firstName) = W32FS.findFirstFile query
73 :     in
74 :     if not (W32G.isValidHandle h) then
75 :     rse "rewindDir" "cannot rewind to first file"
76 :     else
77 :     (hndlptr := h;
78 :     nextFile := firstName;
79 :     isOpen := true)
80 :     end
81 :    
82 :     fun chDir s =
83 :     if W32FS.setCurrentDirectory s then ()
84 :     else rse "chDir" "cannot change directory"
85 :    
86 :     val getDir = OSPath.mkCanonical o W32FS.getCurrentDirectory'
87 :    
88 :     fun mkDir s =
89 :     if W32FS.createDirectory' s then ()
90 :     else rse "mkDir" "cannot create directory"
91 :    
92 :     fun rmDir s =
93 :     if W32FS.removeDirectory s then ()
94 :     else rse "rmDir" "cannot remove directory"
95 :    
96 :     fun isLink _ = false
97 :     fun readLink _ = rse "readLink" "OS does not have links"
98 :    
99 :     fun exists s = W32FS.getFileAttributes s <> NONE
100 :    
101 :     fun fullPath s =
102 :     if exists s then W32FS.getFullPathName' s
103 :     else raise SysErr("fullPath: cannot generate full path",NONE)
104 :     val fullPath = OSPath.mkCanonical o fullPath
105 :    
106 :     fun realPath p =
107 :     if OSPath.isAbsolute p then fullPath p
108 :     else OSPath.mkRelative (fullPath p, fullPath (getDir()))
109 :    
110 :     fun fileSize s =
111 :     case W32FS.getLowFileSizeByName s of
112 :     SOME w => W32G.Word.toInt w
113 :     | NONE => rse "fileSize" "cannot get size"
114 :    
115 :     fun intToMonth 1 = Date.Jan
116 :     | intToMonth 2 = Date.Feb
117 :     | intToMonth 3 = Date.Mar
118 :     | intToMonth 4 = Date.Apr
119 :     | intToMonth 5 = Date.May
120 :     | intToMonth 6 = Date.Jun
121 :     | intToMonth 7 = Date.Jul
122 :     | intToMonth 8 = Date.Aug
123 :     | intToMonth 9 = Date.Sep
124 :     | intToMonth 10 = Date.Oct
125 :     | intToMonth 11 = Date.Nov
126 :     | intToMonth 12 = Date.Dec
127 :    
128 :     fun monthToInt Date.Jan = 1
129 :     | monthToInt Date.Feb = 2
130 :     | monthToInt Date.Mar = 3
131 :     | monthToInt Date.Apr = 4
132 :     | monthToInt Date.May = 5
133 :     | monthToInt Date.Jun = 6
134 :     | monthToInt Date.Jul = 7
135 :     | monthToInt Date.Aug = 8
136 :     | monthToInt Date.Sep = 9
137 :     | monthToInt Date.Oct = 10
138 :     | monthToInt Date.Nov = 11
139 :     | monthToInt Date.Dec = 12
140 :    
141 :     fun intToWeekDay 0 = Date.Sun
142 :     | intToWeekDay 1 = Date.Mon
143 :     | intToWeekDay 2 = Date.Tue
144 :     | intToWeekDay 3 = Date.Wed
145 :     | intToWeekDay 4 = Date.Thu
146 :     | intToWeekDay 5 = Date.Fri
147 :     | intToWeekDay 6 = Date.Sat
148 :    
149 :     fun weekDayToInt Date.Sun = 0
150 :     | weekDayToInt Date.Mon = 1
151 :     | weekDayToInt Date.Tue = 2
152 :     | weekDayToInt Date.Wed = 3
153 :     | weekDayToInt Date.Thu = 4
154 :     | weekDayToInt Date.Fri = 5
155 :     | weekDayToInt Date.Sat = 6
156 :    
157 :     fun modTime s = (case W32FS.getFileTime' s
158 :     of (SOME info) =>
159 :     Date.toTime(Date.date{
160 :     year = #year info,
161 :     month = intToMonth(#month info),
162 :     day = #day info,
163 :     hour = #hour info,
164 :     minute = #minute info,
165 :     second = #second info,
166 :     offset = NONE
167 :     })
168 :     | NONE => rse "modTime" "cannot get file time"
169 :     (* end case *))
170 :    
171 :     fun setTime (s,t) = let
172 :     val date = Date.fromTimeLocal(case t of NONE => Time.now() | SOME t' => t')
173 :     val date' = {
174 :     year = Date.year date,
175 :     month = monthToInt(Date.month date),
176 :     dayOfWeek = weekDayToInt(Date.weekDay date),
177 :     day = Date.day date,
178 :     hour = Date.hour date,
179 :     minute = Date.minute date,
180 :     second = Date.second date,
181 :     milliSeconds = 0
182 :     }
183 :     in
184 :     if W32FS.setFileTime' (s, date')
185 :     then ()
186 :     else rse "setTime" "cannot set time"
187 :     end
188 :    
189 :     fun remove s =
190 :     if W32FS.deleteFile s then ()
191 :     else rse "remove" "cannot remove file"
192 :    
193 :     fun rename {old: string,new: string} =
194 :     let fun rse' s = rse "rename" s
195 :     val _ = not (exists old) andalso
196 :     rse' "cannot find 'old'"
197 :     val same = (exists new) andalso
198 :     (fullPath old = fullPath new)
199 :     in
200 :     if not same then
201 :     (if (exists new) then
202 :     remove new
203 :     handle _ => rse' "cannot remove 'new'"
204 :     else ();
205 :     if W32FS.moveFile(old,new) then ()
206 :     else rse' "moveFile failed")
207 :     else ()
208 :     end
209 :    
210 :     datatype access_mode = A_READ | A_WRITE | A_EXEC
211 :    
212 :     val strUpper =
213 :     S.translate (fn c => S.str (if C.isAlpha c then C.toUpper c else c))
214 :    
215 :     fun access (s,[]) = exists s
216 :     | access (s,al) =
217 :     case W32FS.getFileAttributes s of
218 :     NONE =>
219 :     rse "access" "cannot get file attributes"
220 :     | SOME aw =>
221 :     let fun aux A_READ = true
222 :     | aux A_WRITE =
223 :     W32G.Word.andb(W32FS.FILE_ATTRIBUTE_READONLY,aw) = 0w0
224 :     | aux A_EXEC =
225 :     (case #ext(OS_Path.splitBaseExt s) of
226 :     SOME ext => (case (strUpper ext) of
227 :     ("EXE" | "COM" |
228 :     "CMD" | "BAT" ) => true
229 :     | _ => false)
230 :     | NONE => false)
231 :     in List.all aux al
232 :     end
233 :    
234 :     fun tmpName () =
235 :     case W32FS.getTempFileName' () of
236 :     NONE => rse "tmpName" "cannot obtain tmp filename"
237 :     | SOME s => s
238 :    
239 :     type file_id = string
240 :    
241 :     fun fileId s =
242 :     fullPath s
243 :     handle (SysErr _) =>
244 :     rse "fileId" "cannot create file id"
245 :    
246 :     fun hash (fid : file_id) =
247 :     Word.fromInt
248 :     (List.foldl (fn (a,b) => (Char.ord a + b) handle _ => 0) 0
249 :     (String.explode fid))
250 :    
251 :     val compare = String.compare
252 :     end
253 :    
254 :    
255 :     (*
256 : monnier 113 * $Log$
257 : monnier 16 *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0