------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- 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$ -- $Date$ -- $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;