menu.sa

 
---------------------------> Sather 1.1 source file <--------------------------
-- menu.sa: Tk menus
-- Author: Matthias Ernst <tisi@beutlin.desy.de>
-- Copyright (C) 1995, International Computer Science Institute
-- $Id: menu.sa,v 1.3 1996/06/27 16:33:37 holger 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 TK_MENU_CFG 
class TK_MENU_CFG is
    include TK_WIDGET_CFG_INCL
	  background->background,
	  foreground->foreground,
	  font->font,
	  borderwidth->borderwidth,
	  relief_none->relief_none,relief_raised->relief_raised,
	  relief_sunken->relief_sunken,
	  relief_flat->relief_flat,relief_ridge->relief_ridge,
	  relief_groove->relief_groove,
	  activeforeground->activeforeground,
	  activebackground->activebackground,
	  activeborderwidth->activeborderwidth,
	  disabledforeground->disabledforeground;
    
    tearoff(tearoff: BOOL) is
	config("tearoff", tearoff);
    end;
    
    tearoff(tearoff: BOOL): SAME is
	tearoff(tearoff);
	return self;
    end;
    
end; -- class TK_MENU_CFG


class TK_MENU < $TK_WIDGET 
class TK_MENU < $TK_WIDGET is
   -- a simplified version of Tk menus
   
    include TK_WIDGET_INCL{TK_MENU_CFG}
	  create ->;		-- create's aren't suitable for me
    
    private const tk_widget_type: STR := "menu";
    
    private default_config: TK_MENU_CFG is
	return TK_MENU_CFG::std
    end;
    
    private default_init(c: TK_MENU_CFG) is
	commands := #;
    end;
    
    act_on(id: INT, args: ARRAY{STR}) is
	-- ignore args
	commands[id].call
    end;
    
    -- creation needed to be overwritten since there's no packing for menus
    
    create(parent: $TK_WIDGET): SAME is 
	-- Use default packing and name
	return create(parent,"widget",default_config);
    end;
    
    create(parent: $TK_WIDGET,np: STR): SAME is 
	-- Use default packing and name
	return create(parent,np,default_config);
    end;
    
    create(parent: $TK_WIDGET,cf: TK_MENU_CFG): SAME is 
	return create(parent,"widget",cf);
    end;
    
    create(parent:$TK_WIDGET,np:STR,cf: TK_MENU_CFG): SAME is
	res ::= new;
	name ::= fix_tcl_name(np)+'u'+UNIQ::next;
	deb("Creating widget named:"+name+" specfied name:"+np);
	res.init(parent,name,cf);
	res.register;      
	eval(res.actual_widget_name,"configure", cf.str);
	
	return res;
    end;
    
    

    
    -- commands[id].call
    private attr commands: LIST{ROUT};
    
    

    -- indices into the menu are integers
    -- some special indices:
    -- (see menu manual page for explanation)
    
    -- instead of feeding special strings to index
    -- you call these and give Tk the result.
    
    -- There's one problematic index:
    --   index_active may return -1, which means 'none'
    
    -- You may however not feed -1 as index argument into a procedure
    
    
    private index(s: STR): INT is
	index_str ::= GUI_APP_END::eval(actual_widget_name+" index " + s);
	-- possibly "none"
	
	if index_str = "none" then return -1
	else return #INT(index_str)
	end;
    end;
    
    index_active: INT is
	return index("active");
    end;
    
    index_end: INT is
	return index("end");
    end;
    
    index_at(y: FLT): INT is
      return index("@"+y);
    end;
    
    

    -- adding entries
    -- with sugar for creation
    -- file_menu ::= #TK_MENU(...).
    --                    command("New",      bind(file_new)).
    --                    command("Open ...", bind(file_open)).
    --                    separator.
    --                    cascade("Language").command("English", 
    --                                              bind(set_lang("english"))).
    --                                       .command("German",
    --                                              bind(set_lang("german")))
    --                         .parent_menu.  -- end cascade
    --                    command("You got it now")
    
    
    command(label: STR, command: ROUT) is
	index ::= commands.size;
	commands.append(command);
	
	eval(path_name,"add command -label",
	     quote(label),"-command",quote("sather "+path_name+" "+index)); 
    end;
    
    command(label: STR, command: ROUT): SAME is
	command(label, command);
	return self;
    end;
    
    separator is
	eval(path_name, "add separator");
    end;
    
    separator: SAME is
	separator;
	return self;
    end;
   
    cascade(label: STR): SAME is
	-- returns empty submenu
	
	submenu ::= #SAME(self, "submenu", default_config);
	
	eval(path_name, "add cascade", "-label "
	     +quote(label), "-menu "+submenu.path_name);
	
	return submenu;
    end;
    
    parent_menu: SAME
    -- give the parent menu [of course, only if it is one]
    -- otherwise we get a runtime error
    is
	paren::=parent;
	typecase paren
	when SAME then return paren
	end;
    end;
	
    

    -- entry manipulation
    -- 
    -- for the moment, only dis/enabling is supported
    -- 
    -- dis/enabling of separators/tearoffs will be ignored
    

	
    disable(index: INT) is
	state_config(index, "-state disabled");
    end;
    
    enable(index: INT) is
	state_config(index, "-state normal");
    end;
    
    private state_config(index: INT, state: STR) is
	typestr ::= GUI_APP_END::eval(path_name + " type " + index);
	
	case typestr
	when "command", "cascade" then
	    eval(path_name, "entryconfigure", index, state);
	else			-- ignore
	end;
    end;
    
end; -- class TK_MENU