------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- 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-2016, Frank Singhoff, Alain Plantec, Jerome Legrand -- -- The Cheddar project was started in 2002 by -- Frank Singhoff, Lab-STICC UMR 6285 laboratory, 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 AUTHORS.txt and SPONSORS.txt -- -- 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: 1249 $ -- $Date: 2014-08-28 07:02:15 +0200 (Fri, 28 Aug 2014) $ -- $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;