Patch title: Release 93 bulk changes
Abstract:
File: /language/stream/multi.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.

module "ring.pli"


function configure stream fun
  arg Stream stream ; arg Function fun
  indirect

type MultiFileSystemMountPoint
  field Str from
  field Str to
  field Str options
  field Link:FileSystem file_system
  field Link:Function configure

type MultiFileSystem
  field List mount_points
FileSystem maybe MultiFileSystem


method mfs mount from to options fs configure
  arg_rw MultiFileSystem mfs ; arg Str from to options ; arg FileSystem fs ; arg Function configure
  var Pointer:Arrow c :> mfs:mount_points first
  while c<>null and (c map MultiFileSystemMountPoint):from<>from
    c :> mfs:mount_points next c
  var Link:MultiFileSystemMountPoint mp
  if c=null
    if addressof:fs=null
      return
    mp :> new MultiFileSystemMountPoint
    mfs:mount_points insert_before mfs:mount_points:first addressof:mp
  else
    if addressof:fs=null
      mfs:mount_points remove c
      return
    mp :> c map MultiFileSystemMountPoint
  mp from := from
  mp to := to
  mp options := options
  mp file_system :> fs
  mp configure :> configure

method mfs mount from to fs
  arg_rw MultiFileSystem mfs ; arg Str from to ; arg FileSystem fs
  mfs mount from to "" fs (null map Function)

method mfs mount from to options fs
  arg_rw MultiFileSystem mfs ; arg Str from to options ; arg FileSystem fs
  mfs mount from to options fs (null map Function)

method mfs dismount from
  arg_rw MultiFileSystem mfs ; arg Str from
  mfs mount from "" "" (null map FileSystem) (null map Function)


method mfs query filename options flags info -> status
  oarg_rw MultiFileSystem mfs ; arg Str filename options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status
  if filename:len>0 and filename:0="[dq]" and (filename parse (var Str filename2) any:(var Str opt))
    return (mfs query filename2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+options flags info)
  status := failure
  var Pointer:Arrow cur :> mfs:mount_points:first
  while cur<>null
    check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint
    var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint
    if (filename 0 mp:from:len)=mp:from
      status := mp:file_system query mp:to+(filename mp:from:len filename:len) options+(shunt options:len<>0 and mp:options:len<>0 " " "")+mp:options flags info
      if status=success
        return
    eif filename=(mp:from 0 filename:len)
      var Str remain := mp:from filename:len mp:from:len
      if (remain search "/" remain:len-1)=remain:len-1
        return success
    cur :> mfs:mount_points next cur
  

method mfs configure filename options command -> status
  oarg_rw MultiFileSystem mfs ; arg Str filename options command ; arg ExtendedStatus status
  if filename:len>0 and filename:0="[dq]" and (filename parse (var Str filename2) any:(var Str opt))
    return (mfs configure filename2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+options command)
  status := failure
  var Pointer:Arrow cur :> mfs:mount_points:first
  while cur<>null
    check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint
    var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint
    if (filename 0 mp:from:len)=mp:from
      status := mp:file_system configure mp:to+(filename mp:from:len filename:len) options+(shunt options:len<>0 and mp:options:len<>0 " " "")+mp:options command
      if status=success
        return
    cur :> mfs:mount_points next cur
  

method mfs list path options flags files -> supported_flags
  oarg_rw MultiFileSystem mfs ; arg Str path options ; arg Int flags supported_flags ; arg_rw List files
  if path:len>0 and path:0="[dq]" and (path parse (var Str path2) any:(var Str opt))
    var Pointer:Arrow cur :> files last
    supported_flags := mfs list path2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+options flags files
    if cur<>null
      cur :> files next cur
    else
      cur :> files first
    while cur<>null
      var Pointer:FileInfo info :> cur map FileInfo
      info name := (string info:name)+(shunt opt<>"" " " "")+opt
      cur :> files next cur
    return
  supported_flags := flags
  var Pointer:Arrow cur :> mfs:mount_points:first
  while cur<>null
    check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint
    var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint
    if (path 0 mp:from:len)=mp:from
      var List files2 := var List empty_list
      var Int supported := mp:file_system list mp:to+(path mp:from:len path:len) options+(shunt options:len<>0 and mp:options:len<>0 " " "")+mp:options flags files2
      supported_flags := supported_flags .and. supported
      var Pointer:Arrow c :> files2 first
      while c<>null
        check (addressof entry_type:c)=addressof:FileInfo      
        var Pointer:FileInfo f :> c map FileInfo
        check (f:name 0 mp:to:len)=mp:to
        f:name := mp:from + (f:name mp:to:len f:name:len)
        files append addressof:f
        c :> files2 next c
    eif path=(mp:from 0 path:len)
      var Str remain := mp:from path:len mp:from:len
      if (remain search "/" remain:len-1)=remain:len-1
        var Link:FileInfo fi :> new FileInfo
        fi name := mp from
        fi status := failure
        fi status := success
        fi size := undefined
        fi datetime := undefined
        files append addressof:fi
        supported_flags := 0
    cur :> mfs:mount_points next cur
  

method mfs open name options flags stream support -> status
  oarg_rw MultiFileSystem mfs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  if name:len>0 and name:0="[dq]" and (name parse (var Str name2) any:(var Str opt))
    return (mfs open name2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+options flags stream support)
  status := failure
  var Pointer:Arrow cur :> mfs:mount_points:first
  while cur<>null
    check (addressof entry_type:cur)=addressof:MultiFileSystemMountPoint
    var Pointer:MultiFileSystemMountPoint mp :> cur map MultiFileSystemMountPoint
    if (name 0 mp:from:len)=mp:from
      status := mp:file_system open mp:to+(name mp:from:len name:len) options+(shunt options:len<>0 and mp:options:len<>0 " " "")+mp:options flags stream support
      if status=success
        if (addressof mp:configure)<>null
          configure stream mp:configure
        return
    cur :> mfs:mount_points next cur
    

#----------------------------------------------------------------------
# install the mount stream driver

gvar NativeFileSystem pliant_os_file_system
gvar MultiFileSystem pliant_multi_file_system

pliant_multi_file_system mount "os_file:" "" "backward_allowed" pliant_os_file_system
pliant_multi_file_system mount "file:" "" pliant_os_file_system
if os_kernel="Linux" or os_kernel="FreeBSD" or os_kernel="OpenBSD"
  pliant_multi_file_system mount "device:/" "/dev/" pliant_os_file_system
eif os_api="win32"
  pliant_multi_file_system mount "device:" "" "win32_device" pliant_os_file_system
pliant_multi_file_system mount "/" pliant_root_path pliant_os_file_system
pliant_default_file_system :> pliant_multi_file_system


export MultiFileSystem pliant_os_file_system pliant_multi_file_system '. mount' '. dismount'