Patch title: Release 93 bulk changes
Abstract:
File: /protocol/smb/client2.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/language/os.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/multi.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/language/stream/flushmode.pli"
module "/pliant/language/stream/listmode.pli"
module "/pliant/language/os/linux64.pli"
module "/pliant/language/schedule/namedsem.pli"

constant smb_library (shunt (file_query "file:/usr/lib/libsmbclient.so" standard)=success "/usr/lib/libsmbclient.so" "/lib/libsmbclient.so")
constant getdents_buffer_size 4096
constant advancedlocking true
constant trace2 false

(gvar TraceSlot smb_client_trace) configure "SMB client"


gvar Sem sem
if advancedlocking
  gvar NamedSem hsem

function lock
  sem request

function unlock
  sem release

function lock2 host
  arg Str host
  if advancedlocking
    sem rd_request
    hsem request host
  else
    sem request

function unlock2 host
  arg Str host
  if advancedlocking
    hsem release host
    sem rd_release
  else
    sem release


#----------------------------------------------------------------------
# Samba client library bindings



type SMBCCTX
  field Int debug
  field Address netbios_name
  field Address workgroup
  field Address user
  field Int timeout
  field Address open
  field Address creat
  field Address read
  field Address write
  field Address unlink
  field Address rename
  field Address lseek
  field Address stat
  field Address fstat
  field Address close
  field Address opendir
  field Address closedir
  field Address readdir
  field Address getdents
  field Address mkdir
  field Address rmdir
  field Address telldir
  field Address lseekdir
  field Address fstatdir
  field Address chmod
  field Address utimes
  field Address setxattr
  field Address getxattr
  field Address removexattr
  field Address listxattr
  field Address print_file
  field Address open_print_job
  field Address list_print_jobs
  field Address unlink_print_job
  field Address auth_fn
  # ...

function smbc_new_context -> ctx
  arg_RW SMBCCTX ctx
  external smb_library "smbc_new_context"

function smbc_init_context ctx
  arg_rw SMBCCTX ctx
  external smb_library "smbc_init_context"

function smbc_free_context ctx shutdown
  arg_rw SMBCCTX ctx ; arg Int shutdown
  external smb_library "smbc_free_context"


gvar Pointer:SMBCCTX ctx


function smbc_open ctx url flags mode f -> fd
  arg_rw SMBCCTX ctx ; arg CStr url ; arg Int flags mode ; arg Function f ; arg Address fd
  external_calling_convention
  indirect

function smbc_read ctx fd buf size f -> red
  arg_rw SMBCCTX ctx ; arg Address fd ; arg Address buf ; arg Int size  ; arg Function f ; arg Int red
  external_calling_convention
  indirect

function smbc_write ctx fd buf size f -> written
  arg_rw SMBCCTX ctx ; arg Address fd ; arg Address buf ; arg Int size ; arg Function f ; arg Int written
  external_calling_convention
  indirect

function smbc_close ctx fd f -> err
  arg_rw SMBCCTX ctx ; arg Address fd ; arg Function f ; arg Int err
  external_calling_convention
  indirect


type smbc_dirent
  field uInt32 smbc_type
  field uInt32 dirlen
  field uInt32 commentlen
  field Address comment
  field uInt32 namelen

function smbc_opendir ctx url f -> dh
  arg_rw SMBCCTX ctx ; arg CStr url ; arg Function f ; arg Address dh
  external_calling_convention
  indirect

function smbc_readdir ctx dh f -> dirent
  arg_rw SMBCCTX ctx ; arg Address dh ; arg Function f ; arg_RW smbc_dirent dirent
  external_calling_convention
  indirect

function smbc_getdents ctx dh buf size f -> nb
  arg_rw SMBCCTX ctx ; arg Address dh ; arg Address buf ; arg Int size ; arg Function f ; arg Int nb
  external_calling_convention
  indirect

function smbc_closedir ctx dh f -> err
  arg_rw SMBCCTX ctx ; arg Address dh ; arg Function f ; arg Int err
  external_calling_convention
  indirect

function smbc_stat ctx url stat f -> err
  arg_rw SMBCCTX ctx ; arg CStr url ; arg_w os_stat64 stat ; arg Function f ; arg Int err
  external_calling_convention
  indirect


function smbc_unlink ctx url f -> err
  arg_rw SMBCCTX ctx ; arg CStr url ; arg Function f ; arg Int err
  external_calling_convention
  indirect

function smbc_rename ctx oldurl newurl f -> err
  arg_rw SMBCCTX ctx ; arg CStr oldurl newurl ; arg Function f ; arg Int err
  external_calling_convention
  indirect

function smbc_mkdir ctx url f -> err
  arg_rw SMBCCTX ctx ; arg CStr url ; arg Function f ; arg Int err
  external_calling_convention
  indirect

function smbc_rmdir ctx url f -> err
  arg_rw SMBCCTX ctx ; arg CStr url ; arg Function f ; arg Int err
  external_calling_convention
  indirect

function smbc_utimes ctx url time f -> err
  arg_rw SMBCCTX ctx ; arg CStr url ; arg Function f ; arg os_timeval time ; arg Int err
  external_calling_convention
  indirect


#----------------------------------------------------------------------
# Pliant filesystem


type SmbFileSystem
  void
FileSystem maybe SmbFileSystem


type SmbStreamDriver
  field Address handle
  field Str host
StreamDriver maybe SmbStreamDriver


method fs query filename options flags info -> status
  arg_rw SmbFileSystem fs ; arg Str filename options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status
  smb_client_trace trace "query " filename
  if not (filename parse "//" any:(var Str host) "/" any:(var Str volume) "/" any)
    return failure:"server or volume is missing"
  lock
  (var Function f) executable := ctx stat
  var Int err := smbc_stat ctx "smb:"+filename (var os_stat64 stat) f
  unlock
  if err=0
    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
    status := success
  else
    status := failure


method fs configure filename options command -> status
  arg_rw SmbFileSystem fs ; arg Str filename options command ; arg ExtendedStatus status
  smb_client_trace trace "configure " filename " " command
  if not (filename parse "//" any:(var Str host) "/" any:(var Str volume) "/" any)
    return failure:"server or volume is missing"
  status := success
  var CBool some := false
  lock
  if (command option "mkdir")
    some := true
    (var Function f) executable := ctx mkdir
    if (smbc_mkdir ctx "smb:"+filename f)<>0
      status := failure
  if { var DateTime dt := command option "datetime" DateTime ; dt=defined }
    some := true
    var os_timeval time
    time tv_sec := cast dt:seconds-os_datetime_origin:seconds uInt32
    time tv_usec := 0
    (var Function f) executable := ctx utimes
    if (smbc_utimes ctx "smb:"+filename time f)<>0
      status := failure
  if { var Str target := command option "move" Str ; target<>"" }
    some := true
    (var Function f) executable := ctx rename
    if (smbc_rename ctx "smb:"+filename "smb:"+target f)<>0
      if not (command option "force") or { (var Function f) executable := ctx unlink ; (smbc_unlink ctx target f)<>0 } or { (var Function f) executable := ctx rename ; (smbc_rename ctx filename target f)<>0 }
        status := failure
  if (command option "delete")
    some := true
    (var Function f) executable := ctx unlink
    if (smbc_unlink ctx "smb:"+filename f)<>0
      status := failure
  if (command option "rmdir")
    some := true
    (var Function f) executable := ctx rmdir
    if (smbc_rmdir ctx "smb:"+filename f)<>0
      status := failure
  unlock
  if not some
    status := failure


method fs list path options flags files -> supported_flags
  oarg_rw SmbFileSystem fs ; arg Str path options ; arg_rw List files ; arg Int flags supported_flags
  supported_flags := extended
  smb_client_trace trace "list " path
  if not (path parse "//" any:(var Str host) "/" any:(var Str volume) "/" any)
    return failure:"server or volume is missing"
  lock
  (var Function f) executable := ctx opendir
  var Address fd := smbc_opendir ctx "smb:"+path f
  if fd=null and path:len>0 and (path path:len-1)="/"
    fd := smbc_opendir ctx "smb:"+(path 0 path:len-1) f
  unlock
  if fd=null
    if (flags .and. notifyfailure)<>0
      var Link:FileInfo info :> new FileInfo
      info name := path
      info status := failure
      files append addressof:info
    return
  if getdents_buffer_size<>0
    var Address buffer := memory_allocate getdents_buffer_size null
    (var Function f) executable := ctx getdents
    while { lock2 host ; var Int size := smbc_getdents ctx fd buffer getdents_buffer_size f ; unlock2 host ; size>0 }
      var Int offset := 0
      while offset<size
        var Int dirlen := (buffer translate Byte offset) map Int 1
        var Int namelen := (buffer translate Byte offset) map Int 4
        (var Str filename) set (buffer translate Byte offset+5*Int:size) namelen-1 false
        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 += dirlen
    memory_free buffer
  else
    (var Function f) executable := ctx readdir
    while { lock2 host ; var Pointer:smbc_dirent dirent :> smbc_readdir ctx fd f ; unlock2 host ; exists dirent }
      (var Str filename) set (addressof:dirent translate smbc_dirent) (max dirent:namelen-1 0) false
      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
        # console "-> " filename " (" filename:len ") -> " info:name " " (shunt info:status=success "ok" "failed") eol
  lock
  (var Function f) executable := ctx closedir
  var Int err := smbc_closedir ctx fd f
  unlock
  if err<>0
    if (flags .and. notifyfailure)<>0
      var Link:FileInfo info :> new FileInfo
      info name := path
      info status := failure 
      files append addressof:info
    

method fs open name options flags stream support -> status
  arg_rw SmbFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  smb_client_trace trace "open " name
  if not (name parse "//" any:(var Str host) "/" any:(var Str volume) "/" any)
    return failure:"server or volume is missing"
  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
  access += os_O_LARGEFILE
  var Int mode := options option "file_mode" Int
  if mode=undefined
    mode := os_default_file_mode
  lock
  (var Function f) executable := ctx open
  var Address handle := smbc_open ctx "smb:"+name access mode f
  unlock
  if handle<>null
    var Pointer:SmbStreamDriver nd :> new SmbStreamDriver
    nd handle := handle
    nd host := host
    stream stream_driver :> nd
    status := success
  else
    status := failure


method nd read buf mini maxi -> red
  arg_rw SmbStreamDriver nd ; arg Address buf ; arg Int mini maxi red
  lock2 nd:host
  (var Function f) executable := ctx read
  red := smbc_read ctx nd:handle buf maxi f
  unlock2 nd:host
  red := max red 0
  if trace2 or red=0
    smb_client_trace trace "read " mini " " maxi " -> " red


method nd write buf mini maxi -> written
  arg_rw SmbStreamDriver nd ; arg Address buf ; arg Int mini maxi written
  lock2 nd:host
  (var Function f) executable := ctx write
  written := smbc_write ctx nd:handle buf maxi f
  unlock2 nd:host
  written := max written 0
  if trace2 or written=0
    smb_client_trace trace "write " mini " " maxi " -> " written


method nd close -> status
  arg_rw SmbStreamDriver nd ; arg ExtendedStatus status
  smb_client_trace trace "close" 
  lock
  (var Function f) executable := ctx close
  status := shunt (smbc_close ctx nd:handle f)=0 success failure
  unlock


function auth srv shr wg wglen un unlen pw pwlen
  arg CStr srv shr
  arg Address wg ; arg Int wglen
  arg Address un ; arg Int unlen
  arg Address pw ; arg Int pwlen
  external_calling_convention

gvar SmbFileSystem smb_file_system
ctx :> smbc_new_context
if exists:ctx
  # ctx debug := 9
  ctx auth_fn := (the_function auth CStr CStr Address Int Address Int Address Int):executable
  if exists:(smbc_init_context ctx)
    entry_root addressof:(the_function auth CStr CStr Address Int Address Int Address Int)
    pliant_multi_file_system mount "smb:" "" smb_file_system
  else
    smbc_free_context ctx 1