---------------------------------------------------------------
--                                                           
--  RAPID - Rapid Ada Portable Interface Designer     
--                                                           
--  TCL_UTILITIES.ADB
--  Description : Useful utilities for RAPID programmers
--                       
--  By: Martin Carlisle, Patrick Maes and Jonathan Busch
--                                         
-- RAPID is free software; you can redistribute it and/or 
-- modify it without restriction.  However, we ask that you
-- please retain the original author information, and clearly  
-- indicate if it has been modified.
--
-- 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.  
--
---------------------------------------------------------------
with Tcl.Ada;
with Interfaces.C.Strings;
with System;
with Ada.Integer_Text_IO,Ada.Float_Text_IO;
with Ada.Unchecked_Conversion;
with Ada.Characters.Handling;
with Mcc.Common_Dialogs; -- for debugging

package body Tcl_Utilities is


   -- return True if File1 is newer than File2
   -- or File2 doesn't exist.
   function Is_Newer(Interp : Tcl.Tcl_Interp;
      File1 : in String;
      File2 : in String) return Boolean is
      Time1, Time2 : Integer;
   begin
      Tcl.Ada.Tcl_Eval(Interp,"set time1 [file mtime " &
         Fix_Quotes(File1) & "]");
      begin
         Tcl.Ada.Tcl_Eval(Interp,"set time2 [file mtime " &
            Fix_Quotes(File2) & "]");
      exception when others => return true;
      end;

      Get_Value(Interp,"time1",Time1);
      Get_Value(Interp,"time2",Time2);
      return Time1 > Time2;
   end Is_Newer;

   procedure Destroy_Window(Interp : Tcl.Tcl_Interp;
      Window_Name : in String) is
   begin
      if Window_Name(Window_Name'First) = '.' then
         Tcl.Ada.Tcl_Eval(Interp,"destroy " & Window_Name);
      elsif Ada.Characters.Handling.To_Lower(Window_Name) = "main" then
         Tcl.Ada.Tcl_Eval(Interp,"destroy .");
      else
         Tcl.Ada.Tcl_Eval(Interp,"destroy ." & Window_Name);
      end if;
   end Destroy_Window;

   -- change the title displayed for a window
   procedure Change_Window_Title(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Title       : in String) is
   begin
      if Window_Name(Window_Name'First) = '.' then
         Tcl.Ada.Tcl_Eval(Interp,"wm title " & Window_Name & " """ &
            Fix_Quotes(Title) & '"');
      elsif Ada.Characters.Handling.To_Lower(Window_Name) = "main" then
         Tcl.Ada.Tcl_Eval(Interp,"wm title . """ &
            Fix_Quotes(Title) & '"');
      else
         Tcl.Ada.Tcl_Eval(Interp,"wm title . " & Window_Name & " """ &
            Fix_Quotes(Title) & '"');
      end if;
   end Change_Window_Title;

   -- return the value of a Tcl variable as a string
   procedure Get_Value(Interp : Tcl.Tcl_Interp;
         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(Interp : Tcl.Tcl_Interp;
         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;

   function Window_Object_To_Name(Window_Name : in String;
      Name : in String) return String is
   begin
      if Window_Name = "." then
         return "." & Name;
      elsif Window_Name(Window_Name'First) = '.' then
         return Window_Name & "." & Name;
      elsif Ada.Characters.Handling.To_Lower(Window_Name) = "main" then
         return "." & Name;
      else
         return "." & Window_Name & "." & Name;
      end if;
   end Window_Object_To_Name;

   -- clear the text entry window
   procedure Clear_Text_Entry(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String) is
   begin
       Tcl.Ada.Tcl_Eval(Interp,
          Window_Object_To_Name(Window_Name,Name) &
          " delete 0 end");
   end Clear_Text_Entry;

   procedure Get_Text_Entry(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      Result      : out String;
      Last        : out Natural) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         "set entry_text [ " & Window_Object_To_Name(Window_Name,Name) &
         " get ]");
      Get_Value(Name => "entry_text",
         Interp => Interp,
         Result => Result,
         Last => Last);
   end Get_Text_Entry;

   procedure Get_Text_Entry(Interp : Tcl.Tcl_Interp;
         Window_Name : in String;
         Name        : in String;
         Result      : out Integer) is
      Result_String : String(1..80);
      Result_Length : Natural;
   begin
      Get_Text_Entry(Interp,Window_Name,Name,Result_String,Result_Length);
      Ada.Integer_Text_IO.Get(
         From => Result_String(Result_String'First..Result_Length),
         Item => Result,
         Last => Result_Length);
   end Get_Text_Entry;

   procedure Get_Text_Entry(Interp : Tcl.Tcl_Interp;
         Window_Name : in String;
         Name        : in String;
         Result      : out Float) is
      Result_String : String(1..80);
      Result_Length : Natural;
   begin
      Get_Text_Entry(Interp,Window_Name,Name,Result_String,Result_Length);
      Ada.Float_Text_IO.Get(
         From => Result_String(Result_String'First..Result_Length),
         Item => Result,
         Last => Result_Length);
   end Get_Text_Entry;

   procedure Set_Text_Entry(Interp : Tcl.Tcl_Interp;
         Window_Name : in String;
         Name        : in String;
         Text        : in String) is
   begin
      Clear_Text_Entry(Interp,Window_Name,Name);
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " insert insert {" & Text & "}");
   end Set_Text_Entry;

   -- wbw 15 Apr 99, internal procedure
   procedure Get_Scale_Value(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      Result      : out String;
      Last        : out Natural) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         "set scale_value [ " & Window_Object_To_Name(Window_Name,Name) &
         " get ]");
      Get_Value(Name => "scale_value",
         Interp => Interp,
         Result => Result,
         Last => Last);
   end Get_Scale_Value;

   -- wbw 15 Apr 99, user procedure
   procedure Get_Scale_Value(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      Value       : out Float) is
      Result_String : String(1..80);
      Result_Length : Natural;
   begin
      Get_Scale_Value(Interp,Window_Name,Name,Result_String,Result_Length);
      Ada.Float_Text_IO.Get(
         From => Result_String(Result_String'First..Result_Length),
         Item => Value,
         Last => Result_Length);
   end Get_Scale_Value;

   -- wbw 15 Apr 99
   procedure Set_Scale_Value(Interp : Tcl.Tcl_Interp;
         Window_Name : in String;
         Name        : in String;
         Value       : in String) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " set {" & Value & "}");
   end Set_Scale_Value;
   
   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;
         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;

   procedure Highlight_Text_Entry(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " selection range 0 end");
      Tcl.Ada.Tcl_Eval(Interp,
         "focus " &
         Window_Object_To_Name(Window_Name,Name));
   end Highlight_Text_Entry;

   procedure Select_Box(Interp : Tcl.Tcl_Interp;
         Window_Name : in String;
         Name        : in String) is

   begin
      Tcl.Ada.Tcl_Eval(Interp,Window_Object_To_Name(Window_Name,Name) & " select");
   end Select_Box;



   procedure Deselect_Box(Interp : Tcl.Tcl_Interp;
         Window_Name : in String;
         Name        : in String) is

   begin
      Tcl.Ada.Tcl_Eval(Interp,Window_Object_To_Name(Window_Name,Name) & " deselect");
   end Deselect_Box;


   function Is_Checked(Interp : Tcl.Tcl_Interp;
         Name        : in String) return Boolean is

      Result : Integer;

   begin
      Get_Value(Interp,Name,Result);
      return (Result = 1);
   end Is_Checked;
   procedure Set_Widget_Color(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      FG_Color	  : in String;
      BG_Color    : in String) is

   begin --Set_Widget_Color
       Tcl.Ada.Tcl_Eval(Interp,
          Window_Object_To_Name(Window_Name,Name) &
          " configure -fg " & FG_Color &
	  " -bg " & BG_Color);
   end Set_Widget_Color;

   procedure Change_Label_Text(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      New_Text	  : in String) is

   begin --Change_Label_Text
       Tcl.Ada.Tcl_Eval(Interp,
          Window_Object_To_Name(Window_Name,Name) &
          " configure -text {" & New_Text & "}");
   end Change_Label_Text;

   procedure Append_Listbox_Text(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      New_Text	  : in String) is

   begin --Append_Listbox_Text
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) & '.' & Name &
         " insert end """ & New_Text & '"');
   end Append_Listbox_Text;

   procedure Prepend_Listbox_Text(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      New_Text	  : in String) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) & '.' & Name &
         " insert 0 """ & Fix_Quotes(New_Text) & '"');
   end Prepend_Listbox_Text;

   procedure Insert_Listbox_Text(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      New_Text	  : in String;
      Position    : in Natural) is

   begin --Insert_Listbox_Text
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) & '.' & Name &
         " insert " & Integer'Image(Position) & " """ &
         Fix_Quotes(New_Text) & '"');
   end Insert_Listbox_Text;

   --Remove all entries from listbox
   procedure Clear_Listbox(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) & '.' & Name &
         " delete 0 end");
   end Clear_Listbox;

   --Remove some entries from listbox
   --1 is first, 2 is second...
   procedure Delete_Listbox_Entries(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      From        : in Positive;
      To          : in Positive) is
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) & '.' & Name &
         " delete " & Natural'Image(From-1) & Natural'Image(To-1));
   end Delete_Listbox_Entries;

   -- return which item in Listbox is selected
   -- 1 is first, 2 is second,...
   function Listbox_Selected(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String) return Natural is
      Result : Integer;
   begin
      Tcl.Ada.Tcl_Eval(Interp,
         "set index [" &
         Window_Object_To_Name(Window_Name,Name) & '.' & Name &
         " curselection]");
      Get_Value(
         Interp => Interp,
         Name   => "index",
         Result => Result);
      return Result + 1;
   exception
      when others => return 0;
   end Listbox_Selected;

   procedure Activate_Button(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String) is

   begin --Activate_Button
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " configure -state normal");
   end Activate_Button;

   procedure Disable_Button(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String) is

   begin --Disable_Button
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " configure -state disabled");
   end Disable_Button;

   procedure Activate_Menu_Item(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      Index       : in Natural) is
   begin --Activate_Menu_Item
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " entryconfigure " & Integer'Image(Index) & " -state normal");
   end Activate_Menu_Item;

   procedure Disable_Menu_Item(Interp : Tcl.Tcl_Interp;
      Window_Name : in String;
      Name        : in String;
      Index       : in Natural) is
   begin --Disable_Menu_Item
      Tcl.Ada.Tcl_Eval(Interp,
         Window_Object_To_Name(Window_Name,Name) &
         " entryconfigure " & Integer'Image(Index) & " -state disabled");
   end Disable_Menu_Item;

end Tcl_Utilities;