Patch title: seek implentation under Win32
Abstract:
File: /pliant/language/stream/native.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

scope "/pliant/language/stream/"
module "ring.pli"
module "/pliant/language/os/socket.pli"


constant getdents_buffer_size 4096
constant readlink_buffer_size 256
constant wait_minimal_delay 0.01
constant wait_maximal_delay 15


#----------------------------------------------------------------------
# os native stream driver

type NativeFileSystem
  void
FileSystem maybe NativeFileSystem

type NativeStreamDriver
  field Int handle
  field Float timeout
StreamDriver maybe NativeStreamDriver


if os_api="win32"
  constant os_datetime_origin (datetime 1601 1 1 0 0 0 0)

function valid filename options -> v
  arg Str filename options ; arg CBool v
  if (filename search ".." -1)<>(-1) and not (options option "backward_allowed")
    return false
  if pliant_debugging_level>=2 and (filename search "//" -1)<>(-1)
    return false
  v := true


method fs query filename options flags info -> status
  arg_rw NativeFileSystem fs ; arg Str filename options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status
  if not (valid filename options)
    return failure
  if (flags .and. level_flags)>=extended
    info:options += " os_name "+string:filename
  if os_api="linux" or os_api="posix"
    var Int err := os_stat filename (var os_stat stat)
    if err<>0
      if (flags .and. deadlinks)=0
        return failure
      if (os_lstat filename stat)<>0
        return failure
      if (flags .and. level_flags)>=extended
        info options += " deadlink"
    info size := stat st_size
    info:datetime seconds := os_datetime_origin:seconds + stat:st_mtime
    if (os_S_ISDIR stat:st_mode) and (filename:len=0 or filename:(filename:len-1)<>"/")
      info:name resize info:name:len+1
      info:name info:name:len-1 := "/":0
    if (flags .and. level_flags)>=extended
      info options += " mode "+('convert to string' stat:st_mode)
      info options += " uid "+('convert to string' stat:st_uid)
      info options += " gid "+('convert to string' stat:st_gid)
      (var DateTime dt) seconds := os_datetime_origin:seconds+stat:st_atime
      dt split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction)
      info options += " read_datetime "+string:year+"/"+(right string:month 2 "0")+"/"+(right string:day 2 "0")+" "+(right string:hour 2 "0")+":"+(right string:minute 2 "0")+":"+(right string:second 2 "0")
      if os_api="linux"
        info options += " device "+('convert to string' stat:st_dev)
      var Address buffer2 := memory_allocate readlink_buffer_size null
      var Int size2 := os_readlink filename buffer2 readlink_buffer_size
      if size2>=0
        var Str link ; link set buffer2 size2 false
        info options += " link "+string:link
      memory_free buffer2
    status := success
  eif os_api="win32"
    var Str wname := replace filename "/" "\"
    if filename:len>1 and (filename filename:len-1)="/":0
      if not (filename:len>2 and (filename filename:len-2)=":":0)
        wname := wname 0 wname:len-1
    var Int handle := os_FindFirstFile wname (var os_FIND_DATA data)
    if handle=os_INVALID_HANDLE_VALUE
      return failure
    if (data:dwFileAttributes .and. os_FILE_ATTRIBUTE_DIRECTORY)<>0 and (filename:len=0 or filename:(filename:len-1)<>"/")
      info name += "/"
    info size := data nFileSizeLow
    info:datetime seconds := os_datetime_origin:seconds + data:ftLastWriteTime:dwLowDateTime*(100*0.1^9)+data:ftLastWriteTime:dwHighDateTime*(100*0.1^9*2.0^32)
    os_FindClose handle
    status := success
  eif os_api="os2"
    var Str oname := replace filename "/" "\"
    if filename:len>1 and (filename filename:len-1)="/":0
      if not (filename:len>2 and (filename filename:len-2)=":":0)
        oname := oname 0 oname:len-1
    var Int handle := 1 ; var Int count := 1
    var Int err := os_DosFindFirst oname handle FILE_DIRECTORY addressof:(var FILEFINDBUF3 data) FILEFINDBUF3:size count FIL_STANDARD
    if err<>0 or count=0
      return failure
    if (data:attrFile .and. FILE_DIRECTORY)<>0 and (filename:len=0 or filename:(filename:len-1)<>"/")
      info name += "/"
    info size := data cbFile
    var FDATE d := data fdateLastWrite ; var FTIME t := data ftimeLastWrite
    info:datetime := datetime 1980+d:year d:month d:day t:hours t:minutes t:twosecs*2 0
    os_DosFindClose handle
    status := success
  else
    error "file_query is not implemented under "+os_api
    status := failure


method fs configure filename options command -> status
  arg_rw NativeFileSystem fs ; arg Str filename options command ; arg ExtendedStatus status
  if not (valid filename options)
    return failure
  if os_api="linux" or os_api="posix"
    status := success
    var CBool some := false
    if (command option "mkdir")
      some := true
      var Int mode := options option "directory_mode" Int
      if mode=undefined
        mode := os_default_directory_mode
      if (os_mkdir filename mode)<>0
        status := failure
    if { var Str link := command option "link" Str ; link<>"" }
      some := true
      var Str target := shunt filename:len<>0 and filename:(filename:len-1)="/" (filename 0 filename:len-1) filename
      if (os_symlink link target)<>0
        if not (command option "force") or (os_unlink target)<>0 or (os_symlink link target)<>0
          status := failure
    if { var DateTime dt := command option "datetime" DateTime ; dt=defined }
      some := true
      var os_utimbuf buf
      buf modtime := cast dt:seconds-os_datetime_origin:seconds uInt32
      buf actime := buf modtime
      if (os_utime filename buf)<>0
        status := failure
    var Int uid := command option "uid" Int
    var Int gid := command option "gid" Int
    if uid=defined or gid=defined
      some := true
      if (os_lchown filename (shunt uid=defined uid -1) (shunt gid=defined gid -1))<>0
        status := failure
    if { var Int mode := command option "mode" Int ; mode=defined }
      some := true
      if (os_chmod filename mode)<>0
        status := failure
    if { var Str clone := command option "clone" Str ; clone<>"" }
      some := true
      if (os_link filename clone)<>0
        if not (command option "force") or (os_unlink clone)<>0 or (os_link filename clone)<>0
          status := failure
    if { var Str target := command option "move" Str ; target<>"" }
      some := true
      if (os_rename filename target)<>0
        if not (command option "force") or (os_unlink target)<>0 or (os_rename filename target)<>0
          status := failure
    if (command option "delete")
      some := true
      if true
        if os_unlink:filename<>0
          status := failure
      else
        var Str namez := filename
        if namez:len>1 and (namez namez:len-1)="/"
          namez := namez 0 namez:len-1
        if (os_unlink namez)<>0
          status := failure
    if (command option "rmdir")
      some := true
      if (os_rmdir filename)<>0
        status := failure
    if (command option "flush")
      some := true
      stream_lock_handle
      var Int fd := os_open filename os_O_RDONLY 0
      stream_unlock_handle fd
      if fd<0
        status := failure
      else
        if os_fsync:fd<>0
          status := failure
        os_close fd
    if not some
      status := failure
  eif os_api="win32"
    var Str namez := replace filename "/" "\"
    if namez:len>1 and (namez namez:len-1)="\"
      namez := namez 0 namez:len-1
    status := success
    var CBool some := false
    if command="mkdir"
      some := true
      if not (os_CreateDirectory namez null)
        status := failure
    if command="delete"
      some := true
      if not (os_DeleteFile namez)
        status := failure
    if command="rmdir"
      some := true
      if not (os_RemoveDirectory namez)
        status := failure
    if not some
      status := failure
  eif os_api="os2"
    var Str namez := replace filename "/" "\"
    if namez:len>1 and (namez namez:len-1)="\"
      namez := namez 0 namez:len-1
    status := success
    var CBool some := false
    if command="mkdir"
      some := true
      if (os_DosCreateDir namez null)<>0
        status := failure
    if command="delete"
      some := true
      if (os_DosDelete namez)<>0
        status := failure
    if command="rmdir"
      some := true
      if (os_DosDeleteDir namez)<>0
        status := failure
    if not some
      status := failure
  else
    status := failure


method fs list path options flags files -> supported_flags
  oarg_rw NativeFileSystem fs ; arg Str path options ; arg Int flags supported_flags ; arg_rw List files
  supported_flags := extended
  if not (valid path options) or path:len=0 or (path path:len-1 1)<>"/"
    return failure
  if os_api="linux"
    stream_lock_handle
    var Int fd := os_open path os_O_RDONLY 0
    stream_unlock_handle fd
    if fd<0
      return
    var Address buffer := memory_allocate getdents_buffer_size null
    while { var Int size := os_getdents fd buffer getdents_buffer_size ; size>0 }
      var Int offset := 0
      while offset<size
        var Pointer:os_dirent de :> (buffer translate Byte offset) map os_dirent
        (var CStr cname) characters := addressof de:d_name
        var Str filename := cname
        if filename<>"." and filename<>".."
          var Link:FileInfo info :> new FileInfo
          info name := path+filename
          info size := undefined
          info datetime := undefined
          info options := ""
          info status := fs query path+filename options flags info
          files append addressof:info
        offset += de:d_reclen
    memory_free buffer
    os_close fd
  eif os_api="posix"
    # stream_lock_handle
    var Address fd := os_opendir path
    # stream_unlock_handle fd
    if fd=null
      return
    while { var Pointer:os_dirent de :> os_readdir fd ; addressof:de<>null }
      (var CStr cname) characters := addressof de:d_name
      var Str filename := cname
      if filename<>"." and filename<>".."
        var Link:FileInfo info :> new FileInfo
        info name := path+filename
        info size := undefined
        info datetime := undefined
        info options := ""
        info status := fs query path+filename options flags info
        files append addressof:info
    os_closedir fd
  eif os_api="win32"
    var Str wname := (replace path "/" "\")+"*.*"
    var Int handle := os_FindFirstFile wname (var os_FIND_DATA data)
    var CBool more := handle<>os_INVALID_HANDLE_VALUE
    while more
      (var CStr cname) characters := addressof data:cFileName
      var Str filename := cname
      if filename<>"." and filename<>".."
        var Link:FileInfo info :> new FileInfo
        info name := path+filename
        if (data:dwFileAttributes .and. os_FILE_ATTRIBUTE_DIRECTORY)<>0 and (info:name:len=0 or info:name:(info:name:len-1)<>"/")
          info name += "/"
        info size := data nFileSizeLow
        info:datetime seconds := os_datetime_origin:seconds + data:ftLastWriteTime:dwLowDateTime*(100*0.1^9)+data:ftLastWriteTime:dwHighDateTime*(100*0.1^9*2.0^32)
        files append addressof:info
      more := os_FindNextFile handle data
    os_FindClose handle
  eif os_api="os2"
    var Str oname := (replace path "/" "\")+"*.*"
    var Int size := 4096 ; var Address buf := memory_allocate size null
    var Int handle := 1 ; var Int count := size
    var Int err := os_DosFindFirst oname handle FILE_DIRECTORY buf size count FIL_STANDARD
    while err=0 and count<>0
      var Pointer:FILEFINDBUF3 data :> buf map FILEFINDBUF3
      for (var Int i) 0 count-1
        (var Str filename) set (memory_allocate data:cchName addressof:filename) data:cchName true
        memory_copy (addressof data:achName) filename:characters data:cchName
        if filename<>"." and filename<>".."
          var Link:FileInfo info :> new FileInfo
          info name:= path+filename
          if (data:attrFile .and. FILE_DIRECTORY)<>0 and (filename:len=0 or filename:(filename:len-1)<>"/")
            info name += "/"
          info size := data cbFile
          var FDATE d := data fdateLastWrite ; var FTIME t := data ftimeLastWrite
          info:datetime := datetime 1980+d:year d:month d:day t:hours t:minutes t:twosecs*2 0
          files append addressof:info
        data :> (addressof:data translate Byte data:oNextEntryOffset) map FILEFINDBUF3
      err := os_DosFindNext handle buf size count
    memory_free buf
    os_DosFindClose handle
  else
    error "file_list is not implemented under "+os_api


method fs open name options flags stream support -> status
  arg_rw NativeFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  if not (valid name options)
    return failure
  if os_api="linux" or os_api="posix"
    var Int access
    if (flags .and. append)=append
      access := os_O_RDWR+os_O_CREAT+os_O_APPEND
    eif (flags .and. in_out)=in
      access := os_O_RDONLY
    eif (flags .and. in_out)=out
      access := os_O_RDWR+os_O_CREAT+os_O_TRUNC
    else
      check (flags .and. in_out)=in_out
      access := os_O_RDWR+os_O_CREAT
    if (options option "timeout" Float)=defined
      access += os_O_NONBLOCK
    var Int mode := options option "file_mode" Int
    if mode=undefined
      mode := os_default_file_mode
    stream_lock_handle
    var Int handle := os_open name access mode
    stream_unlock_handle handle
  eif os_api="win32"
    var uInt access := (shunt (flags .and. in)<>0 os_GENERIC_READ 0) .or. (shunt (flags .and. out)<>0 os_GENERIC_WRITE 0)
    var uInt share :=  os_FILE_SHARE_READ .or. os_FILE_SHARE_WRITE
    var uInt creation := shunt ((flags .and. in_out)=in_out or (flags .and. append)<>0) os_OPEN_ALWAYS (flags .and. out)<>0 os_CREATE_ALWAYS os_OPEN_EXISTING
    var uInt wflags := os_FILE_ATTRIBUTE_NORMAL .or. (shunt (flags .and. seekmuch)<>0 os_FILE_FLAG_RANDOM_ACCESS os_FILE_FLAG_SEQUENTIAL_SCAN)
    if (options option "win32_device")
      share := 0 ; creation := os_OPEN_EXISTING ; wflags := 0
    var Int handle := os_CreateFile name access share null creation wflags null
    if (flags .and. append)<>0
      var uInt lpDistanceToMoveHigh := 0
      os_SetFilePointer handle 0 lpDistanceToMoveHigh os_FILE_END
  eif os_api="os2"
    var Int openflags openmode action handle
    if (flags .and. in_out)=in
      openflags := OPEN_ACTION_FAIL_IF_NEW+OPEN_ACTION_OPEN_IF_EXISTS
      openmode := OPEN_ACCESS_READONLY+OPEN_SHARE_DENYWRITE
    eif (flags .and. in_out)=out
      openflags := OPEN_ACTION_CREATE_IF_NEW+OPEN_ACTION_REPLACE_IF_EXISTS
      openmode := OPEN_ACCESS_WRITEONLY+OPEN_SHARE_DENYREADWRITE
    else
      check (flags .and. in_out)=in_out
      openflags := OPEN_ACTION_CREATE_IF_NEW+OPEN_ACTION_OPEN_IF_EXISTS
      openmode := OPEN_ACCESS_READWRITE+OPEN_SHARE_DENYREADWRITE
    if (flags .and. nocache)<>0
      openmode := openmode + OPEN_FLAGS_NO_CACHE
    openmode := openmode + OPEN_FLAGS_SEQUENTIAL
    var Int try_count := 1 ; var Int err := ERROR_TOO_MANY_OPEN_FILES
    var Str os2name := replace name "/" "\"
    while try_count>=0 and err=ERROR_TOO_MANY_OPEN_FILES
      err := os_DosOpen os2name handle action 0 FILE_NORMAL openflags openmode null
      if err<>0
        handle := -1
      if err=ERROR_TOO_MANY_OPEN_FILES
        var Int add := 5 ; var Int nb
        os_DosSetRelMaxFH add nb
      try_count := try_count-1
    if (flags .and. append)<>0
      os_DosSetFilePtr handle 0 FILE_END (var uInt drop)
  else
    error "not implemented under "+os_api
    var Int handle := 0
  if handle>=0
    var Pointer:NativeStreamDriver nd :> new NativeStreamDriver
    nd handle := handle
    nd timeout := options option "timeout" Float
    stream stream_driver :> nd
    stream stream_handle := handle
    status := success
  else
    status := failure


method nd read buf mini maxi -> red
  arg_rw NativeStreamDriver nd ; arg Address buf ; arg Int mini maxi red
  if os_api="linux" or os_api="posix"
    red := os_read nd:handle buf maxi
    if red=(-os_EAGAIN) and nd:timeout=defined
      var DateTime dt := datetime ; var Int lap := 0 ; var Float delay := wait_minimal_delay
      while red=(-os_EAGAIN) and (lap=0 or datetime:seconds-dt:seconds<nd:timeout)
        sleep delay
        lap += 1
        if delay<nd:timeout/8 and delay<wait_maximal_delay
          delay *= 2
        red := os_read nd:handle buf mini
    red := max red 0
  eif os_api="win32"
    if not (os_ReadFile nd:handle buf maxi red null)
      red := 0
  eif os_api="os2"
    if (os_DosRead nd:handle buf maxi red)<>0
      red := 0
  else
    error "not implemented under "+os_api
    red := 0

method nd write buf mini maxi -> written
  arg_rw NativeStreamDriver nd ; arg Address buf ; arg Int mini maxi written
  if os_api="linux" or os_api="posix"
    written := os_write nd:handle buf maxi
    if written=(-os_EAGAIN) and nd:timeout=defined
      var DateTime dt := datetime ; var Int lap := 0 ; var Float delay := wait_minimal_delay
      while written=(-os_EAGAIN) and (lap=0 or datetime:seconds-dt:seconds<nd:timeout)
        sleep delay
        lap += 1
        if delay<nd:timeout/8 and delay<wait_maximal_delay
          delay *= 2
        written := os_write nd:handle buf mini
    written := max written 0
  eif os_api="win32"
    if not (os_WriteFile nd:handle buf maxi written null)
      written := 0
  eif os_api="os2"
    if (os_DosWrite nd:handle buf maxi written)<>0
      written := 0
  else
    error "not implemented under "+os_api
    written := 0

method nd flush level -> status
  arg_rw NativeStreamDriver nd ; arg Int level ; arg Status status
  if level=end
    return success
  if os_api="linux" or os_api="posix"
    if level<sync
      status := success
    else
      status := shunt (os_fsync nd:handle)=0 success failure
  eif os_api="win32"
    status := success
  eif os_api="os2"
    if level<sync
      status := success
    else
      status := shunt (os_DosResetBuffer nd:handle)=0 success failure
  else
    error "not implemented under "+os_api
    status := failure

method nd close -> status
  arg_rw NativeStreamDriver nd ; arg ExtendedStatus status
  if os_api="linux" or os_api="posix"
    status := shunt (os_close nd:handle)=0 success failure
  eif os_api="win32"
    status := shunt (os_CloseHandle nd:handle) success failure
  eif os_api="os2"
    status := shunt (os_DosClose nd:handle)=0 success failure
  else
    error "not implemented under "+os_api
    status := failure

method nd query command stream answer -> status
  oarg_rw NativeStreamDriver nd ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status
  if os_api="linux" and command="seek"
    status := shunt (os_llseek nd:handle 0 0 addressof:(var uInt64 result) os_SEEK_CUR)=0 success failure
    answer := string (cast result Intn)+((cast stream:stream_read_cur Int).-.(cast stream:stream_read_stop Int))+((cast stream:stream_write_cur Int).-.(cast stream:stream_write_buf Int))
  eif os_api="posix" and command="seek"
    var Int pos := os_lseek nd:handle 0 os_SEEK_CUR
    status := shunt pos>=0 success failure
    answer := string pos+((cast stream:stream_read_cur Int).-.(cast stream:stream_read_stop Int))+((cast stream:stream_write_cur Int).-.(cast stream:stream_write_buf Int))
  eif os_api="win32" and command="seek"
    var Int pos := os_SetFilePointer nd:handle 0 (null map uInt) os_FILE_CURRENT
    status := shunt pos>=0 success failure
    answer := string pos+((cast stream:stream_read_cur Int).-.(cast stream:stream_read_stop Int))+((cast stream:stream_write_cur Int).-.(cast stream:stream_write_buf Int))
  else
    status := failure

method nd configure command stream -> status
  arg_rw NativeStreamDriver nd ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status
  if os_api="linux" and (command parse word:"seek" (var Intn pos))
    if (stream:stream_flags .and. out)<>0
      stream flush anytime
    stream stream_read_cur := stream stream_read_stop
    var uInt high := cast pos\(cast 2 Intn)^32 uInt
    var uInt low := cast pos%(cast 2 Intn)^32 uInt
    check high*(cast 2 Intn)^32+low=pos
    status := shunt (os_llseek nd:handle high low addressof:(var uInt64 result) os_SEEK_SET)=0 success failure
  eif os_api="posix" and (command parse word:"seek" (var Int pos))
    if (stream:stream_flags .and. out)<>0
      stream flush anytime
    stream stream_read_cur := stream stream_read_stop
    status := shunt (os_lseek nd:handle pos os_SEEK_SET)>=0 success failure
  eif os_api="win32" and (command parse word:"seek" (var Int pos))
    if (stream:stream_flags .and. out)<>0
      stream flush anytime
    stream stream_read_cur := stream stream_read_stop
    status := shunt (os_SetFilePointer nd:handle (cast pos uInt) (null map uInt) os_FILE_BEGIN)<>(-1) success failure
  else
    status=failure


export NativeFileSystem