/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 0 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>0 and (filename filename:len-1)="/"
67	status := file_configure (filename 0 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)=0 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 ; s open src:name in+safe+bigcache
156	if s=failure
157	return failure
158	var Stream d ; 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 s d 1 2^30 ; step>0 }
167	total += step
168	if (flags .and. level_flags)<standard
169	status := success
170	eif (s safe_query "encoding")<>"" or (d 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 u g o m
210	m := 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 m := info:options option "mode" Int
215	var Int m2 := (m .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<>m "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) 0 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>0 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)=0 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) 0 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) 0 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) 0 files:size-1
287	if files:i:is_directory
288	file_rights files:i owner group dirs_on dirs_off
289	else
290	file_rights files:i 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) 0 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=0 "" 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