diff options
Diffstat (limited to 'lib/gs/src/tcl2erl.erl')
| -rw-r--r-- | lib/gs/src/tcl2erl.erl | 459 |
1 files changed, 0 insertions, 459 deletions
diff --git a/lib/gs/src/tcl2erl.erl b/lib/gs/src/tcl2erl.erl deleted file mode 100644 index 04229ccf49..0000000000 --- a/lib/gs/src/tcl2erl.erl +++ /dev/null @@ -1,459 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1996-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% - -%% -%% ------------------------------------------------------------ -%% -%% Handle conversion from tcl string to erlang terms -%% -%% ------------------------------------------------------------ - --module(tcl2erl). --compile([{nowarn_deprecated_function,{gs,error,2}}]). - --export([parse_event/1, - ret_int/1, - ret_atom/1, - ret_str/1, - ret_tuple/1, - ret_pack/2, - ret_place/2, - ret_x/1, - ret_y/1, - ret_width/1, - ret_height/1, - ret_list/1, - ret_str_list/1, - ret_label/1, - ret_mapped/1, - ret_iconified/1, - ret_focus/2, - ret_file/1, - ret_bool/1, - ret_enable/1, - ret_color/1, - ret_stipple/1]). - --include("gstk.hrl"). - - - -%% ---------------------------------------- -%% Parse an incoming event represented as -%% a list of bytes -%% -parse_event(Bytes) -> - {[$#|ID], Cont1} = first_word(Bytes), - {Etag, Cont} = first_word(Cont1), - {tokens, Toks} = scan(Cont), - {term_seq, Args}= parse_term_seq(Toks), - {list_to_integer(ID), Etag, Args}. - - -%%---first word returns {Word,Cont}---%% -first_word(Bytes) -> - fw(Bytes,[]). - -fw([],Ack) -> - {lists:reverse(Ack),[]}; -fw([$ |R],Ack) -> - {lists:reverse(Ack),R}; -fw([Char|R],Ack) -> - fw(R,[Char|Ack]). - - -%% --------------------------------------------- -%% str_to_term(Str) -%% Transforms a string to the corresponding Erlang -%% term. Note that the string "Hello" will be -%% transformed to an Erlang atom: 'Hello' . -%% If it is impossible to convert the string into -%% a term the original string is just returned. -%% str_to_term(Str) <---> {string, Str} or {term, Term} -%% 'so that we can be able to tell if conversion succeded or not.' -%% - -str_to_term(Str) -> - {tokens,Tokens} = scan(Str), - case catch parse_term(Tokens) of - {_Type, Term,[]} -> {term,Term}; - _ -> {string, Str} - end. - - -%% --------------------------------------------- -%% Simple Parser. ;-) -%% Parses tokens or fails. -%% Better catch result. -%% Tokens should be generated by scan. -%% parse_term(Toks) <----> {term, Term, Cont} -%% parse_call(Toks) <----> {call, Mod, Fun, Args, Cont} -%% parse_list(Toks) <----> {list, ListTerm, Cont} -%% parse_tuple(Toks) <----> {tuple, TupleTerm, Cont} -%% parse_fun_args(Toks) <-> {fun_args, FunArgs, Cont} %% like (arg1, arg2...) -%% parse_term_seq(Toks) <-> {term_seq, Term_Sequence} %% no continuation -%% - -parse_term([{var,Var}|R]) -> {var,Var,R}; -parse_term([{atom,Atom}|R]) -> {atom,Atom,R}; -parse_term([{float,Float}|R]) -> {float,Float,R}; -parse_term([{integer,Integer}|R]) -> {integer,Integer,R}; -parse_term([{string,String}|R]) -> {string,String,R}; -parse_term(['-',{integer,Integer}|R]) -> {integer,-Integer,R}; -parse_term(['-',{float,Float}|R]) -> {float,-Float,R}; -parse_term(['+',{integer,Integer}|R]) -> {integer,Integer,R}; -parse_term(['+',{float,Float}|R]) -> {float,Float,R}; -parse_term(['['|R]) -> {list,_Term,_C}=parse_list(['['|R]); -parse_term(['{'|R]) -> {tuple,_Term,_C}=parse_tuple(['{'|R]); -parse_term([Char|R]) -> {char,Char,R}. - -%%--- parse list --- -parse_list(['[',']'|C]) -> - {list, [], C}; -parse_list(['['|R]) -> - {list,_List,_C}= list_args(R,[]). - -list_args(Toks,Ack) -> - cont_list(parse_term(Toks),Ack). - -cont_list({_Tag, Term,[','|C]},Ack) -> - list_args(C,[Term|Ack]); -cont_list({_Tag, Term,[']'|C]},Ack) -> - {list,lists:reverse([Term|Ack]),C}. - -%%--- parse tuple --- -parse_tuple(['{','}'|C]) -> - {tuple,{}, C}; -parse_tuple(['{'|R]) -> - {tuple,_Tuple,_C}=tuple_args(R,[]). - -tuple_args(Toks,Ack) -> - cont_tuple(parse_term(Toks),Ack). - -cont_tuple({_Tag, Term,[','|C]},Ack) -> - tuple_args(C,[Term|Ack]); -cont_tuple({_Tag, Term,['}'|C]},Ack) -> - {tuple,list_to_tuple(lists:reverse([Term|Ack])),C}. - -%%--- parse sequence of terms --- -parse_term_seq(Toks) -> - p_term_seq(Toks,[]). - -p_term_seq([],Ack) -> - {term_seq, lists:reverse(Ack)}; % never any continuation left -p_term_seq(Toks,Ack) -> - {_Type,Term,C} = parse_term(Toks), - p_term_seq(C,[Term|Ack]). - - - -%% ---------------------------------------- -%% Simple Scanner - -scan(Bytes) -> - {tokens, scan(Bytes,[])}. - -scan([],Ack) -> - lists:reverse(Ack); -scan([$ |R],Ack) -> % delete whitespace - scan(R,Ack); -scan([X|R],Ack) when is_integer(X),X>=$a,X=<$z -> - scan_atom(R,[X],Ack); -scan([X|R],Ack) when is_integer(X),X>=$A,X=<$Z -> - scan_var(R,[X],Ack); -scan([X|R],Ack) when is_integer(X),X>=$0,X=<$9 -> - scan_number(R,[X],Ack); -scan([$"|R],Ack) -> - scan_string(R,[],Ack); -scan([X|R],Ack) when is_integer(X) -> - scan(R,[list_to_atom([X])|Ack]). - -scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$a,X=<$z -> - scan_atom(R,[X|Ack1],Ack2); -scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$A,X=<$Z -> - scan_atom(R,[X|Ack1],Ack2); -scan_atom([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_atom(R,[X|Ack1],Ack2); -scan_atom([$_|R],Ack1,Ack2) -> - scan_atom(R,[$_|Ack1],Ack2); -scan_atom(L,Ack1,Ack2) -> - scan(L,[{atom,list_to_atom(lists:reverse(Ack1))}|Ack2]). - -scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$a,X=<$z -> - scan_var(R,[X|Ack1],Ack2); -scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$A,X=<$Z -> - scan_var(R,[X|Ack1],Ack2); -scan_var([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_var(R,[X|Ack1],Ack2); -scan_var([$_|R],Ack1,Ack2) -> - scan_var(R,[$_|Ack1],Ack2); -scan_var(L,Ack1,Ack2) -> - scan(L,[{var,list_to_atom(lists:reverse(Ack1))}|Ack2]). - -scan_number([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_number(R,[X|Ack1],Ack2); -scan_number([$.|R],Ack1,Ack2) -> - scan_float(R,[$.|Ack1],Ack2); -scan_number(L,Ack1,Ack2) -> - scan(L,[{integer,list_to_integer(lists:reverse(Ack1))}|Ack2]). - -scan_float([X|R],Ack1,Ack2) when is_integer(X),X>=$0,X=<$9 -> - scan_float(R,[X|Ack1],Ack2); -scan_float(L,Ack1,Ack2) -> - Float = list_to_float(lists:reverse(Ack1)), - Int = trunc(Float), - if - Int==Float -> - scan(L,[{integer,Int}|Ack2]); - true -> - scan(L,[{float,Float}|Ack2]) - end. - - -scan_string([$"|R],Ack1,Ack2) -> - scan(R,[{string,lists:reverse(Ack1)}|Ack2]); -scan_string([X|R],Ack1,Ack2) when is_integer(X) -> - scan_string(R,[X|Ack1],Ack2); -scan_string([],_Ack1,_Ack2) -> - throw({error,"unterminated string."}). - - - -%% ---------- Checking Return values ----------- -%% Used by read to return a proper type or fail. - -ret_int(Str) -> - case gstk:call(Str) of - {result, Result} -> - {_,Value} = str_to_term(Result), - Value; - Bad_result -> Bad_result - end. - -ret_atom(Str) -> - case gstk:call(Str) of - {result, Result} -> - {_,Value} = str_to_term(Result), - Value; - Bad_result -> Bad_result - end. - -ret_str(Str) -> - case gstk:call(Str) of - {result, Val} -> Val; - Bad_result -> Bad_result - end. - -ret_tuple(Str) -> - case gstk:call(Str) of - {result,S} -> - {tokens,Toks} = scan(S), - {term_seq,Seq} = parse_term_seq(Toks), - list_to_tuple(Seq); - Bad_result -> Bad_result - end. - -%%---------------------------------------------------------------------- -%% Returns: Coords or error. -%%---------------------------------------------------------------------- -ret_pack(Key, TkW) -> - Str = ret_list(["pack info ", TkW]), - pick_out(Str, Key). - -ret_place(Key, TkW) -> - Str = ret_list(["place info ", TkW]), - pick_out(Str, Key). - -pick_out([Key, Value | _Rest], Key) -> Value; -pick_out([Key, {} | _Rest], Key) -> 0; -pick_out(['-' | Rest], Key) -> pick_out(Rest, Key); -pick_out([_, _ | Rest], Key) -> pick_out(Rest, Key); -pick_out(Other, _Key) -> Other. - - -ret_x(Str) -> - case ret_geometry(Str) of - {_W,_H,X,_Y} -> X; - Other -> Other - end. - -ret_y(Str) -> - case ret_geometry(Str) of - {_W,_H,_X,Y} -> Y; - Other -> Other - end. - -ret_width(Str) -> - case ret_geometry(Str) of - {W,_H,_X,_Y} -> W; - Other -> Other - end. - -ret_height(Str) -> - case ret_geometry(Str) of - {_W,H,_X,_Y} -> H; - Other -> Other - end. - - - -ret_geometry(Str) -> - case ret_tuple(Str) of - {W,H,X,Y} when is_atom(H) -> - [_|Height]=atom_to_list(H), - {W,list_to_integer(Height),X,Y}; - Other -> Other - end. - -ret_list(Str) -> - case gstk:call(Str) of - {result,S} -> - {tokens,Toks} = scan(S), - {term_seq,Seq} = parse_term_seq(Toks), - Seq; - Bad_result -> Bad_result - end. - -ret_str_list(Str) -> - case gstk:call(Str) of - {result,S} -> - mk_quotes0(S,[]); - Bad_result -> Bad_result - end. - - -ret_label(Str) -> - case ret_str_list(Str) of - [[], [$@|Img]] -> {image, Img}; - [Text, []] -> {text, Text}; - Bad_Result -> Bad_Result - end. - - - -ret_mapped(Str) -> - case ret_int(Str) of - 1 -> true; - 0 -> false; - Bad_Result -> Bad_Result - end. - - -ret_iconified(Str) -> - case ret_atom(Str) of - iconic -> true; - normal -> false; - Bad_Result -> Bad_Result - end. - - -ret_focus(W, Str) -> - case gstk:call(Str) of - {result, W} -> true; - _ -> false - end. - - -ret_file(Str) -> - case gstk:call(Str) of - {result, [$@|File]} -> File; - {result, []} -> []; - Bad_result -> Bad_result - end. - - -ret_bool(Str) -> - case ret_int(Str) of - 1 -> true; - 0 -> false; - Bad_Result -> Bad_Result - end. - -ret_enable(Str) -> - case ret_atom(Str) of - normal -> true; - active -> true; - disabled -> false; - Bad_Result -> Bad_Result - end. - - - -ret_color(Str) -> - case gstk:call(Str) of - {result,[$#,R1,G1,B1]} -> - {hex2dec([R1,$0]),hex2dec([G1,$0]),hex2dec([B1,$0])}; - {result,[$#,R1,R2,G1,G2,B1,B2]} -> - {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; - {result,[$#,R1,R2,_R3,G1,G2,_G3,B1,B2,_B3]} -> - {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; - {result,[$#,R1,R2,_R3,_R4,G1,G2,_G3,_G4,B1,B2,_B3,_B4]} -> - {hex2dec([R1,R2]),hex2dec([G1,G2]),hex2dec([B1,B2])}; - {result,[Char|Word]} when Char>=$A, Char=<$Z -> - list_to_atom([Char+32|Word]); - {result,[Char|Word]} when Char>=$a, Char=<$z -> - list_to_atom([Char|Word]); - {result,Color} -> - gs:error("error in tcl2erl:ret_color got ~w.~n",[Color]); - Bad_result -> Bad_result - end. - - -ret_stipple(Str) -> - case gstk:call(Str) of - {result, _Any} -> true; - _Other -> false - end. - - -%% ------------------------------------------------------------ -%% Hexadecimal to Decimal converter -%% - -hex2dec(Hex) -> hex2dec(Hex,0). - -hex2dec([H|T],N) when H>=$0,H=<$9 -> - hex2dec(T,(N bsl 4) bor (H-$0)); -hex2dec([H|T],N) when H>=$a,H=<$f -> - hex2dec(T,(N bsl 4) bor (H-$a+10)); -hex2dec([H|T],N) when H>=$A,H=<$F -> - hex2dec(T,(N bsl 4) bor (H-$A+10)); -hex2dec([],N) -> N. - - -mk_quotes0([${|T],Res) -> mk_quotes2(T,"",Res); -mk_quotes0([$ |T],Res) -> mk_quotes0(T,Res); -mk_quotes0([$\\,X |T],Res) -> mk_quotes1(T,[X],Res); -mk_quotes0([X|T],Res) -> mk_quotes1(T,[X],Res); -mk_quotes0([],Res) -> lists:reverse(Res). - -mk_quotes1([$}|T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); -mk_quotes1([$\\,X |T],Ack,Res) -> mk_quotes1(T,[X|Ack],Res); -mk_quotes1([$ |T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); -mk_quotes1([X|T],Ack,Res) -> mk_quotes1(T,[X|Ack],Res); -mk_quotes1([],Ack,Res) -> lists:reverse([lists:reverse(Ack)|Res]). - -%% grouped using {bla bla} syntax -mk_quotes2([$}|T],Ack,Res) -> mk_quotes0(T,[lists:reverse(Ack)|Res]); -mk_quotes2([$\\,X |T],Ack,Res) -> mk_quotes2(T,[X|Ack],Res); -mk_quotes2([X|T],Ack,Res) -> mk_quotes2(T,[X|Ack],Res); -mk_quotes2([],Ack,Res) -> lists:reverse([lists:reverse(Ack)|Res]). - - |