gui.sa

 
---------------------------> Sather 1.1 source file <--------------------------
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>
-- Copyright (C) 1995, International Computer Science Institute
-- gui.sa,v 1.2 1995/11/29 14:07:59 gomes Exp
--
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.


class GUI_APP_END 
class GUI_APP_END is
   -- The application-end code for the GUI.
   -- Though, the application programmer will normally use only
   -- GUI_UTIL and the Widget classes.
    
   shared debug: BOOL := false;	-- Debug the sather code
   shared tcldebug: BOOL := false; -- Print out the tcl code sent in both 
   -- directions
   shared is_done: BOOL := false; -- True when the application is done
   -- and must quit
   shared tcl_tk:TCL_TK;	-- Set up to point to the interpreter
   
   startup is
      sather_home ::= UNIX::sather_home;
      deb("Starting tcl, initializing...");
      TCL_TK_COMMANDS::sather_command := bind(exec_callback(_));
      tcl_tk := #TCL_TK("SatherGui",sather_home+"/");
      INIT_GUI::gui_setup(tcl_tk);
      INIT_GUI::gui_post_socket_init(tcl_tk);
   end;
    
   terminate is UNIX::exit(0); end;
    
   main_loop is tcl_tk.main_loop end;
    
   private init is
      deb("Done with init");
   end;
    
   eval(s: STR): STR is
      res ::= tcl_tk.eval(s);
      if tcldebug then #ERR+s+"\n"; end;
      return res;
   end;
    
   eval(s: STR) is 
      res ::= tcl_tk.eval(s);
      if tcldebug then #ERR+s+"\n"; end;
      if debug then deb("Sent string") end;
   end;
    
   exec_callback(argv: ARRAY{STR}) is
      -- Three special callbacks are
      -- "poll"  Poll sather for more commands
      -- "debug" Turn on debugging flag
      -- "nodebug" Turn off debugging flag
      command_name ::= argv[1];
      if command_name = "poll" then ;
      elsif command_name = "server_debug" then ;
      elsif command_name = "server_tcldebug" then ;
      else
	 raw_args:ARRAY{STR}:= #(argv.size-2);
	 widget_name: STR := command_name;
	 i ::= 2; loop until!(i=argv.size);
	    raw_args[i-2] := argv[i]; i := i + 1; 
	 end;
	 if debug then deb("Executing callback with:"+arr_str(argv)); end;
	 if widget_name="app_debug"  then 
	    debval ::= raw_args[0];
	    if debval = "true" then
	       debug:=true;
	       deb("gui_app_end: turned on app debugging");
	    else
	       deb("gui_app_end: turning off app debugging");
	       debug := false;
	    end;
	 elsif widget_name="app_tcldebug"  then 
	    debval ::= raw_args[0];
	    if debval = "true" then 
	       tcldebug := true;
	       deb("gui_app_end: turned on tcldebug debugging");
	    else
	       deb("gui_app_end: turning off tcldebug debugging");
	       tcldebug := false;
	    end;
	 else
	    if raw_args.size < 1 then raise "Not enough arguments!"  end;
	    if debug then deb("Converting id to int") end;
	    action_id ::= to_int(raw_args[0]);
	    if debug then deb("Action id is:"+action_id); end;
	    widget: $TK_WIDGET := TK_WIDGET_MAP::get_widget(widget_name);
	    if debug then deb("Calling command...") end;
	    widget.act_on(action_id,raw_args);
	 end;
	 C_TCL_TK::Tcl_SetResult(tcl_tk.interpreter, 
				 "DontCare",
				 C_TCL_TK::ConstTclVolatile);
	 if debug then deb("Set tcl result to DontCare"); end;
      end;
   end;
    
   shutdown is
      UNIX::exit(0);
   end;
    
   private arr_str(a: ARRAY{STR}): STR is
      res ::= "";  loop res := res+" "+a.elt!; end;   return res;
   end;
    
   private int_if_poss(s: STR,default: INT): INT is
      c ::= #STR_CURSOR(s);
      res ::= c.int;
      if c.has_error then return default  else return res end;
   end;
   
   private to_int(s: STR): INT is
      c ::= #STR_CURSOR(s);
      res ::= c.int;
      if c.has_error then raise "Error in converting:"+s+" to int\n";  end;
      return res;
   end;
    
   deb(s: STR) is
      if debug then #ERR+"gui_server_end: "+s+"\n" end;
   end;
    
end; -- class GUI_SERVER_END