path: root/lib/common_test/src/ct_groups.erl

%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 2004-2013. 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%
%%

%%% @doc Common Test Framework callback module.
%%%
%%% <p>This module contains CT internal help functions for searching
%%%    through groups specification trees and producing resulting
%%%    tests.</p>

-module(ct_groups).

-export([find_groups/4]).
-export([make_all_conf/3, make_all_conf/4, make_conf/5]).
-export([delete_subs/2]).
-export([expand_groups/3, search_and_override/3]).

-define(val(Key, List), proplists:get_value(Key, List)). 
-define(val(Key, List, Def), proplists:get_value(Key, List, Def)).
-define(rev(L), lists:reverse(L)).

find_groups(Mod, GrNames, TCs, GroupDefs) when is_atom(GrNames) ; 
					       (length(GrNames) == 1) ->
    find_groups1(Mod, GrNames, TCs, GroupDefs);

find_groups(Mod, Groups, TCs, GroupDefs) when Groups /= [] ->
    lists:append([find_groups1(Mod, [GrNames], TCs, GroupDefs) || 
		     GrNames <- Groups]);

find_groups(_Mod, [], _TCs, _GroupDefs) ->
    [].

%% GrNames == atom(): Single group name, perform full search
%% GrNames == list(): List of groups, find all matching paths
%% GrNames == [list()]: Search path terminated by last group in GrNames
find_groups1(Mod, GrNames, TCs, GroupDefs) ->
    {GrNames1,FindAll} =
	case GrNames of
	    Name when is_atom(Name), Name /= all ->
		{[Name],true};
	    [Path] when is_list(Path) ->
		{Path,false};
	    Path ->
		{Path,true}
	end,
    TCs1 = if (is_atom(TCs) and (TCs /= all)) or is_tuple(TCs) ->
		   [TCs];
	      true -> 
		   TCs 
	   end,
    Found = find(Mod, GrNames1, TCs1, GroupDefs, [],
		 GroupDefs, FindAll),
    [Conf || Conf <- Found, Conf /= 'NOMATCH'].

%% Locate all groups
find(Mod, all, all, [{Name,Props,Tests} | Gs], Known, Defs, _) 
  when is_atom(Name), is_list(Props), is_list(Tests) ->
    cyclic_test(Mod, Name, Known),
    trim(make_conf(Mod, Name, Props,
		   find(Mod, all, all, Tests, [Name | Known],
			Defs, true))) ++
	find(Mod, all, all, Gs, Known, Defs, true);

%% Locate particular TCs in all groups
find(Mod, all, TCs, [{Name,Props,Tests} | Gs], Known, Defs, _) 
  when is_atom(Name), is_list(Props), is_list(Tests) ->
    cyclic_test(Mod, Name, Known),
    Tests1 = rm_unwanted_tcs(Tests, TCs, []),
    trim(make_conf(Mod, Name, Props,
		   find(Mod, all, TCs, Tests1, [Name | Known],
			Defs, true))) ++
	find(Mod, all, TCs, Gs, Known, Defs, true);

%% Found next group is in search path
find(Mod, [Name|GrNames]=SPath, TCs, [{Name,Props,Tests} | Gs], Known,
     Defs, FindAll) when is_atom(Name), is_list(Props), is_list(Tests) ->
    cyclic_test(Mod, Name, Known),
    Tests1 = rm_unwanted_tcs(Tests, TCs, GrNames),
    trim(make_conf(Mod, Name, Props,
		   find(Mod, GrNames, TCs, Tests1, [Name|Known],
			Defs, FindAll))) ++
	find(Mod, SPath, TCs, Gs, Known, Defs, FindAll);

%% Group path terminated, stop the search
find(Mod, [], TCs, Tests, _Known, _Defs, false) ->
    Cases = lists:flatmap(fun(TC) when is_atom(TC), TCs == all ->
				  [{Mod,TC}];
			     ({group,_}) ->
				  [];
			     ({_,_}=TC) when TCs == all ->
				  [TC];
			     (TC) ->
				  if is_atom(TC) ->
					  Tuple = {Mod,TC},
					  case lists:member(Tuple, TCs) of
					      true  ->
						  [Tuple];
					      false ->
						  case lists:member(TC, TCs) of
						      true  -> [{Mod,TC}];
						      false -> []
						  end
					  end;
				     true ->
					  []
				  end
			  end, Tests),
    if Cases == [] -> ['NOMATCH'];
       true -> Cases
    end;

%% No more groups
find(_Mod, [_|_], _TCs, [], _Known, _Defs, _) ->
    ['NOMATCH'];

%% Found group not next in search path
find(Mod, GrNames, TCs, [{Name,Props,Tests} | Gs], Known,
     Defs, FindAll) when is_atom(Name), is_list(Props), is_list(Tests) ->
    cyclic_test(Mod, Name, Known),
    Tests1 = rm_unwanted_tcs(Tests, TCs, GrNames),
    trim(make_conf(Mod, Name, Props,
		   find(Mod, GrNames, TCs, Tests1, [Name|Known],
			Defs, FindAll))) ++
	find(Mod, GrNames, TCs, Gs, Known, Defs, FindAll);
  
%% A nested group defined on top level found
find(Mod, GrNames, TCs, [{group,Name1} | Gs], Known, Defs, FindAll) 
  when is_atom(Name1) ->
    find(Mod, GrNames, TCs, [expand(Mod, Name1, Defs) | Gs], Known,
	 Defs, FindAll);

%% Undocumented remote group feature, use with caution
find(Mod, GrNames, TCs, [{group, ExtMod, ExtGrp} | Gs], Known,
     Defs, FindAll) when is_atom(ExtMod), is_atom(ExtGrp) ->
    ExternalDefs = ExtMod:groups(),
    ExternalTCs = find(ExtMod, ExtGrp, TCs, [{group, ExtGrp}],
		       [], ExternalDefs, FindAll),
    ExternalTCs ++ find(Mod, GrNames, TCs, Gs, Known, Defs, FindAll);

%% Group definition without properties, add an empty property list
find(Mod, GrNames, TCs, [{Name1,Tests} | Gs], Known, Defs, FindAll)
  when is_atom(Name1), is_list(Tests) ->
    find(Mod, GrNames, TCs, [{Name1,[],Tests} | Gs], Known, Defs, FindAll);

%% Save, and keep searching
find(Mod, GrNames, TCs, [{ExternalTC, Case} = TC | Gs], Known,
     Defs, FindAll) when is_atom(ExternalTC),
			 is_atom(Case) ->
    [TC | find(Mod, GrNames, TCs, Gs, Known, Defs, FindAll)];

%% Save test case
find(Mod, GrNames, all, [TC | Gs], Known,
     Defs, FindAll) when is_atom(TC) ->
    [{Mod,TC} | find(Mod, GrNames, all, Gs, Known, Defs, FindAll)];

%% Save test case
find(Mod, GrNames, all, [{M,TC} | Gs], Known,
     Defs, FindAll) when is_atom(M), M /= group, is_atom(TC) ->
    [{M,TC} | find(Mod, GrNames, all, Gs, Known, Defs, FindAll)];

%% Check if test case should be saved
find(Mod, GrNames, TCs, [TC | Gs], Known,
     Defs, FindAll) when is_atom(TC) orelse 
			 ((size(TC) == 2) and (element(1,TC) /= group)) ->
    Case =
	if is_atom(TC) ->
		Tuple = {Mod,TC},
		case lists:member(Tuple, TCs) of
		    true  ->
			Tuple;
		    false ->
			case lists:member(TC, TCs) of
			    true  -> {Mod,TC};
			    false -> []
			end
		end;
	   true ->
		case lists:member(TC, TCs) of
		    true  -> {Mod,TC};
		    false -> []
		end
	end,
    if Case == [] ->
	    find(Mod, GrNames, TCs, Gs, Known, Defs, FindAll);
       true ->
	    [Case | find(Mod, GrNames, TCs, Gs, Known, Defs, FindAll)]
    end;

%% Unexpeted term in group list
find(Mod, _GrNames, _TCs, [BadTerm | _Gs], Known, _Defs, _FindAll) ->
    Where = if length(Known) == 0 ->
		    atom_to_list(Mod)++":groups/0";
	       true ->
		    "group "++atom_to_list(lists:last(Known))++
			" in "++atom_to_list(Mod)++":groups/0"
	    end,		 
    Term = io_lib:format("~p", [BadTerm]),
    E = "Bad term "++lists:flatten(Term)++" in "++Where,
    throw({error,list_to_atom(E)});

%% No more groups
find(_Mod, _GrNames, _TCs, [], _Known, _Defs, _) ->
    [].

%%%-----------------------------------------------------------------

%% We have to always search bottom up to only remove a branch
%% if there's 'NOMATCH' in the leaf (otherwise, the branch should
%% be kept)

trim({conf,Props,Init,Tests,End}) ->
    try trim(Tests) of
	[] -> [];
	Tests1 -> [{conf,Props,Init,Tests1,End}]
    catch
	throw:_ -> []
    end;

trim(Tests) when is_list(Tests) ->
    %% we need to compare the result of trimming each test on this
    %% level, and only let a 'NOMATCH' fail the level if no
    %% successful sub group can be found
    Tests1 =
	lists:flatmap(fun(Test) ->
			      IsConf = case Test of
					   {conf,_,_,_,_} ->
					       true;
					   _ ->
					       false
				       end,
			      try trim_test(Test) of
				  [] -> [];
				  Test1 when IsConf -> [{conf,Test1}];
				  Test1 -> [Test1]
			      catch
				  throw:_ -> ['NOMATCH']
			      end
		      end, Tests),
    case lists:keymember(conf, 1, Tests1) of
	true ->					% at least one successful group
	    lists:flatmap(fun({conf,Test}) -> [Test];
			     ('NOMATCH') -> [];	% ignore any 'NOMATCH'
			     (Test) -> [Test]
			  end, Tests1);
	false ->
	    case lists:member('NOMATCH', Tests1) of
		true ->
		    throw('NOMATCH');
		false ->
		    Tests1
	    end
    end.

trim_test({conf,Props,Init,Tests,End}) ->
    case trim(Tests) of
	[] ->
	    [];
	Tests1 ->
	    {conf,Props,Init,Tests1,End}
    end;

trim_test('NOMATCH') ->
    throw('NOMATCH');

trim_test(Test) ->
    Test.

%% GrNames is [] if the terminating group has been found. From
%% that point, all specified test should be included (as well as
%% sub groups for deeper search).
rm_unwanted_tcs(Tests, all, []) ->
    Tests;

rm_unwanted_tcs(Tests, TCs, []) ->
    sort_tests(lists:flatmap(fun(Test) when is_tuple(Test),
					    (size(Test) > 2) ->
				     [Test];
				(Test={group,_}) ->
				     [Test];
				(Test={_M,TC}) ->
				     case lists:member(TC, TCs) of
					 true  -> [Test];
					 false -> []
				     end;
				(Test) when is_atom(Test) ->
				     case lists:keysearch(Test, 2, TCs) of
					 {value,_} ->
					     [Test];
					 _ ->
					     case lists:member(Test, TCs) of
						 true  -> [Test];
						 false -> []
					     end
				     end;
				(Test) -> [Test]
			     end, Tests), TCs);
					  
rm_unwanted_tcs(Tests, _TCs, _) ->
    [Test || Test <- Tests, not is_atom(Test)].

%% make sure the order of tests is according to the order in TCs
sort_tests(Tests, TCs) when is_list(TCs)->
    lists:sort(fun(T1, T2) ->
		       case {is_tc(T1),is_tc(T2)} of
			   {true,true} ->
			       (position(T1, TCs) =<
				position(T2, TCs));
			   {false,true} ->
			       (position(T2, TCs) == (length(TCs)+1));
			   _ -> true
				   
		       end
	       end, Tests);
sort_tests(Tests, _) ->
    Tests.

is_tc(T) when is_atom(T)      -> true;
is_tc({group,_})              -> false;
is_tc({_M,T}) when is_atom(T) -> true;
is_tc(_)                      -> false.

position(T, TCs) ->
    position(T, TCs, 1).

position(T, [T|_TCs], Pos) ->
    Pos;
position(T, [{_,T}|_TCs], Pos) ->
    Pos;
position({M,T}, [T|_TCs], Pos) when M /= group ->
    Pos;
position(T, [_|TCs], Pos) ->
    position(T, TCs, Pos+1);
position(_, [], Pos) ->
    Pos.

%%%-----------------------------------------------------------------

delete_subs([{conf, _,_,_,_} = Conf | Confs], All) ->
    All1 = delete_conf(Conf, All),
    case is_sub(Conf, All1) of
	true ->
	    delete_subs(Confs, All1);
	false ->
	    delete_subs(Confs, All)
    end;
delete_subs([_Else | Confs], All) ->
    delete_subs(Confs, All);
delete_subs([], All) ->
    All.

delete_conf({conf,Props,_,_,_}, Confs) ->
    Name = ?val(name, Props),
    [Conf || Conf = {conf,Props0,_,_,_} <- Confs,
	     Name =/= ?val(name, Props0)].

is_sub({conf,Props,_,_,_}=Conf, [{conf,_,_,Tests,_} | Confs]) ->
    Name = ?val(name, Props),
    case lists:any(fun({conf,Props0,_,_,_}) ->
			   case ?val(name, Props0) of
			       N when N == Name ->
				   true;
			       _ ->
				   false
			   end;
		      (_) ->
			   false
		   end, Tests) of
	true ->
	    true;
	false ->
	    is_sub(Conf, Tests) orelse is_sub(Conf, Confs)
    end;

is_sub(Conf, [_TC | Tests]) ->
    is_sub(Conf, Tests);

is_sub(_Conf, []) ->
    false.


cyclic_test(Mod, Name, Names) ->
    case lists:member(Name, Names) of
	true ->
	    E = "Cyclic reference to group "++atom_to_list(Name)++
		" in "++atom_to_list(Mod)++":groups/0",
	    throw({error,list_to_atom(E)});
	false ->
	    ok
    end.

expand(Mod, Name, Defs) ->
    case lists:keysearch(Name, 1, Defs) of
	{value,Def} -> 
	    Def;
	false ->
	    E = "Invalid group "++atom_to_list(Name)++
		" in "++atom_to_list(Mod)++":groups/0",
	    throw({error,list_to_atom(E)})
    end.

make_all_conf(Dir, Mod, Props, TestSpec) ->
    case code:is_loaded(Mod) of
	false ->
	    code:load_abs(filename:join(Dir,atom_to_list(Mod)));
	_ ->
	    ok
    end,
    make_all_conf(Mod, Props, TestSpec).

make_all_conf(Mod, Props, TestSpec) ->
    case catch apply(Mod, groups, []) of
	{'EXIT',_} ->
	    exit({invalid_group_definition,Mod});
	GroupDefs when is_list(GroupDefs) ->
	    case catch find_groups(Mod, all, TestSpec, GroupDefs) of
		{error,_} = Error ->
		    %% this makes test_server call error_in_suite as first
		    %% (and only) test case so we can report Error properly
		    [{ct_framework,error_in_suite,[[Error]]}];
		[] ->
		    exit({invalid_group_spec,Mod});
		_ConfTests ->
		    make_conf(Mod, all, Props, TestSpec) 
	    end
    end.

make_conf(Dir, Mod, Name, Props, TestSpec) ->
    case code:is_loaded(Mod) of
	false ->
	    code:load_abs(filename:join(Dir,atom_to_list(Mod)));
	_ ->
	    ok
    end,
    make_conf(Mod, Name, Props, TestSpec).

make_conf(Mod, Name, Props, TestSpec) ->
    case code:is_loaded(Mod) of
	false ->
	    code:load_file(Mod);
	_ ->
	    ok
    end,
    {InitConf,EndConf,ExtraProps} =
	case erlang:function_exported(Mod,init_per_group,2) of
	    true ->
		{{Mod,init_per_group},{Mod,end_per_group},[]};
	    false ->
		ct_logs:log("TEST INFO", "init_per_group/2 and "
			    "end_per_group/2 missing for group "
			    "~w in ~w, using default.",
			    [Name,Mod]),
		{{ct_framework,init_per_group},
		 {ct_framework,end_per_group},
		 [{suite,Mod}]}
	end,
    {conf,[{name,Name}|Props++ExtraProps],InitConf,TestSpec,EndConf}.

%%%-----------------------------------------------------------------

expand_groups([H | T], ConfTests, Mod) ->
    [expand_groups(H, ConfTests, Mod) | expand_groups(T, ConfTests, Mod)];
expand_groups([], _ConfTests, _Mod) ->
    [];
expand_groups({group,Name}, ConfTests, Mod) ->
    expand_groups({group,Name,default,[]}, ConfTests, Mod);
expand_groups({group,Name,default}, ConfTests, Mod) ->
    expand_groups({group,Name,default,[]}, ConfTests, Mod);
expand_groups({group,Name,ORProps}, ConfTests, Mod) when is_list(ORProps) ->
    expand_groups({group,Name,ORProps,[]}, ConfTests, Mod);
expand_groups({group,Name,ORProps,SubORSpec}, ConfTests, Mod) ->
    FindConf =
	fun(Conf = {conf,Props,Init,Ts,End}) ->
		case ?val(name, Props) of
		    Name when ORProps == default ->
			[Conf];
		    Name ->
			Props1 = case ?val(suite, Props) of
				     undefined ->
					 ORProps;
				     SuiteName ->
					 [{suite,SuiteName}|ORProps]
				 end,
			[{conf,[{name,Name}|Props1],Init,Ts,End}];
		    _    -> 
			[]
		end
	end,					 
    case lists:flatmap(FindConf, ConfTests) of
	[] ->
	    throw({error,invalid_ref_msg(Name, Mod)});
	Matching when SubORSpec == [] -> 
	    Matching;
	Matching -> 
	    override_props(Matching, SubORSpec, Name,Mod)
    end;
expand_groups(SeqOrTC, _ConfTests, _Mod) ->
    SeqOrTC.

%% search deep for the matching conf test and modify it and any 
%% sub tests according to the override specification
search_and_override([Conf = {conf,Props,Init,Tests,End}], ORSpec, Mod) ->
    InsProps = fun(GrName, undefined, Ps) ->
		       [{name,GrName} | Ps];
		  (GrName, Suite, Ps) ->
		       [{name,GrName}, {suite,Suite} | Ps]
	       end,
    Name = ?val(name, Props),
    Suite = ?val(suite, Props),
    case lists:keysearch(Name, 1, ORSpec) of
	{value,{Name,default}} ->
	    [Conf];
	{value,{Name,ORProps}} ->
	    [{conf,InsProps(Name,Suite,ORProps),Init,Tests,End}];
	{value,{Name,default,[]}} ->
	    [Conf];
	{value,{Name,default,SubORSpec}} ->
	    override_props([Conf], SubORSpec, Name,Mod);
	{value,{Name,ORProps,SubORSpec}} ->
	    override_props([{conf,InsProps(Name,Suite,ORProps),
			    Init,Tests,End}], SubORSpec, Name,Mod);
	_ ->
	    [{conf,Props,Init,search_and_override(Tests,ORSpec,Mod),End}]
    end.

%% Modify the Tests element according to the override specification
override_props([{conf,Props,Init,Tests,End} | Confs], SubORSpec, Name,Mod) ->
    {Subs,SubORSpec1} = override_sub_props(Tests, [], SubORSpec, Mod),
    [{conf,Props,Init,Subs,End} | override_props(Confs, SubORSpec1, Name,Mod)];
override_props([], [], _,_) ->
    [];
override_props([], SubORSpec, Name,Mod) ->
    Es = [invalid_ref_msg(Name, element(1,Spec), Mod) || Spec <- SubORSpec],
    throw({error,Es}).

override_sub_props([], New, ORSpec, _) ->    
    {?rev(New),ORSpec};
override_sub_props([T = {conf,Props,Init,Tests,End} | Ts],
		   New, ORSpec, Mod) ->
    Name = ?val(name, Props),
    Suite = ?val(suite, Props),
    case lists:keysearch(Name, 1, ORSpec) of
	{value,Spec} ->				% group found in spec
	    Props1 =
		case element(2, Spec) of
		    default -> Props;
		    ORProps when Suite == undefined -> [{name,Name} | ORProps];
		    ORProps -> [{name,Name}, {suite,Suite} | ORProps]
		end,
	    case catch element(3, Spec) of
		Undef when Undef == [] ; 'EXIT' == element(1, Undef) ->
		    override_sub_props(Ts, [{conf,Props1,Init,Tests,End} | New],
				       lists:keydelete(Name, 1, ORSpec), Mod);
		SubORSpec when is_list(SubORSpec) ->
		    case override_sub_props(Tests, [], SubORSpec, Mod) of
			{Subs,[]} ->
			    override_sub_props(Ts, [{conf,Props1,Init,
						     Subs,End} | New],
					       lists:keydelete(Name, 1, ORSpec),
					       Mod);
			{_,NonEmptySpec} ->
			    Es = [invalid_ref_msg(Name, element(1, GrRef),
						  Mod) || GrRef <- NonEmptySpec],
			    throw({error,Es})
		    end;
		BadGrSpec ->
		    throw({error,{invalid_form,BadGrSpec}})
	    end;
	_ ->					% not a group in spec
	    override_sub_props(Ts, [T | New], ORSpec, Mod)
    end;
override_sub_props([TC | Ts], New, ORSpec, Mod) ->
    override_sub_props(Ts, [TC | New], ORSpec, Mod).

invalid_ref_msg(Name, Mod) ->
    E = "Invalid reference to group "++
	atom_to_list(Name)++" in "++
	atom_to_list(Mod)++":all/0",
    list_to_atom(E).

invalid_ref_msg(Name0, Name1, Mod) ->
    E = "Invalid reference to group "++
	atom_to_list(Name1)++" from "++atom_to_list(Name0)++
	" in "++atom_to_list(Mod)++":all/0",
    list_to_atom(E).