1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195 | ------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- Cheddar is a GNU GPL real-time scheduling analysis tool.
-- This program provides services to automatically check schedulability and
-- other performance criteria of real-time architecture models.
--
-- Copyright (C) 2002-2023, Frank Singhoff, Alain Plantec, Jerome Legrand,
-- Hai Nam Tran, Stephane Rubini
--
-- The Cheddar project was started in 2002 by
-- Frank Singhoff, Lab-STICC UMR 6285, Université de Bretagne Occidentale
--
-- Cheddar has been published in the "Agence de Protection des Programmes/France" in 2008.
-- Since 2008, Ellidiss technologies also contributes to the development of
-- Cheddar and provides industrial support.
--
-- The full list of contributors and sponsors can be found in README.md
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- 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
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--
--
-- Contact : cheddar@listes.univ-brest.fr
--
------------------------------------------------------------------------------
-- Last update :
-- $Rev: 4589 $
-- $Date: 2023-09-29 16:02:19 +0200 (ven., 29 sept. 2023) $
-- $Author: singhoff $
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- PACKAGE BODY: Pipe_Commands
--
-- PURPOSE: Implementation of a thick Ada binding for calling the popen and
-- pclose commands imported from C.
--------------------------------------------------------------------------------
with Interfaces.C; use Interfaces.C;
with Ada.Characters.Latin_1;
package body pipe_commands is
lf : constant Integer :=
Character'pos (Ada.Characters.Latin_1.LF); -- Unix end of line
-----------------------------------------------------------------------
-- INTERNAL FUNCTION: Popen
--
-- PURPOSE: Thin binding to the C "popen" command, used by the Execute
-- function.
-----------------------------------------------------------------------
function popen (command : char_array; mode : char_array) return files;
pragma import (C, popen);
-----------------------------------------------------------------------
-- INTERNAL FUNCTION: pclose
--
-- PURPOSE: Thin binding to the C "pclose" command, used by the Close
-- procedure.
-----------------------------------------------------------------------
function pclose (filestream : files) return Integer;
pragma import (C, pclose);
-----------------------------------------------------------------------
-- INTERNAL FUNCTION: fgetc
--
-- PURPOSE: Thin binding to the C "fgetc" function, used by Get_Next
-- function
-----------------------------------------------------------------------
-----------------------------------------------------------------------
-- INTERNAL FUNCTION: fputc
--
-- PURPOSE: Thin binding to the C "fput" function, used by Write_Next
-- function
-----------------------------------------------------------------------
function fgetc (c_stream : in files) return Integer;
pragma import (C, fgetc);
function fputc (c : Integer; stream : files) return Integer;
pragma import (C, fputc);
-----------------------------------------------------------------------
-- FUNCTION: Execute
--
-- PURPOSE: This command executes the process indicated in the Command
-- parameter, setting I/O according to the IO_Type parameter.
--
-- RETURN VALUE: The stream corresponding to the opened pipe, including
-- the C file pointer and the mode for which the pipe was
-- opened.
-- EXCEPTIONS RAISED: None
-----------------------------------------------------------------------
function execute
(command : in String;
io_type : in io_mode) return stream
is
result : stream;
begin
case io_type is
when read_file =>
result.filestream := popen (To_C (command), To_C ("r"));
when write_file =>
result.filestream := popen (To_C (command), To_C ("w"));
end case;
result.mode := io_type;
return result;
end execute;
-----------------------------------------------------------------------
-- FUNCTION: Read_Next
--
-- PURPOSE: Reads the next line from the stream indicated by the parameter
-- FromFile, returning an unbounded string.
-- RETURN VALUE: An unbounded string containing the line read from the
-- stream.
--
-- EXCEPTIONS RAISED:
-- Access_Error => when the stream was opened with write_file mode
-- End_Of_File => when the pipe is closed (the program indicated
-- by the parameter FromFile terminates).
-----------------------------------------------------------------------
function read_next (fromfile : in stream) return Unbounded_String is
result : Unbounded_String := Null_Unbounded_String;
char_buf : Integer;
c_constant_eof : Integer;
pragma import (C, c_constant_eof, "__gnat_constant_eof");
eof : constant Integer := c_constant_eof;
begin
if fromfile.mode = write_file then
raise access_error;
end if;
--------------------------------------------------------------------
-- Read characters one at a time until a line feed character is
-- encountered, indicating an end of line. The line feed character
-- is NOT included in the returned unbounded string.
--------------------------------------------------------------------
loop
char_buf := fgetc (fromfile.filestream);
if char_buf = eof then
raise end_of_file;
end if;
exit when char_buf = lf;
result := result & Character'val (char_buf);
end loop;
return result;
end read_next;
-----------------------------------------------------------------------
-- PROCEDURE: Write_Next
--
-- PURPOSE: Write a line of input to the stream indicated by the
-- parameter ToFile.
--
-- EXCEPTIONS RAISED:
-- Access_Error => when the stream was opened with mode Read_File
-----------------------------------------------------------------------
procedure write_next (tofile : in stream; message : in String) is
rc : Integer;
begin
if tofile.mode = read_file then
raise access_error;
end if;
for i in message'range loop
rc := fputc (Character'pos (message (i)), tofile.filestream);
end loop;
rc := fputc (lf, tofile.filestream); -- add end of line
end write_next;
-----------------------------------------------------------------------
-- PROCEDURE: Close
--
-- PURPOSE: Close the stream to the parameter OpenFile
--
-- EXCEPTIONS RAISED: None
-----------------------------------------------------------------------
procedure close (openfile : in stream) is
rc : Integer;
begin
rc := pclose (openfile.filestream);
end close;
end pipe_commands;
|