/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 c :> mfs:mount_points first
38	while c<>null and (c map MultiFileSystemMountPoint):from<>from
39	c :> 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 :> c 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>0 and filename:0="[dq]" and (filename parse (var Str filename2) any:(var Str opt))
73	return (mfs query filename2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+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 0 mp:from:len)=mp:from
80	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
81	if status=success
82	return
83	eif filename=(mp:from 0 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>0 and filename:0="[dq]" and (filename parse (var Str filename2) any:(var Str opt))
93	return (mfs configure filename2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+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 0 mp:from:len)=mp:from
100	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
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>0 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<>0 and options:len<>0 " " "")+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 0 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<>0 and mp:options:len<>0 " " "")+mp:options flags files2
128	supported_flags := supported_flags .and. supported
129	var Pointer:Arrow c :> files2 first
130	while c<>null
131	check (addressof entry_type:c)=addressof:FileInfo
132	var Pointer:FileInfo f :> c map FileInfo
133	check (f:name 0 mp:to:len)=mp:to
134	f:name := mp:from + (f:name mp:to:len f:name:len)
135	files append addressof:f
136	c :> files2 next c
137	eif path=(mp:from 0 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>0 and name:0="[dq]" and (name parse (var Str name2) any:(var Str opt))
153	return (mfs open name2 opt+(shunt opt:len<>0 and options:len<>0 " " "")+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 0 mp:from:len)=mp:from
160	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
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'