The R13B03 release.OTP_R13B03

1 files changed, 412 insertions, 0 deletions

diff --git a/lib/gs/src/gstk_db.erl b/lib/gs/src/gstk_db.erl
new file mode 100644
index 0000000000..849784574f
--- /dev/null
+++ b/lib/gs/src/gstk_db.erl
@@ -0,0 +1,412 @@
+%%
+%% %CopyrightBegin%
+%% 
+%% Copyright Ericsson AB 1996-2009. All Rights Reserved.
+%% 
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%% 
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%% 
+%% %CopyrightEnd%
+%%
+
+%%
+%% ------------------------------------------------------------
+%%
+%% Database interface for `gstk'.
+%% 
+%% ------------------------------------------------------------
+
+-module(gstk_db).
+
+-export([init/1,
+	 insert/3,
+	 lookup/2,
+	 lookup_event/3,
+	 insert_bgrp/2,
+	 delete_bgrp/2,
+	 insert_gs/2,
+	 insert_widget/2,
+	 delete_kid/3,
+	 insert_opts/3,
+	 lookup_def/3,
+	 opt_or_not/3,
+	 lookup_gstkid/3,
+	 lookup_ids/2,
+	 lookup_item/3,
+	 delete_widget/2,
+	 delete_gstkid/2,
+	 get_deleted/1,
+	 delete_event/3,
+	 insert_event/4,
+	 update_widget/2,
+	 is_inserted/3,
+	 lookup_kids/2,
+	 insert_def/3,
+	 opt/4,
+	 opt/3,
+	 insert_opt/3,
+	 default_container_opts/3,
+	 default_opts/3,
+	 counter/2,
+	 lookup_gstkid/2]).
+
+-include("gstk.hrl").
+
+
+%% ------------------------------------------------------------
+%%                      INITIALIZATION
+%% ------------------------------------------------------------
+
+init(_Opts) ->
+    put(events,ets:new(gstk_db, [public, set])),
+    put(kids,ets:new(gstk_db, [public, bag])),
+    put(defaults,ets:new(gstk_db, [public, bag])),
+    put(deleted,ets:new(gstk_db, [public, bag])),
+    put(options,ets:new(gstk_db, [public, set])),
+    ets:new(gstk_db, [public, set]).
+
+%% -----------------------------------------------------------------
+%%                 PRIMITIVE DB INTERFACE
+%% -----------------------------------------------------------------
+
+insert(DB, Key, Value) ->
+    ets:insert(DB, {Key, Value}).
+
+
+lookup(DB, Key) ->
+    Result =
+	case ets:lookup(DB, Key) of
+	    [{Key, Value}] -> Value;
+	    _ -> undefined
+	end,
+    Result.
+
+
+delete(DB, Key) ->
+    ets:delete(DB, Key).
+
+
+
+%% -----------------------------------------------------------------
+%%               NOT SO PRIMITIVE DB INTERFACE
+%% -----------------------------------------------------------------
+
+%% -----------------------------------------------------------------
+%%                  HANDLE EVENTS
+%% -----------------------------------------------------------------
+insert_event(DB, Gstkid, Etype, Edata) ->
+    ID = Gstkid#gstkid.id,
+    Rdata =
+	case Edata of
+	    [] -> opt(DB,ID,data);
+	    _Other1 -> Edata
+	end,
+    Events = lookup_events(DB, ID),
+    case lists:keysearch(Etype, 2, Events) of
+	{value, {Etag, _, _}} ->
+	    NewEvents =
+		lists:keyreplace(Etype, 2, Events, {Etag, Etype, Rdata}),
+	    ets:insert(get(events), {{events, ID}, NewEvents}),
+	    [$#, gstk:to_ascii(ID), " ", Etag];
+	_Other2 ->
+	    Etag = etag(Etype),
+	    NewEvents = [{Etag, Etype, Rdata} | Events],
+	    ets:insert(get(events), {{events, ID}, NewEvents}),
+	    [$#, gstk:to_ascii(ID), " ", Etag]
+    end.
+
+etag(Etype) ->
+    case Etype of
+	click -> "c";
+	doubleclick -> "dc";
+	configure -> "co";
+	enter -> "e";
+	leave -> "l";
+	motion -> "m";
+	buttonpress -> "bp";
+	buttonrelease -> "br";
+	focus -> "f";
+	destroy -> "d";
+	keypress -> "kp";
+	keyrelease -> "kr"
+    end.
+
+lookup_events(_DB, ID) ->
+    case lookup(get(events), {events, ID}) of
+	undefined -> [];
+	Events -> Events
+    end.
+
+lookup_event(DB, ID, Etag) ->
+    case lists:keysearch(Etag, 1, lookup_events(DB, ID)) of
+	{value, {Etag, Etype, Edata}} ->
+	    {Etype, Edata};
+	_Other ->
+	    nonexisting_event
+    end.
+
+delete_event(DB, Gstkid, Etype) ->
+    ID = Gstkid#gstkid.id,
+    NewEvents = lists:keydelete(Etype, 2, lookup_events(DB, ID)),
+    ets:insert(get(events), {{events, ID}, NewEvents}).
+
+%% -----------------------------------------------------------------
+%%                  HANDLE BUTTON GROUPS
+%% -----------------------------------------------------------------
+insert_bgrp(DB, Key) ->
+    case ets:lookup(DB, Key) of
+	[] ->
+	    {_Bgrp, RG, _Owner} = Key,
+	    insert(DB, Key, {0, RG}),
+	    RG;
+	[{_, {Counter, RG}}] ->
+	    insert(DB, Key, {Counter+1, RG}),
+	    RG
+    end.
+
+
+delete_bgrp(DB, Key) ->
+    case ets:lookup(DB, Key) of
+	[] ->
+	    true;
+	[{_, {0, _RG}}] ->
+	    delete(DB, Key),
+	    true;
+	[{_, {Counter, RG}}] ->
+	    insert(DB, Key, {Counter-1, RG}),
+	    true
+    end.
+
+
+%% -----------------------------------------------------------------
+%%  insert things
+
+update_widget(DB, Gstkid) ->
+    ID = Gstkid#gstkid.id,
+    insert(DB, ID, Gstkid),
+    Gstkid.
+
+insert_gs(DB,Gstkid) ->
+    update_widget(DB,Gstkid).
+
+insert_widget(DB, Gstkid) ->
+    ID = Gstkid#gstkid.id,
+    insert_kid(DB, Gstkid#gstkid.parent, ID),
+    insert(DB, ID, Gstkid),
+    Gstkid.
+
+insert_kid(_DB, Parent, Kid) ->
+    ets:insert(get(kids), {{kids, Parent},Kid}).
+
+delete_kid(_DB, Parent, Kid) ->
+    ets:match_delete(get(kids), {{kids, Parent},Kid}).
+
+lookup_kids(_DB, Parent) ->
+    ril(ets:match(get(kids), {{kids, Parent},'$1'})).
+
+%%----------------------------------------------------------------------
+%% Options are stored as {{Id,Opt},Val}
+%%----------------------------------------------------------------------
+insert_opt(_DB,Id,{default,ObjType,Opt}) ->
+    insert_def(Id,ObjType,Opt);
+insert_opt(_DB,#gstkid{id=Id},{Key,Val}) ->
+    ets:insert(get(options),{{Id,Key},Val});
+insert_opt(_DB,Id,{Key,Val}) ->
+    ets:insert(get(options),{{Id,Key},Val}).
+
+insert_opts(_DB,_Id,[]) -> done;
+insert_opts(DB,Id,[Opt|Opts]) ->
+    insert_opt(DB,Id,Opt),
+    insert_opts(DB,Id,Opts).
+
+insert_def(#gstkid{id=ID},ObjType,{Key,Val}) ->
+    insert_def(ID,ObjType,{Key,Val});
+insert_def(ID,ObjType,{Key,Val}) ->
+    Def = get(defaults),
+    ets:match_delete(Def,{{ID,ObjType},{Key,'_'}}),
+    ets:insert(Def,{{ID,ObjType},{Key,Val}}).
+
+lookup_def(ID,ObjType,Key) ->
+    case ets:match(get(defaults),{{ID,ObjType},{Key,'$1'}}) of
+	[] -> false;
+	[[Val]] -> {value,Val}
+    end.
+
+opt(DB,#gstkid{id=Id},Opt) -> opt(DB,Id,Opt);
+opt(_DB,Id,Opt) ->
+    [{_, Value}] = ets:lookup(get(options), {Id,Opt}),
+    Value.
+
+opt_or_not(DB,#gstkid{id=Id},Opt) -> opt_or_not(DB,Id,Opt);
+opt_or_not(_DB,Id,Opt) ->
+    case ets:lookup(get(options), {Id,Opt}) of
+	[{_, Value}] -> {value, Value};
+	_ -> false
+    end.
+
+opt(DB,#gstkid{id=Id},Opt,ElseVal) -> opt(DB,Id,Opt,ElseVal);
+opt(_DB,Id,Opt,ElseVal) ->
+    case ets:lookup(get(options), {Id,Opt}) of
+	[{_, Value}] ->
+	    Value;
+	_ -> ElseVal
+    end.
+
+%%----------------------------------------------------------------------
+%% Returns: list of {Key,Val}
+%%----------------------------------------------------------------------
+default_container_opts(_DB,Id,ChildType) ->
+    L =	ets:match(get(defaults),{{Id,'$1'},'$2'}),
+    lists:sort(fix_def_for_container(L,ChildType)).
+
+default_opts(_DB,Id,ChildType) ->
+    L1 = ets:lookup(get(defaults),{Id,ChildType}),
+    L2 = ets:lookup(get(defaults),{Id,all}),
+    lists:sort(fix_def(L1,L2)).
+
+fix_def([{_,Opt}|Opts],Opts2) ->
+    [Opt|fix_def(Opts,Opts2)];
+fix_def([],[]) -> [];
+fix_def([],Opts) ->
+    fix_def(Opts,[]).
+
+%%----------------------------------------------------------------------
+%% Purpose: Extracs {default,ObjType,DefsultOpt} for the ChildType
+%% and keeps default options since it is a container object.
+%% Returns: list of options
+%%----------------------------------------------------------------------
+fix_def_for_container([[all,{Key,Val}]|Opts],ChildType) ->
+    [{{default,all,Key},Val},{Key,Val}
+     |fix_def_for_container(Opts,ChildType)];
+fix_def_for_container([[ChildType,{Key,Val}]|Opts],ChildType) ->
+    [{{default,ChildType,Key},Val},{Key,Val}
+     |fix_def_for_container(Opts,ChildType)];
+fix_def_for_container([[ChildType2,{Key,Val}]|Opts],_ChildType) ->
+    [{{default,ChildType2,Key},Val}|fix_def_for_container(Opts,ChildType2)];
+fix_def_for_container([],_) -> [].
+
+%% -----------------------------------------------------------------
+%%  lookup things
+
+lookup_gstkid(DB, Name, Owner) when is_atom(Name) ->
+    ID = lookup(DB, {Owner, Name}),
+    lookup(DB, ID);
+
+lookup_gstkid(DB, ID, _Owner) ->
+    lookup(DB, ID).
+
+
+lookup_gstkid(_DB, Name) when is_atom(Name) ->
+    exit({'must use owner',Name});
+
+lookup_gstkid(DB, ID) ->
+    lookup(DB, ID).
+
+
+lookup_ids(DB, Pid) ->
+    ril(ets:match(DB, {'$1', {gstkid,'_','_','_',Pid,'_','_'}})).
+
+lookup_item(DB, TkW, Item) ->
+						%    [[Id]] = ets:match(DB, {'$1', {gstkid,'_',TkW, Item,'_','_','_'}}),
+						%    Id.
+    %% OTP-4167 Gif images gstkids are stored differently from other objects
+    case ets:match(DB, {'$1', {gstkid,'_',TkW, Item,'_','_','_'}}) of
+	[[Id]] ->
+	    Id;
+	[] ->
+	    Pattern = {'$1', {gstkid,'_',TkW, {'_',Item},'_','_',image}},
+	    [[Id]] = ets:match(DB, Pattern),
+	    Id
+    end.
+
+
+%% -----------------------------------------------------------------
+%% counters
+
+counter(DB, Key) ->
+    Result =
+	case ets:lookup(DB, Key) of
+	    [{Key, Value}] -> Value+1;
+	    _ -> 0
+	end,
+    ets:insert(DB, {Key, Result}),
+    Result.
+
+
+%% -----------------------------------------------------------------
+%% delete things
+
+delete_widgets(DB, [ID | Rest]) ->
+    delete_widget(DB, ID),
+    delete_widgets(DB, Rest);
+delete_widgets(_, []) ->
+    true.
+
+
+delete_widget(DB, #gstkid{id = ID}) ->
+    delete_widget(DB, ID);
+delete_widget(DB, ID) ->
+    delete_widgets(DB, lookup_kids(DB, ID)),
+    delete_id(DB, ID).
+
+delete_gstkid(DB,Gstkid) ->
+    delete_id(DB,Gstkid).
+
+delete_id(DB, ID) ->
+    case lookup_gstkid(DB, ID) of
+	undefined ->
+	    true;
+	_Gstkid     ->
+	    gstk:worker_do({match_delete,[{get(options),[{{ID,'_'},'_'}]},
+					  {get(defaults),[{{ID,'_'},'_'}]}]}),
+	    ets:insert(get(deleted),{deleted,ID}),
+	    delete(DB, ID)
+    end,
+    ets:delete(get(kids), {kids, ID}),
+    delete(get(events), {events, ID}),
+    true.
+
+get_deleted(_DB) ->
+    Dd = get(deleted),
+    R=fix_deleted(ets:lookup(Dd,deleted)),
+    ets:delete(Dd,deleted),
+    R.
+
+fix_deleted([{_,Id}|Dd]) ->
+    [Id | fix_deleted(Dd)];
+fix_deleted([]) -> [].
+
+%% -----------------------------------------------------------------
+%% odd stuff
+
+%% check if an event is in the database, used by read_option
+is_inserted(DB, #gstkid{id = ID}, What) ->
+    is_inserted(DB, ID, What);
+is_inserted(_DB, ID, What) ->
+    case lookup(get(events), {events, ID}) of
+	undefined -> false;
+	Events -> 
+	    case lists:keysearch(What, 2, Events) of
+		{value, _} -> true;
+		_Other      -> false
+	    end
+    end.
+
+%% -----------------------------------------------------------------
+%%                    PRIMITIVES
+%% -----------------------------------------------------------------
+
+%% remove irritating lists
+ril([[Foo] | Rest]) -> [Foo | ril(Rest)];
+ril([]) -> [].
+
+
+