/pliant/admin/file.pli
 
 1  abstract 
 2    [Files handling (listing, copying, ...)] ; eol 
 3   
 4  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 5  # 
 6  # This program is free software; you can redistribute it and/or 
 7  # modify it under the terms of the GNU General Public License version 2 
 8  # as published by the Free Software Foundation. 
 9  # 
 10  # This program is distributed in the hope that it will be useful, 
 11  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 12  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 13  # GNU General Public License for more details. 
 14  # 
 15  # You should have received a copy of the GNU General Public License 
 16  # version 2 along with this program; if not, write to the Free Software 
 17  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 18   
 19  submodule "/pliant/language/stream/filebase1.pli" 
 20  submodule "/pliant/language/stream/filebase2.pli" 
 21  module "/pliant/language/stream.pli" 
 22  module "/pliant/language/stream/filesystembase.pli" 
 23  module "/pliant/language/os.pli" 
 24   
 25   
 26  constant trace false 
 27  constant advanced_tmp false 
 28   
 29   
 30  if os_api="linux" or os_api="posix" 
 31    if advanced_tmp 
 32      gvar Sem temp_sem ; gvar Str temp_path ; gvar Int temp_counter 
 33   
 34   
 35  function file_configure filename options command -> status 
 36    arg Str filename options command ; arg ExtendedStatus status 
 37    status := pliant_default_file_system configure filename options command 
 38   
 39  function file_configure filename command -> status 
 40    arg Str filename command ; arg ExtendedStatus status 
 41    status := file_configure filename "" command 
 42   
 43   
 44  export file_configure 
 45   
 46   
 47 
 
 48   
 49   
 50  function file_tree_create filename -> status 
 51    arg Str filename ; arg Status status 
 52    var Str path := filename 0 (filename search_last "/" -1)+1 
 53    if (file_query path standard+directories)=defined 
 54      status := success 
 55    eif path<>"" 
 56      status := shunt (file_tree_create (path path:len-1))=success and (file_configure path "mkdir")=success success failure 
 57    else 
 58      status := failure 
 59   
 60   
 61 
 
 62   
 63   
 64  function file_delete filename -> status 
 65    arg Str filename ; arg ExtendedStatus status 
 66    if filename:len>and (filename filename:len-1)="/" 
 67      status := file_configure (filename filename:len-1) "delete" 
 68      if status=failure 
 69        status := file_configure filename "rmdir" 
 70    else 
 71      status := file_configure filename "delete" 
 72    if os_api="linux" or os_api="posix" 
 73      if advanced_tmp 
 74        temp_sem request 
 75        if temp_path:len<>0 and (filename 0 temp_path:len)=temp_path 
 76          if (os_rmdir (temp_path 5 temp_path:len))=0 
 77            temp_path := "" 
 78        temp_sem release 
 79   
 80   
 81  function file_link src dest force -> status 
 82    arg Str src dest ; arg CBool force ; arg ExtendedStatus status 
 83    var Str target := (file_query src extended):options option "os_name" Str 
 84    if target<>"" 
 85      status := file_configure dest "link "+string:target+(shunt force " force" "") 
 86    eif (target search "/" -1)=(-1) 
 87      status := file_configure dest "link "+string:src+(shunt force " force" "") 
 88    else 
 89      status := failure 
 90   
 91  function file_link src dest -> status 
 92    arg Str src dest ; arg Status status 
 93    status := file_link src dest false 
 94   
 95   
 96  function file_clone src dest force -> status 
 97    arg Str src dest ; arg CBool force ; arg ExtendedStatus status 
 98    var Str target := (file_query dest extended):options option "os_name" Str 
 99    if target<>"" 
 100      status := file_configure src "clone "+string:target+(shunt force " force" "") 
 101    else 
 102      status := failure 
 103   
 104  function file_clone src dest -> status 
 105    arg Str src dest ; arg ExtendedStatus status 
 106    status := file_clone src dest false 
 107   
 108   
 109  module "/pliant/language/stream/listmode.pli" 
 110  module "/pliant/language/compiler.pli" 
 111   
 112  constant use_sendfile false # os_api="linux" 
 113   
 114  if use_sendfile 
 115    function os_sendfile64 out_fd in_fd offset count -> copied 
 116      arg Int out_fd in_fd ; arg_rw Int64 offset ; arg Int count copied 
 117      kernel_function 239 
 118   
 119  function file_copy src dest flags -> status 
 120    arg FileInfo src dest ; arg Int flags ; arg ExtendedStatus status 
 121    check (flags .and. recursive)=0 
 122    check (flags .and. delete)=or (flags .and. bidirectional)=0 
 123    check src:datetime=defined or dest:datetime=defined or (flags .and. (lazy .or. newer .or. bidirectional))=0 
 124    if (flags .and. bidirectional)<>0 
 125      if dest=defined and (src=undefined or (src:datetime=defined and dest:datetime=defined and dest:datetime>src:datetime)) 
 126        return (file_copy dest src flags) 
 127    if (flags .and. (newer .or. bidirectional))<>0 
 128      if src:datetime=defined and dest:datetime=defined and dest:datetime>=src:datetime 
 129        return success 
 130    if (flags .and. lazy)<>0 
 131      if dest:datetime=src:datetime and dest:size=src:size 
 132        return success 
 133    var Str cmd 
 134    if (flags .and. level_flags)>=standard and src:datetime=defined 
 135      src:datetime split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction) 
 136      cmd := "datetime "+string:year+"/"+string:month+"/"+string:day+" "+string:hour+":"+string:minute+":"+string:second 
 137    else 
 138      cmd := "" 
 139    cmd += (shunt cmd<>"" " " "")+"file_size "+(string src:size) 
 140    if (flags .and. level_flags)>=extended and src:options<>"" 
 141      cmd += (shunt cmd<>"" " " "")+src:options 
 142    if src:is_link and (flags .and. linktransparent)=0 
 143      if ((dest:options option "link" Str)=(src:options option "link" Str)) 
 144        return success 
 145      if (file_configure dest:name "link "+string:(src:options option "link" Str)+" force")=success 
 146        return success 
 147      file_tree_create dest:name 
 148      return (file_configure dest:name "link "+string:(src:options option "link" Str)) 
 149    eif src:is_directory and (flags .and. forcefile)=0 
 150      if dest=defined and dest:is_directory 
 151        status := success 
 152      else 
 153        status := file_tree_create dest:name 
 154    else 
 155      var Stream s ; open src:name in+safe+bigcache 
 156      if s=failure 
 157        return failure 
 158      var Stream d ; open dest:name cmd out+mkdir+safe+bigcache 
 159      if d=failure 
 160        return failure 
 161      var Intn total := 0 
 162      if use_sendfile and s:stream_handle<>undefined and d:stream_handle<>undefined 
 163        while { var Int step := os_sendfile64 d:stream_handle s:stream_handle (null map Int64) 2^16 ; step>0 } 
 164          total += step 
 165      if not use_sendfile or total=0 
 166        while { var Int step := raw_copy 1 2^30 ; step>0 } 
 167          total += step 
 168      if (flags .and. level_flags)<standard 
 169        status := success 
 170      eif (safe_query "encoding")<>"" or (safe_query "encoding")<>"" 
 171        status := success 
 172      else 
 173        status := shunt total=src:size success failure 
 174      if d:close=failure # let's close the destination first as a workaround Linux stalled connections on close when using NAT 
 175        status := failure 
 176      if s:close=failure 
 177        status := failure 
 178    if cmd<>"" 
 179      file_configure dest:name cmd 
 180    if trace 
 181      console src:name+" -> "+dest:name+(shunt status=success " success" " failure")+"[lf]" 
 182   
 183  function file_copy src dest flags -> status 
 184    arg Str src dest ; arg Int flags ; arg ExtendedStatus status 
 185    status := file_copy (file_query src extended) (file_query dest extended) flags 
 186   
 187  (the_function file_copy FileInfo FileInfo Int -> ExtendedStatus) extra_module :> the_module "/pliant/language/stream/listmode.pli" 
 188  (the_function file_copy Str Str Int -> ExtendedStatus) extra_module :> the_module "/pliant/language/stream/listmode.pli" 
 189   
 190  function file_copy src dest -> status 
 191    arg Str src dest ; arg ExtendedStatus status 
 192    status := file_copy src dest extended 
 193   
 194   
 195  function file_move oldfilename newfilename -> status 
 196    arg Str oldfilename newfilename ; arg ExtendedStatus status 
 197    if newfilename=oldfilename 
 198      return success 
 199    var Str target := (file_query newfilename extended):options option "os_name" Str 
 200    if target<>"" 
 201      if (file_configure oldfilename "move "+string:target)=success 
 202        return success 
 203    status := file_copy oldfilename newfilename 
 204    if status=success and newfilename<>oldfilename 
 205      file_delete oldfilename 
 206   
 207   
 208  function mode u g o -> m 
 209    arg Int m 
 210    := u*8^2+g*8+o 
 211   
 212  function file_rights info owner group on off 
 213    arg FileInfo info ; arg Int owner group on off 
 214    var Int := info:options option "mode" Int 
 215    var Int m2 := (.and. .not. off) .or. on 
 216    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 
 217      file_configure info:name (shunt owner=defined "uid "+string:owner "")+" "+(shunt group=defined "gid "+string:group "")+" "+(shunt m2<>"mode "+string:m2 "") 
 218      # console "setting access rights for " info:name eol 
 219   
 220  function file_rights filename owner group on off 
 221    arg Str filename ; arg Int owner group on off 
 222    file_rights (file_query filename extended) owner group on off 
 223   
 224   
 225  function file_directory_flush filename -> status 
 226    arg Str filename ; arg ExtendedStatus status 
 227    var Str path := filename 0 (filename search_last "/" -1) 
 228    status := file_configure path "flush" 
 229   
 230   
 231 
 
 232   
 233   
 234  function file_tree_delete path -> status 
 235    arg Str path ; arg ExtendedStatus status 
 236    var Array:FileInfo subs := file_list path extended+directories+deadlinks 
 237    for (var Int i) subs:size-1 
 238      if subs:i:is_directory and not subs:i:is_link 
 239        file_tree_delete subs:i:name 
 240      else 
 241        file_delete subs:i:name 
 242    status := file_delete path 
 243   
 244   
 245  function file_name_concat path subpath -> fullpath 
 246    arg Str path subpath fullpath 
 247    if path:len>and path:0="[dq]" and (path parse (var Str strippedpath) any:(var Str options)) 
 248      fullpath := (string strippedpath+subpath)+(shunt options<>"" " " "")+options 
 249    else 
 250      fullpath := path+subpath 
 251   
 252  function file_tree_copy src dest flags -> status 
 253    arg Str src dest ; arg Int flags ; arg ExtendedStatus status 
 254    check (flags .and. delete)=or (flags .and. bidirectional)=0 
 255    check src<>"" and (src src:len-1)="/" and dest<>"" and (dest dest:len-1)="/" 
 256    status := success 
 257    var Array:FileInfo src_files := file_list src extended+recursive+relative 
 258    for (var Int i) src_files:size-1 
 259      var FileInfo srci := src_files i ; srci name := file_name_concat src srci:name 
 260      var FileInfo desti := file_query (file_name_concat dest src_files:i:name) extended 
 261      if (file_copy srci desti flags)=failure 
 262        status := failure 
 263    if (flags .and. (bidirectional .or. delete))<>0 
 264      var Array:FileInfo dest_files := file_list dest extended+recursive+relative 
 265      for (var Int i) dest_files:size-1 
 266        var FileInfo desti := dest_files i ; desti name := file_name_concat dest desti:name 
 267        var FileInfo srci := file_query (file_name_concat src dest_files:i:name) extended 
 268        if srci=undefined 
 269          if (flags .and. bidirectional)<>0 
 270            if (file_copy desti srci flags)=failure 
 271              status := failure 
 272          else 
 273            check (flags .and. delete)<>0 
 274            if (file_delete desti:name)=failure 
 275              status := failure 
 276  (the_function file_tree_copy Str Str Int -> ExtendedStatus) extra_module :> the_module "/pliant/language/stream/listmode.pli" 
 277   
 278  function file_tree_copy src dest -> status 
 279    arg Str src dest ; arg ExtendedStatus status 
 280    status := file_tree_copy src dest extended 
 281   
 282   
 283  function file_tree_rights path owner group files_on files_off dirs_on dirs_off 
 284    arg Str path ; arg Int owner group files_on files_off dirs_on dirs_off 
 285    var Array:FileInfo files := file_list path extended+recursive+directories 
 286    for (var Int i) files:size-1 
 287      if files:i:is_directory 
 288        file_rights files:owner group dirs_on dirs_off 
 289      else 
 290        file_rights files:owner group files_on files_off 
 291    file_rights path owner group dirs_on dirs_off 
 292   
 293   
 294  function file_tree_cleanup path 
 295    arg Str path 
 296    check path<>"" and (path path:len-1)="/" 
 297    var Array:FileInfo subs := file_list path extended+directories 
 298    for (var Int i) subs:size-1 
 299      if subs:i:is_directory and not subs:i:is_link 
 300        file_tree_cleanup subs:i:name 
 301    file_delete path 
 302   
 303   
 304 
 
 305   
 306   
 307  if os_api="linux" or os_api="posix" 
 308   
 309    if advanced_tmp 
 310   
 311      function file_temporary -> name 
 312        arg Str name 
 313        temp_sem request 
 314        var Int try_count := 0 
 315        while temp_path="" 
 316          temp_path := "file:/tmp/pliant"+string:os_getpid+"_"+string:try_count+"/" 
 317          temp_counter := 0 
 318          if (os_mkdir (temp_path 5 temp_path:len) 7*8^2)<>0 
 319            temp_path := "" ; try_count += 1 
 320        temp_counter += 1 
 321        name := temp_path+string:temp_counter+".tmp" 
 322        temp_sem release 
 323     
 324      function file_temporary_cleanup 
 325        if (file_query "file:/proc/" standard)=defined 
 326          var Array:FileInfo files := file_list "file:/tmp/" standard+directories 
 327          (var Relation processes) flags := 0 
 328          var Array:FileInfo proc := file_list "file:/proc/" standard 
 329          for (var Int i) 0 proc:size-1 
 330            if (proc:i:name parse "file:/proc/" (var Int pid) "/") 
 331              processes define (cast pid Address) null (cast -1 Address) 
 332          for (var Int i) 0 files:size-1 
 333            if (files:i:name parse "file:/tmp/pliant" (var Int pid) "_" any "/") 
 334              if (processes query (cast pid Address) null)=null 
 335                file_tree_delete files:i:name 
 336     
 337      function reset_temporary parameter filehandle 
 338        arg Address parameter ; arg Int filehandle 
 339        temp_path := "" 
 340      gvar DelayedAction da 
 341      da function :> the_function reset_temporary Address Int 
 342      pliant_restore_actions append addressof:da 
 343   
 344    else 
 345   
 346      gvar Sem temp_sem 
 347      gvar Int temp_counter := 0 
 348     
 349      function file_temporary -> name 
 350        arg Str name 
 351        part generate_name 
 352          temp_sem request 
 353          temp_counter += 1 
 354          name := "file:/tmp/pliant_"+string:os_getpid+"_"+string:temp_counter+".tmp" 
 355          temp_sem release 
 356          if (file_query name standard)=defined 
 357            file_delete name 
 358            restart generate_name 
 359   
 360      function file_temporary_cleanup 
 361        void 
 362   
 363  eif os_api="win32" 
 364   
 365    gvar Sem temp_sem 
 366    gvar Int temp_counter := 0 
 367   
 368    function file_temporary -> name 
 369      arg Str name 
 370      temp_sem request 
 371      var Str tmp := os_environment_variable "TMP" 
 372      if tmp:len=0 
 373        tmp := os_environment_variable "TEMP" 
 374        if tmp:len=0 
 375          tmp := "c:\temp" 
 376      temp_counter += 1 
 377      name := "file:"+(replace tmp "\" "/")+"/pliant_"+string:os_getpid+"_"+string:temp_counter+".tmp" 
 378      temp_sem release 
 379   
 380    function file_temporary_cleanup 
 381      void 
 382   
 383  eif os_api="os2" 
 384   
 385    gvar Sem temp_sem 
 386    gvar Int temp_counter := 0 
 387   
 388    function file_temporary -> name 
 389      arg Str name 
 390      temp_sem request 
 391      temp_counter += 1 
 392      name := "file:c:/tmp/pliant_"+string:os_getpid+"_"+string:temp_counter+".tmp" 
 393      temp_sem release 
 394   
 395    function file_temporary_cleanup 
 396      void 
 397   
 398  function file_temporary filename options -> temp 
 399    arg Str filename options temp 
 400    if (options option "notmp") 
 401      return filename 
 402    var Str temp0 
 403    if (temp eparse (var Str base) any:(var Str opt)) 
 404      temp0 := string:(file_temporary base options)+opt 
 405    else 
 406      temp0 := filename+".tmp" 
 407    var Int counter := 0 
 408    part checkit 
 409      temp := temp0+(shunt counter="" string:counter) 
 410      if (file_query temp standard)=defined 
 411        counter += 1 
 412        restart checkit 
 413   
 414  function file_os_name filename -> osname 
 415    arg Str filename osname 
 416    osname := (file_query filename extended):options option "os_name" Str 
 417   
 418   
 419  function file_hook filename 
 420    arg Str filename 
 421    plugin hook 
 422   
 423   
 424   
 425 
 
 426   
 427   
 428  export file_delete file_link file_clone file_copy file_move file_rights file_directory_flush 
 429  export file_tree_create file_tree_delete file_tree_copy file_tree_rights file_tree_cleanup 
 430  export file_temporary file_temporary_cleanup file_os_name file_hook