yap-6.3/library/system.yap

/*************************************************************************
*									 *
*	 YAP Prolog 							 *
*									 *
*	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
*									 *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
*									 *
**************************************************************************
*									 *
* File:		system.yap						 *
* Last rev:								 *
* mods:									 *
* comments:	Operating System Access built-ins			 *
*									 *
*************************************************************************/

:- module(system, [
	chmod/2,
	datime/1,
	delete_file/1,
	delete_file/2,
	directory_files/2,
	environ/2,
	exec/3,
	file_exists/1,
	file_exists/2,
	file_property/2,
	fmode/2,
	host_id/1,
	host_name/1,
	pid/1,
	kill/2,
	mktemp/2,
	make_directory/1,
	popen/3,
	rename_file/2,
	shell/0,
	shell/1,
	shell/2,
	sleep/1,
	system/0,
	system/1,
	system/2,
	time/1,
	tmpnam/1,
	wait/2,
	working_directory/2
          ]).

:- use_module(library(lists), [append/3]).

:- load_foreign_files([sys], [], init_sys).

% time builtins

datime(X) :-
	datime(X, Error),
	handle_system_error(Error, off, datime(X)).
 
% file operations

delete_file(File) :-
	delete_file(File, off, on, off).

delete_file(File, Opts) :-
	process_delete_file_opts(Opts, Dir, Recurse, Ignore, delete_file(File,Opts)),
	delete_file(File, Dir, Recurse, Ignore).

process_delete_file_opts(V, _, _, _, T) :- var(V), !,
	throw(error(instantiation_error,T)).
process_delete_file_opts([], off, off, off, _) :- !.
process_delete_file_opts([V|_], _, _, _, T) :- var(V), !,
	throw(error(instantiation_error,T)).
process_delete_file_opts([directory|Opts], on, Recurse, Ignore, T) :- !,
	process_delete_file_opts(Opts, _, Recurse, Ignore, T).
process_delete_file_opts([recursive|Opts], Dir, on, Ignore, T) :- !,
	process_delete_file_opts(Opts, Dir, _, Ignore, T).
process_delete_file_opts([ignore|Opts], Dir, Recurse, on, T) :- !,
	process_delete_file_opts(Opts, Dir, Recurse, _, T).
process_delete_file_opts(Opts, _, _, _, T) :-
	throw(error(domain_error(delete_file_option,Opts),T)).

delete_file(File, Dir, Recurse, Ignore) :-
	file_property(File, Type, _, _, _Permissions, Ignore),
	delete_file(Type, File, Dir, Recurse, Ignore).

delete_file(N, File, _Dir, _Recurse, Ignore) :- number(N), !, % error.
	handle_system_error(N, Ignore, delete_file(File)).
delete_file(directory, File, Dir, Recurse, Ignore) :-
	delete_directory(Dir, File, Recurse, Ignore).
delete_file(_, File, _Dir, _Recurse, Ignore) :-
	unlink_file(File, Ignore).

unlink_file(File, Ignore) :-
	unlink(File, N),
	handle_system_error(N, Ignore, delete_file(File)).

delete_directory(on, File, _Recurse, Ignore) :-
	rm_directory(File, Ignore).
delete_directory(off, File, Recurse, Ignore) :-
	delete_directory(Recurse, File, Ignore).

rm_directory(File, Ignore) :-
	rmdir(File, Error),
	handle_system_error(Error, Ignore, delete_file(File)).

delete_directory(on, File, Ignore) :-
	directory_files(File, FileList, Ignore),
	dir_separator(D),
	atom_concat(File, D, FileP),
	delete_dirfiles(FileList, FileP, Ignore),
	rmdir(File, Ignore).

delete_dirfiles([], _, _).
delete_dirfiles(['.'|Fs], File, Ignore) :- !,
	delete_dirfiles(Fs, File, Ignore).
delete_dirfiles(['..'|Fs], File, Ignore) :- !,
	delete_dirfiles(Fs, File, Ignore).
delete_dirfiles([F|Fs], File, Ignore) :-
	atom_concat(File,F,TrueF),
	delete_file(TrueF, off, on, Ignore),
	delete_dirfiles(Fs, File, Ignore).

directory_files(File, FileList) :-
	directory_files(File, FileList, off).

directory_files(File, FileList, Ignore) :-
       list_directory(File, FileList, Error),
       handle_system_error(Error, Ignore, directory_files(File, FileList)).

handle_system_error(Error, _Ignore, _G) :- var(Error), !.
handle_system_error(Error, off, G) :- atom(Error), !,
	throw(error(system_error(Error),G)).
handle_system_error(Error, off, G) :-
	error_message(Error, Message),
	throw(error(system_error(Message),G)).

file_property(File, type(Type)) :-
	file_property(File, Type, _Size, _Date).
file_property(File, size(Size)) :-
	file_property(File, _Type, Size, _Date).
file_property(File, mod_time(Date)) :-
	file_property(File, _Type, _Size, Date).

file_property(File, Type, Size, Date) :-
	file_property(File, Type, Size, Date, _Permissions, Error),
	handle_system_error(Error, off, file_property(File)).

file_exists(File) :-
	var(File), !,
	throw(error(instantiation_error,file_exists(File))).
file_exists(File) :-
	\+ atom(File), !,
	throw(error(type_error(atom,File),file_exists(File))).
file_exists(File) :-
	file_property(File, _Type, _Size, _Date, _Permissions, Error),
	var(Error).

file_exists(File, Permissions) :-
	var(File), !,
	throw(error(instantiation_error,file_exists(File, Permissions))).
file_exists(File, Permissions) :-
	\+ atom(File), !,
	throw(error(type_error(atom,File),file_exists(File, Permissions))).
file_exists(File, Permissions) :-
	file_property(File, _Type, _Size, _Date, FPermissions, Error),
	var(Error),
	process_permissions(Permissions, Perms),
	FPermissions /\ Perms =:= Perms.

process_permissions(Number, Number) :- integer(Number).

make_directory(Dir) :-
	var(Dir), !,
	throw(error(instantiation_error,mkdir(Dir))).
make_directory(Dir) :-
	atom(Dir), !,
	mkdir(Dir,Error),
	handle_system_error(Error, off, mkdir(Dir)).
make_directory(Dir) :-
	throw(error(type_error(atom,Dir),make_directory(Dir))).

rename_file(Old, New) :-
	atom(Old), atom(New), !,
	rename_file(Old, New, Error),
	handle_system_error(Error, off, rename_file(Old, New)).
rename_file(X,Y) :- (var(X) ; var(Y)), !,
	throw(error(instantiation_error,rename_file(X,Y))).
rename_file(X,Y) :- atom(X), !,
	throw(error(type_error(atom,Y),rename_file(X,Y))).
rename_file(X,Y) :-
	throw(error(type_error(atom,X),rename_file(X,Y))).

%
% environment manipulation.
%

environ(Na,Val) :- var(Na), !,
	environ_enum(0,I),
	( p_environ(I,S) -> environ_split(S,SNa,SVal) ; !, fail ),
	atom_codes(Na, SNa),
	atom_codes(Val, SVal).
environ(Na,Val) :- atom(Na), !,
	bound_environ(Na, Val).
environ(Na,Val) :-
	throw(type_error(atom,Na),environ(Na,Val)).

bound_environ(Na, Val) :- var(Val), !,
	getenv(Na,Val).
bound_environ(Na, Val) :- atom(Val), !,
	putenv(Na,Val).
bound_environ(Na, Val) :-
	throw(type_error(atom,Val),environ(Na,Val)).

environ_enum(X,X).
environ_enum(X,X1) :-
	Xi is X+1,
	environ_enum(Xi,X1).

environ_split([61|SVal], [], SVal) :- !.
environ_split([C|S],[C|SNa],SVal) :-
	environ_split(S,SNa,SVal).

working_directory(OLD, NEW) :-
	getcwd(OLD),
	cd(NEW).

%
% process execution
%
exec(Command, [StdIn, StdOut, StdErr], PID) :-
	G = exec(Command, [StdIn, StdOut, StdErr], PID),
	check_command_with_default_shell(Command, TrueCommand, G), 
	process_inp_stream_for_exec(StdIn, In, G, [], L1),
	process_out_stream_for_exec(StdOut, Out, G, L1, L2),
	process_err_stream_for_exec(StdErr, Err, G, L2, L3),
	( exec_command(TrueCommand, In, Out, Err, PID, Error) -> true ; true ),
	close_temp_streams(L3),
	handle_system_error(Error, off, G).

process_inp_stream_for_exec(Error, _, G, L, L) :- var(Error), !,
	throw(error(instantiation_error,G)).
process_inp_stream_for_exec(null, null, _, L, L) :- !.
process_inp_stream_for_exec(std, 0, _, L, L) :- !.
process_inp_stream_for_exec(pipe(ForWriting), ForReading, _, L, [ForReading|L]) :- !,
	open_pipe_streams(ForReading, ForWriting).
process_inp_stream_for_exec(Stream, Stream, _, L, L) :-
	stream_property(Stream, input).


process_out_stream_for_exec(Error, _, G, L, L) :- var(Error), !,
	throw(error(instantiation_error,G)).
process_out_stream_for_exec(null, null, _, L, L) :- !.
process_out_stream_for_exec(std, 1, _, L, L) :- !.
process_out_stream_for_exec(pipe(ForReading), ForWriting, _, L, [ForWriting|L]) :- !,
	open_pipe_streams(ForReading, ForWriting).
process_out_stream_for_exec(Stream, Stream, _, L, L) :-
	stream_property(Stream, output).

process_err_stream_for_exec(Error, _, G, L, L) :- var(Error), !,
	throw(error(instantiation_error,G)).
process_err_stream_for_exec(null, null, _, L, L) :- !.
process_err_stream_for_exec(std, 2, _, L, L) :- !.
process_err_stream_for_exec(pipe(ForReading), ForWriting, _, L, [ForWriting|L]) :- !,
	open_pipe_streams(ForReading, ForWriting).
process_err_stream_for_exec(Stream, Stream, _, L, L) :-
	stream_property(Stream, output).

close_temp_streams([]).
close_temp_streams([S|Ss]) :- close(S),
	close_temp_streams(Ss).


popen(Command, Mode, Stream) :-
	G = popen(Command, Mode, Stream),
	check_command_with_default_shell(Command, TrueCommand, G),
	check_mode(Mode, M, G),
	do_popen(TrueCommand, M, Stream, Result),
	handle_system_error(Result, off, G).

do_popen(Command, M, Stream, Result) :- win, !,
	win_popen(M, Command, Stream, Result).
do_popen(Command, M, Stream, Result) :-
	popen(Command, M, Stream, Result).

win_popen(0, Command, ForReading, Result) :-
	open_pipe_streams(ForReading, ForWriting),
	exec_command(Command, 0, ForWriting, 2, _, Result),
	close(ForWriting).
win_popen(1, Command, ForWriting, Result) :-
	open_pipe_streams(Stream, ForWriting),
	exec_command(Command, ForReading, 1, 2, _, Result),
	close(ForReading).
	
check_command_with_default_shell(Com, ComF, G) :-
	check_command(Com, G),
	os_command_postprocess(Com, ComF).

%
% make sure that Windows executes the command from $COMSPEC.
%
os_command_postprocess(Com, ComF) :- win, !,
	atom_codes(Com, SC),
	append(" /c ", SC, SC1),
	getenv('COMSPEC', Shell0),
	atom_codes(Shell0, Codes),
	append(Codes, SC1, SCF),
	atom_codes(ComF, SCF).
os_command_postprocess(Com, Com).

check_command(Com, G) :- var(Com), !,
	throw(error(instantiation_error,G)).
check_command(Com, _) :- atom(Com), !.
check_command(Com, G) :-
	throw(type_error(atom,Com),G).

check_mode(Mode, _, G) :- var(Mode), !,
	throw(error(instantiation_error,G)).
check_mode(read, 0, _) :- !.
check_mode(write,1, _) :- !.
check_mode(Mode, G) :-
	throw(domain_error(io_mode,Mode),G).

shell :-
	G = shell,
	get_shell0(FullCommand),
	exec_command(FullCommand, 0, 1, 2, PID, Error),
	handle_system_error(Error, off, G),
	wait(PID, _Status, Error),
	handle_system_error(Error, off, G).

shell(Command) :-
	G = shell(Command),
	check_command(Command, G),
	get_shell(Shell),
	atom_codes(Command, SC),
	append(Shell, SC, ShellCommand),
	atom_codes(FullCommand, ShellCommand),
	exec_command(FullCommand, 0, 1, 2, PID, Error),
	handle_system_error(Error, off, G),
	wait(PID, _Status, Error),
	handle_system_error(Error, off, G).

shell(Command, Status) :-
	G = shell(Command, Status),
	check_command(Command, G),
	get_shell(Shell),
	atom_codes(Command, SC),
	append(Shell, SC, ShellCommand),
	atom_codes(FullCommand, ShellCommand),
	exec_command(FullCommand, 0, 1, 2, PID, Error),
	handle_system_error(Error, off, G),
	wait(PID, Status,Error),
	handle_system_error(Error, off, G).

get_shell0(Shell) :-
	getenv('SHELL', Shell), !.
get_shell0(Shell) :-
	win, !,
	getenv('COMSPEC', Shell0).
get_shell0('/bin/sh').

get_shell(Shell) :-
	getenv('SHELL', Shell0), !,
	atom_codes(Shell0, Codes),
	append(Codes," -c ", Shell).
get_shell(Shell) :-
	win, !,
	getenv('COMSPEC', Shell0),
	atom_codes(Shell0, Codes),
	append(Codes," /c ", Shell).
get_shell("/bin/sh -c").
	   
system :-
	default_shell(Command),
	do_system(Command, _Status, Error),
	handle_system_error(Error, off, system).

default_shell(Shell) :- win, !,
	getenv('COMSPEC', Shell).
default_shell('/bin/sh').
	

system(Command, Status) :-
	G = system(Command, Status),
	check_command(Command, G),
	do_system(Command, Status, Error),
	handle_system_error(Error, off, G).

sleep(Interval) :- var(Interval), !,
	throw(error(instantiation_error,sleep(Interval))).
sleep(Interval) :- number(Interval), !,
	( Interval =< 0 ->
	    throw(error(domain_error(not_less_than_zero,Interval),
			sleep(Interval)))
	;
	    sleep(Interval, _Remainder)
	).
sleep(Interval) :-
	throw(error(type_error(number,Interval),sleep(Interval))).

wait(PID,STATUS) :- var(PID), !,
	throw(error(instantiation_error,wait(PID,STATUS))).
wait(PID,STATUS) :- integer(PID), !,
	wait(PID, STATUS, Error),
	handle_system_error(Error, off, wait(PID,STATUS)).
wait(PID,STATUS) :-
	throw(error(type_error(integer,PID),wait(PID,STATUS))).

%
% host info
%
host_name(X) :-
	host_name(X, Error),
	handle_system_error(Error, off, host_name(X)).

host_id(X) :-
	host_id(X0, Error),
	handle_system_error(Error, off, host_id(X)),
	number_codes(X0, S),
	atom_codes(X, S).

pid(X) :-
	pid(X, Error),
	handle_system_error(Error, off, pid(X)).

kill(X,Y) :-
	integer(X), integer(Y), !,
	kill(X, Y, Error),
	handle_system_error(Error, off, kill(X,Y)).
kill(X,Y) :- (var(X) ; var(Y)), !,
	throw(error(instantiation_error,kill(X,Y))).
kill(X,Y) :- integer(X), !,
	throw(error(type_error(integer,Y),kill(X,Y))).
kill(X,Y) :-
	throw(error(type_error(integer,X),kill(X,Y))).

mktemp(X,Y) :- var(X), !,
	throw(error(instantiation_error,mktemp(X,Y))).
mktemp(X,Y) :-
	atom(X), !,
	mktemp(X, Y, Error),
	handle_system_error(Error, off, mktemp(X,Y)).
mktemp(X,Y) :-
	throw(error(type_error(atom,X),mktemp(X,Y))).

tmpnam(X) :-
	tmpnam(X, Error),
	handle_system_error(Error, off, tmpnam(X)).