aboutsummaryrefslogtreecommitdiffstats
path: root/lib/gs/src/tcl2erl.erl
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/gs/src/tcl2erl.erl
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/gs/src/tcl2erl.erl')
-rw-r--r--lib/gs/src/tcl2erl.erl457
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]).
+
+