Patch title: Release 92 bulk changes
Abstract:
File: /admin/file.pli
Key:
    Removed line
    Added line
abstract
  [Files handling (listing, copying, ...)] ; eol

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

submodule "/pliant/language/stream/filebase1.pli"
submodule "/pliant/language/stream/filebase2.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/os.pli"


constant trace false
constant advanced_tmp false


if os_api="linux" or os_api="posix"
  if advanced_tmp
    gvar Sem temp_sem ; gvar Str temp_path ; gvar Int temp_counter


function file_configure filename options command -> status
  arg Str filename options command ; arg ExtendedStatus status
  status := pliant_default_file_system configure filename options command

function file_configure filename command -> status
  arg Str filename command ; arg ExtendedStatus status
  status := file_configure filename "" command


export file_configure


#----------------------------------------------------------------------


function file_tree_create filename -> status
  arg Str filename ; arg Status status
  var Str path := filename 0 (filename search_last "/" -1)+1
  if (file_query path standard+directories)=defined
    status := success
  eif path<>""
    status := shunt (file_tree_create (path 0 path:len-1))=success and (file_configure path "mkdir")=success success failure
  else
    status := failure


#--------------------------------------------------------------------------


function file_delete filename -> status
  arg Str filename ; arg ExtendedStatus status
  if filename:len>0 and (filename filename:len-1)="/"
    status := file_configure (filename 0 filename:len-1) "delete"
    if status=failure
      status := file_configure filename "rmdir"
  else
    status := file_configure filename "delete"
  if os_api="linux" or os_api="posix"
    if advanced_tmp
      temp_sem request
      if temp_path:len<>0 and (filename 0 temp_path:len)=temp_path
        if (os_rmdir (temp_path 5 temp_path:len))=0
          temp_path := ""
      temp_sem release


function file_link src dest force -> status
  arg Str src dest ; arg CBool force ; arg ExtendedStatus status
  var Str target := (file_query src extended):options option "os_name" Str
  if target<>""
    status := file_configure dest "link "+string:target+(shunt force " force" "")
  eif (target search "/" -1)=(-1)
    status := file_configure dest "link "+string:src+(shunt force " force" "")
  else
    status := failure

function file_link src dest -> status
  arg Str src dest ; arg Status status
  status := file_link src dest false


function file_clone src dest force -> status
  arg Str src dest ; arg CBool force ; arg ExtendedStatus status
  var Str target := (file_query dest extended):options option "os_name" Str
  if target<>""
    status := file_configure src "clone "+string:target+(shunt force " force" "")
  else
    status := failure

function file_clone src dest -> status
  arg Str src dest ; arg ExtendedStatus status
  status := file_clone src dest false


module "/pliant/language/stream/listmode.pli"
module "/pliant/language/compiler.pli"

function file_copy src dest flags -> status
  arg FileInfo src dest ; arg Int flags ; arg ExtendedStatus status
  check (flags .and. recursive)=0
  check (flags .and. delete)=0 or (flags .and. bidirectional)=0
  check src:datetime=defined or dest:datetime=defined or (flags .and. (lazy .or. newer .or. bidirectional))=0
  if (flags .and. bidirectional)<>0
    if dest=defined and (src=undefined or (src:datetime=defined and dest:datetime=defined and dest:datetime>src:datetime))
      return (file_copy dest src flags)
  if (flags .and. (newer .or. bidirectional))<>0
    if src:datetime=defined and dest:datetime=defined and dest:datetime>=src:datetime
      return success
  if (flags .and. lazy)<>0
    if dest:datetime=src:datetime and dest:size=src:size
      return success
  var Str cmd
  if (flags .and. level_flags)>=standard and src:datetime=defined
    src:datetime split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction)
    cmd := "datetime "+string:year+"/"+string:month+"/"+string:day+" "+string:hour+":"+string:minute+":"+string:second
  else
    cmd := ""
  cmd += (shunt cmd<>"" " " "")+"file_size "+(string src:size)
  if (flags .and. level_flags)>=extended and src:options<>""
    cmd += (shunt cmd<>"" " " "")+src:options
  if src:is_link and (flags .and. linktransparent)=0
    if ((dest:options option "link" Str)=(src:options option "link" Str))
      return success
    if (file_configure dest:name "link "+string:(src:options option "link" Str)+" force")=success
      return success
    file_tree_create dest:name
    return (file_configure dest:name "link "+string:(src:options option "link" Str))
  eif src:is_directory
    if dest=defined and dest:is_directory
      status := success
    else
      status := file_tree_create dest:name
  else
    var Stream s ; s open src:name in+safe+bigcache
    if s=failure
      return failure
    var Stream d ; d open dest:name cmd out+mkdir+safe+bigcache
    if d=failure
      return failure
    var Intn total := 0
    while { var Int step := raw_copy s d 1 2^30 ; step>0 }
      total += step
    if (flags .and. level_flags)<standard
      status := success
    eif (s safe_query "encoding")<>"" or (d safe_query "encoding")<>""
      status := success
    else
      status := shunt total=src:size success failure
    if d:close=failure # let's close the destination first as a workaround Linux stalled connections on close when using NAT
      status := failure
    if s:close=failure
      status := failure
  if cmd<>""
    file_configure dest:name cmd
  if trace
    console src:name+" -> "+dest:name+(shunt status=success " success" " failure")+"[lf]"

function file_copy src dest flags -> status
  arg Str src dest ; arg Int flags ; arg ExtendedStatus status
  status := file_copy (file_query src extended) (file_query dest extended) flags

(the_function file_copy FileInfo FileInfo Int -> ExtendedStatus) extra_module :> the_module "/pliant/language/stream/listmode.pli"
(the_function file_copy Str Str Int -> ExtendedStatus) extra_module :> the_module "/pliant/language/stream/listmode.pli"

function file_copy src dest -> status
  arg Str src dest ; arg ExtendedStatus status
  status := file_copy src dest extended


function file_move oldfilename newfilename -> status
  arg Str oldfilename newfilename ; arg ExtendedStatus status
  if newfilename=oldfilename
    return success
  var Str target := (file_query newfilename extended):options option "os_name" Str
  if target<>""
    if (file_configure oldfilename "move "+string:target)=success
      return success
  status := file_copy oldfilename newfilename
  if status=success and newfilename<>oldfilename
    file_delete oldfilename


function mode u g o -> m
  arg Int u g o m
  m := u*8^2+g*8+o

function file_rights info owner group on off
  arg FileInfo info ; arg Int owner group on off
  var Int m := info:options option "mode" Int
  var Int m2 := (m .and. .not. off) .or. on
  if (shunt owner=defined (info:options option "uid" Int)<>owner false) or (shunt group=defined (info:options option "gid" Int)<>group false) or m2<>m
    file_configure info:name (shunt owner=defined "uid "+string:owner "")+" "+(shunt group=defined "gid "+string:group "")+" "+(shunt m2<>m "mode "+string:m2 "")
    # console "setting access rights for " info:name eol

function file_rights filename owner group on off
  arg Str filename ; arg Int owner group on off
  file_rights (file_query filename extended) owner group on off


function file_directory_flush filename -> status
  arg Str filename ; arg ExtendedStatus status
  var Str path := filename 0 (filename search_last "/" -1)
  status := file_configure path "flush"


#----------------------------------------------------------------------


function file_tree_delete path -> status
  arg Str path ; arg ExtendedStatus status
  var Array:FileInfo subs := file_list path extended+directories+deadlinks
  for (var Int i) 0 subs:size-1
    if subs:i:is_directory and not subs:i:is_link
      file_tree_delete subs:i:name
    else
      file_delete subs:i:name
  status := file_delete path


function file_name_concat path subpath -> fullpath
  arg Str path subpath fullpath
  if path:len>0 and path:0="[dq]" and (path parse (var Str strippedpath) any:(var Str options))
    fullpath := (string strippedpath+subpath)+(shunt options<>"" " " "")+options
  else
    fullpath := path+subpath

function file_tree_copy src dest flags -> status
  arg Str src dest ; arg Int flags ; arg ExtendedStatus status
  check (flags .and. delete)=0 or (flags .and. bidirectional)=0
  check src<>"" and (src src:len-1)="/" and dest<>"" and (dest dest:len-1)="/"
  status := success
  var Array:FileInfo src_files := file_list src  extended+recursive+relative
  var Array:FileInfo src_files := file_list src extended+recursive+relative
  for (var Int i) 0 src_files:size-1
    var FileInfo srci := src_files i ; srci name := file_name_concat src srci:name
    var FileInfo desti := file_query (file_name_concat dest src_files:i:name) extended
    if (file_copy srci desti flags)=failure
      status := failure
  if (flags .and. (bidirectional .or. delete))<>0
    var Array:FileInfo dest_files := file_list dest extended+recursive+relative
    for (var Int i) 0 dest_files:size-1
      var FileInfo desti := dest_files i ; desti name := file_name_concat dest desti:name
      var FileInfo srci := file_query (file_name_concat src dest_files:i:name) extended
      if srci=undefined
        if (flags .and. bidirectional)<>0
          if (file_copy desti srci flags)=failure
            status := failure
        else
          check (flags .and. delete)<>0
          if (file_delete desti:name)=failure
            status := failure
(the_function file_tree_copy Str Str Int -> ExtendedStatus) extra_module :> the_module "/pliant/language/stream/listmode.pli"

function file_tree_copy src dest -> status
  arg Str src dest ; arg ExtendedStatus status
  status := file_tree_copy src dest extended


function file_tree_rights path owner group files_on files_off dirs_on dirs_off
  arg Str path ; arg Int owner group files_on files_off dirs_on dirs_off
  var Array:FileInfo files := file_list path extended+recursive+directories
  for (var Int i) 0 files:size-1
    if files:i:is_directory
      file_rights files:i owner group dirs_on dirs_off
    else
      file_rights files:i owner group files_on files_off
  file_rights path owner group dirs_on dirs_off


function file_tree_cleanup path
  arg Str path
  check path<>"" and (path path:len-1)="/"
  var Array:FileInfo subs := file_list path extended+directories
  for (var Int i) 0 subs:size-1
    if subs:i:is_directory and not subs:i:is_link
      file_tree_cleanup subs:i:name
  file_delete path


#--------------------------------------------------------------------------


if os_api="linux" or os_api="posix"

  if advanced_tmp

    function file_temporary -> name
      arg Str name
      temp_sem request
      var Int try_count := 0
      while temp_path=""
        temp_path := "file:/tmp/pliant"+string:os_getpid+"_"+string:try_count+"/"
        temp_counter := 0
        if (os_mkdir (temp_path 5 temp_path:len) 7*8^2)<>0
          temp_path := "" ; try_count += 1
      temp_counter += 1
      name := temp_path+string:temp_counter+".tmp"
      temp_sem release
  
    function file_temporary_cleanup
      if (file_query "file:/proc/" standard)=defined
        var Array:FileInfo files := file_list "file:/tmp/" standard+directories
        (var Relation processes) flags := 0
        var Array:FileInfo proc := file_list "file:/proc/" standard
        for (var Int i) 0 proc:size-1
          if (proc:i:name parse "file:/proc/" (var Int pid) "/")
            processes define (cast pid Address) null (cast -1 Address)
        for (var Int i) 0 files:size-1
          if (files:i:name parse "file:/tmp/pliant" (var Int pid) "_" any "/")
            if (processes query (cast pid Address) null)=null
              file_tree_delete files:i:name
  
    function reset_temporary parameter filehandle
      arg Address parameter ; arg Int filehandle
      temp_path := ""
    gvar DelayedAction da
    da function :> the_function reset_temporary Address Int
    pliant_restore_actions append addressof:da

  else

    gvar Sem temp_sem
    gvar Int temp_counter := 0
  
    function file_temporary -> name
      arg Str name
      part generate_name
        temp_sem request
        temp_counter += 1
        name := "file:/tmp/pliant_"+string:os_getpid+"_"+string:temp_counter+".tmp"
        temp_sem release
        if (file_query name standard)=defined
          file_delete name
          restart generate_name

    function file_temporary_cleanup
      void

eif os_api="win32"

  gvar Sem temp_sem
  gvar Int temp_counter := 0

  function file_temporary -> name
    arg Str name
    temp_sem request
    var Str tmp := os_environment_variable "TMP"
    if tmp:len=0
      tmp := os_environment_variable "TEMP"
      if tmp:len=0
        tmp := "c:\temp"
    temp_counter += 1
    name := "file:"+(replace tmp "\" "/")+"/pliant_"+string:os_getpid+"_"+string:temp_counter+".tmp"
    temp_sem release

  function file_temporary_cleanup
    void

eif os_api="os2"

  gvar Sem temp_sem
  gvar Int temp_counter := 0

  function file_temporary -> name
    arg Str name
    temp_sem request
    temp_counter += 1
    name := "file:c:/tmp/pliant_"+string:os_getpid+"_"+string:temp_counter+".tmp"
    temp_sem release

  function file_temporary_cleanup
    void

function file_temporary filename options -> temp
  arg Str filename options temp
  if (options option "notmp")
    return filename
  var Str temp0
  if (temp eparse (var Str base) any:(var Str opt))
    temp0 := string:(file_temporary base options)+opt
  eif filename:len<>0 and (filename filename:len-1)="."
    temp0 := filename+"tmp"
  else
    temp0 := filename+".tmp"
  var Int counter := 0
  part checkit
    temp := temp0+(shunt counter=0 "" string:counter)
    if (file_query temp standard)=defined
      counter += 1
      restart checkit

function file_os_name filename -> osname
  arg Str filename osname
  osname := (file_query filename extended):options option "os_name" Str


function file_hook filename
  arg Str filename
  plugin hook



#--------------------------------------------------------------------------


export file_delete file_link file_clone file_copy file_move file_rights file_directory_flush
export file_tree_create file_tree_delete file_tree_copy file_tree_rights file_tree_cleanup
export file_temporary file_temporary_cleanup file_os_name file_hook