diff options
Diffstat (limited to 'lib/gs/src/tcl2erl.erl')
| -rw-r--r-- | lib/gs/src/tcl2erl.erl | 457 |
1 files changed, 457 insertions, 0 deletions
diff --git a/lib/gs/src/tcl2erl.erl b/lib/gs/src/tcl2erl.erl new file mode 100644 index 0000000000..8845cf0b9a --- /dev/null +++ b/lib/gs/src/tcl2erl.erl @@ -0,0 +1,457 @@ +%% +%% %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% +%% + +%% +%% ------------------------------------------------------------ +%% +%% Handle conversion from tcl string to erlang terms +%% +%% ------------------------------------------------------------ + +-module(tcl2erl). + +-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]). + + |