------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 199x by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  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 Doc/GPL for more details.        --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- TkApp.sa: Tk applications
-- Author: Matthias Ernst <tisi@home>

class TK_APP is
   -- Simplified Tk Application core (by gomes), which does not depend
   -- depend on as many files
   
   readonly shared tcl_tk: TCL_TK; -- the interpreter et al
   private shared callbacks: FMAP{STR, $TKKIT_CB};
   
   create(basename, classname: STR): SAME is
      if (~void(tcl_tk)) then 
	 #ERR+"Cannot create more than one root application - shared state";
      end;
      TCL_TK_COMMANDS::tkkit_cb_command := bind(exec_callback(_));
      tcl_tk := #TCL_TK(basename, classname);
      callbacks := #;
      return self;
   end;

   create_no_window(basename, classname: STR): SAME is
      if ~void(tcl_tk) then 
	 #ERR+"Cannot create more than one root application - shared state";
      end;
      TCL_TK_COMMANDS::tkkit_cb_command := bind(exec_callback(_));
      tcl_tk := TCL_TK::create_no_window(basename, classname);
      callbacks := #;
      return self;
   end;

   -- register callbacks with/out args with/out result

   cb_args_res(id: STR, cb: ROUT{ARRAY{STR}}: TUP{INT, STR}) is
      callback(#TKKIT_CB_ARGS_RES(id, cb));
   end;

   cb_res(id: STR, cb: ROUT: TUP{INT, STR}) is
      callback(#TKKIT_CB_RES(id, cb));
   end;

   cb_args(id: STR, cb: ROUT{ARRAY{STR}}) is
      callback(#TKKIT_CB_ARGS(id, cb));
   end;

   cb(id: STR, cb: ROUT) is
      callback(#TKKIT_CB(id, cb));
   end;

   exec_callback(argv:ARRAY{STR}):INT is
      -- Execute teh callback specified by the list of
      -- strings "argv"
      rout: $TKKIT_CB:= TK_APP::callback(argv[1]);
      if void(rout) then
	 raise "There's no callback named" + argv[1].pretty;
      else
	 ret: TUP{INT, STR};
	 if argv.size = 2 then
	    ret := rout.call_from_tcl(void);
	 else
	    ret := rout.call_from_tcl(argv.subarr(2, argv.size-2));
	 end;
	 C_TCL_TK::Tcl_SetResult(TK_APP::tcl_tk.interpreter, 
				 ret.t2, 
				 C_TCL_TK::ConstTclVolatile);
	 return ret.t1;
      end;
   end;

   -- you may call this directly when you want to share callbacks
   -- and don't always want to create the same bound routine
   callback(callb: $TKKIT_CB) is -- overrides old entry !
      callbacks := callbacks.insert(callb.id, callb);
   end;

   callback(id: STR): $TKKIT_CB is
      return callbacks.get(id)
   end;

end; -- class TK_APP

-------------------------------------------------------------------
