/pliant/language/stream/multi.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  module "ring.pli" 
 17   
 18   
 19  function configure stream fun 
 20    arg Stream stream ; arg Function fun 
 21    indirect 
 22   
 23  type MultiFileSystemMountPoint 
 24    field Str from 
 25    field Str to 
 26    field Str options 
 27    field Link:FileSystem file_system 
 28    field Link:Function configure 
 29   
 30  type MultiFileSystem 
 31    field List mount_points 
 32  FileSystem maybe MultiFileSystem 
 33   
 34   
 35  method mfs mount from to options fs configure 
 36    arg_rw MultiFileSystem mfs ; arg Str from to options ; arg FileSystem fs ; arg Function configure 
 37    var Pointer:Arrow :> mfs:mount_points first 
 38    while c<>null and (map MultiFileSystemMountPoint):from<>from 
 39      :> mfs:mount_points next c 
 40    var Link:MultiFileSystemMountPoint mp 
 41    if c=null 
 42      if addressof:fs=null 
 43        return 
 44      mp :> new MultiFileSystemMountPoint 
 45      mfs:mount_points insert_before mfs:mount_points:first addressof:mp 
 46    else 
 47      if addressof:fs=null 
 48        mfs:mount_points remove c 
 49        return 
 50      mp :> map MultiFileSystemMountPoint 
 51    mp from := from 
 52    mp to := to 
 53    mp options := options 
 54    mp file_system :> fs 
 55    mp configure :> configure 
 56   
 57  method mfs mount from to fs 
 58    arg_rw MultiFileSystem mfs ; arg Str from to ; arg FileSystem fs 
 59    mfs mount from to "" fs (null map Function) 
 60   
 61  method mfs mount from to options fs 
 62    arg_rw MultiFileSystem mfs ; arg Str from to options ; arg FileSystem fs 
 63    mfs mount from to options fs (null map Function) 
 64   
 65  method mfs dismount from 
 66    arg_rw MultiFileSystem mfs ; arg Str from 
 67    mfs mount from "" "" (null map FileSystem) (null map Function) 
 68   
 69   
 70  method mfs query filename options flags info -> status 
 71    oarg_rw MultiFileSystem mfs ; arg Str filename options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status 
 72    if filename:len>and filename:0="[dq]" and (filename parse (var Str filename2) any:(var Str opt)) 
 73      return (mfs query filename2 opt+(shunt opt:len<>and options:len<>" " "")+options flags info) 
 74    status := failure 
 75    var Pointer:Arrow cur :> mfs:mount_points:first 
 76    while cur<>null 
 77      check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint 
 78      var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint 
 79      if (filename mp:from:len)=mp:from 
 80        status := mp:file_system query mp:to+(filename mp:from:len filename:len) options+(shunt options:len<>and mp:options:len<>" " "")+mp:options flags info 
 81        if status=success 
 82          return 
 83      eif filename=(mp:from filename:len) 
 84        var Str remain := mp:from filename:len mp:from:len 
 85        if (remain search "/" remain:len-1)=remain:len-1 
 86          return success 
 87      cur :> mfs:mount_points next cur 
 88     
 89   
 90  method mfs configure filename options command -> status 
 91    oarg_rw MultiFileSystem mfs ; arg Str filename options command ; arg ExtendedStatus status 
 92    if filename:len>and filename:0="[dq]" and (filename parse (var Str filename2) any:(var Str opt)) 
 93      return (mfs configure filename2 opt+(shunt opt:len<>and options:len<>" " "")+options command) 
 94    status := failure 
 95    var Pointer:Arrow cur :> mfs:mount_points:first 
 96    while cur<>null 
 97      check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint 
 98      var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint 
 99      if (filename mp:from:len)=mp:from 
 100        status := mp:file_system configure mp:to+(filename mp:from:len filename:len) options+(shunt options:len<>and mp:options:len<>" " "")+mp:options command 
 101        if status=success 
 102          return 
 103      cur :> mfs:mount_points next cur 
 104     
 105   
 106  method mfs list path options flags files -> supported_flags 
 107    oarg_rw MultiFileSystem mfs ; arg Str path options ; arg Int flags supported_flags ; arg_rw List files 
 108    if path:len>and path:0="[dq]" and (path parse (var Str path2) any:(var Str opt)) 
 109      var Pointer:Arrow cur :> files last 
 110      supported_flags := mfs list path2 opt+(shunt opt:len<>and options:len<>" " "")+options flags files 
 111      if cur<>null 
 112        cur :> files next cur 
 113      else 
 114        cur :> files first 
 115      while cur<>null 
 116        var Pointer:FileInfo info :> cur map FileInfo 
 117        info name := (string info:name)+(shunt opt<>"" " " "")+opt 
 118        cur :> files next cur 
 119      return 
 120    supported_flags := flags 
 121    var Pointer:Arrow cur :> mfs:mount_points:first 
 122    while cur<>null 
 123      check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint 
 124      var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint 
 125      if (path mp:from:len)=mp:from 
 126        var List files2 := var List empty_list 
 127        var Int supported := mp:file_system list mp:to+(path mp:from:len path:len) options+(shunt options:len<>and mp:options:len<>" " "")+mp:options flags files2 
 128        supported_flags := supported_flags .and. supported 
 129        var Pointer:Arrow :> files2 first 
 130        while c<>null 
 131          check (addressof entry_type:c)=addressof:FileInfo       
 132          var Pointer:FileInfo :> map FileInfo 
 133          check (f:name mp:to:len)=mp:to 
 134          f:name := mp:from + (f:name mp:to:len f:name:len) 
 135          files append addressof:f 
 136          :> files2 next c 
 137      eif path=(mp:from path:len) 
 138        var Str remain := mp:from path:len mp:from:len 
 139        if (remain search "/" remain:len-1)=remain:len-1 
 140          var Link:FileInfo fi :> new FileInfo 
 141          fi name := mp from 
 142          fi status := success 
 143          fi size := undefined 
 144          fi datetime := undefined 
 145          files append addressof:fi 
 146          supported_flags := 0 
 147      cur :> mfs:mount_points next cur 
 148     
 149   
 150  method mfs open name options flags stream support -> status 
 151    oarg_rw MultiFileSystem mfs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status 
 152    if name:len>and name:0="[dq]" and (name parse (var Str name2) any:(var Str opt)) 
 153      return (mfs open name2 opt+(shunt opt:len<>and options:len<>" " "")+options flags stream support) 
 154    status := failure 
 155    var Pointer:Arrow cur :> mfs:mount_points:first 
 156    while cur<>null 
 157      check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint 
 158      var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint 
 159      if (name mp:from:len)=mp:from 
 160        status := mp:file_system open mp:to+(name mp:from:len name:len) options+(shunt options:len<>and mp:options:len<>" " "")+mp:options flags stream support 
 161        if status=success 
 162          if (addressof mp:configure)<>null 
 163            configure stream mp:configure 
 164          return 
 165      cur :> mfs:mount_points next cur 
 166       
 167   
 168 
 
 169  # install the mount stream driver 
 170   
 171  gvar NativeFileSystem pliant_os_file_system 
 172  gvar MultiFileSystem pliant_multi_file_system 
 173   
 174  pliant_multi_file_system mount "os_file:" "" "backward_allowed" pliant_os_file_system 
 175  pliant_multi_file_system mount "file:" "" pliant_os_file_system 
 176  if os_kernel="Linux" or os_kernel="FreeBSD" or os_kernel="OpenBSD" 
 177    pliant_multi_file_system mount "device:/" "/dev/" pliant_os_file_system 
 178  eif os_api="win32" 
 179    pliant_multi_file_system mount "device:" "" "win32_device" pliant_os_file_system 
 180  pliant_multi_file_system mount "/" pliant_root_path pliant_os_file_system 
 181  pliant_default_file_system :> pliant_multi_file_system 
 182   
 183   
 184  export MultiFileSystem pliant_os_file_system pliant_multi_file_system '. mount' '. dismount'