-------------------------------------------------------------------
--           RAPID - RAPID ADA PORTABLE INTERFACE DESIGNER         
--           TCL PEER FOR THE MCC GUI PACKAGE LIBRARY 
--           Copyright (C) 1999 Martin C. Carlisle.                
--                                                                 
-- RAPID is free software;  you can  redistribute it  and/or modify
-- it under terms of the  GNU General Public License as published  
-- by the Free Software  Foundation;  either version 2,  or (at your
-- option) any later version.  RAPID 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
-- distributed with RAPID; see file COPYING.  If not, write to the 
-- Free Software Foundation,  59 Temple Place - Suite 330,  Boston, 
-- MA 02111-1307, USA.                                                 
--                                                                     
-- As a special exception, if other files instantiate generics from
-- this unit, or you link this unit with other files to produce an 
-- executable, this unit does not by itself cause the resulting 
-- executable to be covered by the GNU General Public License.  
-- This exception does not however invalidate any other reasons 
-- why the executable file might be covered by the GNU Public 
-- License.  This exception does not apply to executables which
-- are GUI design tools, or that could act as a replacement
-- for RAPID.
------------------------------------------------------------------------------
with Cargv;
with Tcl,Tcl.Tk;
with Tcl.Ada;
with Ada.Integer_Text_IO;
with Ada.Exceptions;
with Interfaces.C;
use type Interfaces.C.Int;
with Interfaces.C.Strings;
with Ada.Unchecked_Conversion;
with System;
package body peer is
   pragma Linker_Options("-ltash");
   pragma Linker_Options("-ltcl84");
   pragma Linker_Options("-ltk84");
   -- state variables
   Name_Counter : Natural := 0;     -- counter for generating names
   Interp       : Tcl.Tcl_Interp;   -- Tcl interpreter
   Have_Interp  : Boolean := False; -- is Interp initialized

   -- exceptions (shouldn't happen)
   Tcl_Error    : exception;
   Tk_Error     : exception;

   ------------------------------------
   -- Count_Image
   --
   -- return string representing count
   -- without leading space
   ------------------------------------
   function Count_Image(Count : Natural) return String is
      Result : String := Natural'image(Count);
   begin
      return Result(Result'First+1..Result'Last);
   end Count_Image;

   -----------------
   -- Create_Peer --
   -----------------

   function Create_Peer return Peer is
      Result : Peer;
   begin
      Name_Counter  := Name_Counter + 1;
      Result.Name   := new String'(".name" & count_image(name_counter));
      Result.Lookup := 0;
      return Result;
   end Create_Peer;

   -----------------
   -- Create_Peer --
   -----------------

   function Create_Peer (Parent : in Peer) return Peer is
      Result : Peer;
   begin
      Name_Counter  := Name_Counter + 1;
      Result.Lookup := 0;
      if Parent.Name.all = "." then
         Result.Name := new String'(".name" & count_image(name_counter));
      else
         Result.Name := new String'(
            Parent.Name.all & ".name" & count_image(name_counter));
      end if;
      return Result;
   end Create_Peer;


   ----------------------------------
   -- Initialize_Interp
   ----------------------------------
   procedure Initialize_Interp is
      Argc         : Interfaces.C.Int;
      Argv         : CArgv.Chars_Ptr_Ptr;
   begin
      -- Get command-line arguments and put them into C-style "argv"
      --------------------------------------------------------------
      CArgv.Create (Argc, Argv);

      -- Tcl needs to know the path name of the executable
      -- otherwise Tcl.Tcl_Init below will fail.
      ----------------------------------------------------
      Tcl.Tcl_FindExecutable (Argv.all);
      Interp := Tcl.Tcl_Createinterp;

      if Tcl.Tcl_Init (Interp) = Tcl.Tcl_Error then
         Ada.Exceptions.raise_Exception(Tcl_Error'identity,
            Tcl.Ada.Tcl_GetStringResult(Interp));
      end if;

      if Tcl.Tk.Tk_Init (Interp) = Tcl.Tcl_Error then
         Ada.Exceptions.raise_Exception(Tk_Error'identity,
            Tcl.Ada.Tcl_GetStringResult(Interp));
      end if;

      Have_Interp := True;
   end Initialize_Interp;

   ---------------------------------------------------
   -- Get_Interp
   --
   -- returns Interp, initializing if needed
   ---------------------------------------------------
   function Get_Interp return Tcl.Tcl_Interp is
   begin
      if not Have_Interp then
         Initialize_Interp;
      end if;

      return Interp;
   end Get_Interp;

   -------------------------
   -- Eval 
   --
   -- calls Tcl.Ada.Tcl_Eval
   -------------------------
   procedure Eval(Expression : in String) is
   begin
      if not Have_Interp then
         Initialize_Interp;
      end if;

      Tcl.Ada.Tcl_Eval(Interp,Expression);
   end Eval;

   --------------------------------------------------
   -- To_Hex_String
   --
   -- converts a number to a Hexadecimal string
   --------------------------------------------------
   function To_Hex_String(
      Number : in Natural;
      Width  : in Natural := 6) return String is
      Result : String(1..Natural'Width);
      First  : Natural;
      Length : Natural;
   begin
      Ada.Integer_Text_IO.Put(To => Result,
         Item => Number,
         Base => 16);
      for i in Result'Range loop
         if Result(i) = '#' then
            First := i+1; -- skip 16#
            exit;
         end if;
      end loop;
      Length := Result'Last-First;
      if Width > Length then
         declare
            Zero : String(1..Width-Length) := (others => '0');
         begin
            return Zero & Result(First..Result'Last-1);
         end;
      else
         return Result(First..Result'Last-1);
      end if;
   end To_Hex_String;

   function Fix_Quotes(Text : in String) return String is
      Result : String(1..Text'Length*2);
      Last   : Natural := 0;
   begin
      for i in Text'Range loop
         if Text(i) = '"' then
            Result(Last+1) := '\';
            Result(Last+2) := '"';
            Last := Last + 2;
         elsif Text(i) = '[' then
            Result(Last+1) := '\';
            Result(Last+2) := '[';
            Last := Last + 2;
         elsif Text(i) = '\' then
            Result(Last+1) := '\';
            Result(Last+2) := '\';
            Last := Last + 2;
         else
            Result(Last+1) := Text(i);
            Last := Last + 1;
         end if;
      end loop;

      return Result(1..Last);
   end Fix_Quotes;

   function Unescape(Text : in String) return String is
      Result : String(1..Text'Length);
      Last   : Natural := 0;
      Previous_Was_Escape : Boolean := False;
   begin
      for i in Text'Range loop
         if Text(i) = '\' then
            if Previous_Was_Escape then
               Result(Last+1) := '\';
               Previous_Was_Escape := False;
               Last := Last + 1;
            else
               Previous_Was_Escape := True;
            end if;
         else
            Previous_Was_Escape := False;
            Result(Last+1) := Text(i);
            Last := Last + 1;
         end if;
      end loop;

      return Result(1..Last);
   end Unescape;

      -- return name with "." converted to "_", remove 1st '.'
   function Undot_Name(Name : in String) return String is
      Result : String := Name;
   begin
      for i in Result'range loop
         if Result(i) = '.' or else Result(i) = ' ' then
            Result(i) := '_';
         end if;
      end loop;

      return Result(Result'First+1..Result'Last);
   end Undot_Name;

   -- return the value of a Tcl variable as a string
   procedure Get_Value(
         Name : in String;
         Result : out String;
         Last : out Natural) is
      Answer : Interfaces.C.Strings.Chars_Ptr;
      Variable_Name   : constant String := Name & Character'First;
      function Convert is new Ada.Unchecked_Conversion(System.Address,
         Interfaces.C.Strings.Chars_Ptr);
   begin -- Get_Value
      Answer := Tcl.Tcl_Getvar(Interp,Convert(Variable_Name'Address),0);
      Last := Result'First+Integer(Interfaces.C.Strings.Strlen(Answer))-1;
      Result(Result'First..Last) := Interfaces.C.Strings.Value(Answer);
   exception when Constraint_Error =>
      Last := Result'First-1;
   end Get_Value;

   -- return the value of a Tcl variable as an integer
   procedure Get_Value(
         Name : in String;
         Result : out Integer) is
      Answer : Interfaces.C.Strings.Chars_Ptr;
      Variable_Name   : constant String := Name & Character'First;
      function Convert is new Ada.Unchecked_Conversion(System.Address,
         Interfaces.C.Strings.Chars_Ptr);
   begin -- Get_Value
      Answer := Tcl.Tcl_Getvar(Interp,Convert(Variable_Name'Address),0);
      Result := Integer'Value(Interfaces.C.Strings.Value(Answer));
   exception when others =>
      Result := -1;
   end Get_Value;

end peer;
