PreviousUpNext

15.4.1241  src/lib/std/src/win32/os-file-system.pkg

## 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;



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext