## os-file-system.pkg
# Win32 implementation of the winix__premicrothread::file package
stipulate
package string = StringImp
package time = TimeImp
package unt = unt_guts
herein
package winix_file
: Winix_File
{
package ospath = winix_path
package W32G = win32_general
package W32FS = Win32_FileSys
package s = string
package c = char
not = bool::not
exception RUNTIME_EXCEPTION
=
assembly::RUNTIME_EXCEPTION
enum Directory_Stream = DS of {
hndlptr: Ref( W32G::hndl ),
query: String,
isOpen: Ref( Bool ),
nextFile: REF( Null_Or( String ) )
}
fun rse name msg # "rse" might be "raise"
=
raise exception RUNTIME_EXCEPTION (string::cat [name, ": ", msg], NULL)
fun is_directory s =
case W32FS::getFileAttributes s of
NULL =>
rse "is_directory" "cannot get file attributes"
| THE a =>
W32G::unt::bitwise_and (W32FS::FILE_ATTRIBUTE_DIRECTORY, a) != 0wx0
fun open_directory_stream s =
let fun rse' s = rse "open_directory_stream" s
not (is_directory s) and rse' "invalid directory"
fun mkValidDir s =
if (s::sub (s, s::size s - 1) != W32G::arcSepChar) then
s$(s::str W32G::arcSepChar)
else s
p = (mkValidDir s)$"*"
my (h, firstName) = W32FS::findFirstFile p
in
if not (W32G::isValidHandle h) then
rse' "cannot find first file"
else
DS { hndlptr=REF h, query=p,
isOpen=REF TRUE, nextFile=REF firstName }
end
fun read_directory_entry (DS { isOpen=REF FALSE, ... } ) =
rse "read_directory_entry" "stream not open"
| read_directory_entry (DS { nextFile=REF NULL, ... } ) = NULL
| read_directory_entry (DS { hndlptr, nextFile=nF as REF (THE name), ... } ) =
(nF := W32FS::findNextFile *hndlptr;
case name of
"" => NULL
| _ => THE name)
read_directory_entry = /* ospath::make_canonical o */ read_directory_entry
fun close_directory_stream (DS { isOpen=REF FALSE, ... } ) = ()
| close_directory_stream (DS { hndlptr, isOpen, ... } ) =
(isOpen := FALSE;
if W32FS::findClose *hndlptr
then ()
else
rse "close_directory_stream" "win32: unexpected close_directory_stream failure")
fun rewind_directory_stream (DS { isOpen=REF FALSE, ... } ) =
rse "rewind_directory_stream" "rewinddir on closed directory stream"
| rewind_directory_stream (d as DS { hndlptr, query, isOpen, nextFile } ) =
let close_directory_stream d
my (h, firstName) = W32FS::findFirstFile query
in
if not (W32G::isValidHandle h) then
rse "rewind_directory_stream" "cannot rewind to first file"
else
(hndlptr := h;
nextFile := firstName;
isOpen := TRUE)
end
fun change_directory s =
if W32FS::setCurrentDirectory s then ()
else rse "change_directory" "cannot change directory"
current_directory = ospath::make_canonical o W32FS::getCurrentDirectory'
fun make_directory s =
if W32FS::createDirectory' s then ()
else rse "make_directory" "cannot create directory"
fun remove_directory s =
if W32FS::removeDirectory s then ()
else rse "remove_directory" "cannot remove directory"
fun is_symbolic_link _ = FALSE
fun read_symbolic_link _ = rse "read_symbolic_link" "OS does not have links"
fun exists s = W32FS::getFileAttributes s != NULL
fun full_path "" = current_directory ()
| full_path s =
if exists s then W32FS::getFullPathName' s
else raise exception RUNTIME_EXCEPTION("full_path: cannot generate full path", NULL)
full_path = ospath::make_canonical o full_path
fun real_path p =
if ospath::is_absolute p then full_path p
else ospath::make_relative { path=full_path p, relative_to=full_path (current_directory()) }
fun file_size s =
case W32FS::getLowFileSizeByName s of
THE w => W32G::unt::toInt w
| NULL => rse "file_size" "cannot get size"
fun intToMonth 1 = date::Jan
| intToMonth 2 = date::Feb
| intToMonth 3 = date::Mar
| intToMonth 4 = date::Apr
| intToMonth 5 = date::May
| intToMonth 6 = date::Jun
| intToMonth 7 = date::Jul
| intToMonth 8 = date::Aug
| intToMonth 9 = date::Sep
| intToMonth 10 = date::Oct
| intToMonth 11 = date::Nov
| intToMonth 12 = date::Dec
| intToMonth _ = rse "intToMonth" "not in 1-12"
fun monthToInt date::Jan = 1
| monthToInt date::Feb = 2
| monthToInt date::Mar = 3
| monthToInt date::Apr = 4
| monthToInt date::May = 5
| monthToInt date::Jun = 6
| monthToInt date::Jul = 7
| monthToInt date::Aug = 8
| monthToInt date::Sep = 9
| monthToInt date::Oct = 10
| monthToInt date::Nov = 11
| monthToInt date::Dec = 12
fun intToWeekDay 0 = date::Sun
| intToWeekDay 1 = date::MON
| intToWeekDay 2 = date::TUE
| intToWeekDay 3 = date::Wed
| intToWeekDay 4 = date::Thu
| intToWeekDay 5 = date::Fri
| intToWeekDay 6 = date::Sat
| intToWeekDay _ = rse "intToWeekDay" "not in 0-6"
fun weekDayToInt date::Sun = 0
| weekDayToInt date::MON = 1
| weekDayToInt date::TUE = 2
| weekDayToInt date::Wed = 3
| weekDayToInt date::Thu = 4
| weekDayToInt date::Fri = 5
| weekDayToInt date::Sat = 6
fun last_file_modification_time s = (case W32FS::getFileTime' s
of (THE info) =>
date::toTime (date::date {
year = info.year,
month = intToMonth info.month,
day = info.day,
hour = info.hour,
minute = info.minute,
second = info.second,
offset = NULL
} )
| NULL => rse "last_file_modification_time" "cannot get file time"
) # end case
fun set_last_file_modification_time (s, t) = let
date = date::fromTimeLocal (case t of NULL => time::now() | THE t' => t')
date' = {
year = date::year date,
month = monthToInt (date::month date),
dayOfWeek = weekDayToInt (date::weekDay date),
day = date::day date,
hour = date::hour date,
minute = date::minute date,
second = date::second date,
milliSeconds = 0
}
in
if W32FS::setFileTime' (s, date')
then ()
else rse "set_last_file_modification_time" "cannot set time"
end
fun remove_file s
=
if W32FS::deleteFile s then ()
else rse "remove" "cannot remove file"
fun rename_file { from: String, to: String }
=
let fun rse' s = rse "rename" s
not (exists from) and
rse' ("cannot find from='" + from + "'")
same = (exists to) and
(full_path from = full_path to)
in
if not same then
(if (exists to) then
remove to
except _ => rse' "cannot remove 'to'"
if W32FS::moveFile (from, to) then ()
else rse' "moveFile failed")
else ()
end
enum Access_Mode = MAY_READ | MAY_WRITE | MAY_EXECUTE
strUpper =
s::translate (\\ c => s::str (if c::is_alpha c then c::to_upper c else c))
fun access (s,[]) = exists s
| access (s, al) =
case W32FS::getFileAttributes s of
NULL =>
rse "access" "cannot get file attributes"
| THE aw =>
let fun aux MAY_READ = TRUE
| aux MAY_WRITE =
W32G::unt::bitwise_and (W32FS::FILE_ATTRIBUTE_READONLY, aw) = 0w0
| aux MAY_EXECUTE =
(case .ext (winix_path::split_base_ext s) of
THE ext => (case (strUpper ext) of
("EXE" | "COM" |
"CMD" | "BAT" ) => TRUE
| _ => FALSE)
| NULL => FALSE)
in list::all aux al
end
fun tmpName () =
case W32FS::getTempFileName' () of
NULL => rse "tmpName" "cannot obtain tmp filename"
| THE s => s
type file_id = String
fun fileId s =
full_path s
except (RUNTIME_EXCEPTION _) =>
rse "fileId" "cannot create file id"
fun hash (fid: file_id)
=
unt::from_int
(list::fold_forward (\\ (a, b) => (char::to_int a + b) except _ => 0) 0
(string::explode fid))
compare = string::compare
};
end;