• R/O
  • SSH
  • HTTPS

make-flowchart: Commit


Commit MetaInfo

Revisão6 (tree)
Hora2009-03-22 18:52:45
Autortenmyo

Mensagem de Log

fcml2dot Ver.0.1

Mudança Sumário

Diff

--- fcml2dot/tags/R_0_1/fcml2dot.pl (nonexistent)
+++ fcml2dot/tags/R_0_1/fcml2dot.pl (revision 6)
@@ -0,0 +1,291 @@
1+#!/usr/bin/perl -w
2+use strict;
3+use warnings;
4+
5+# 関数連番。複数subに対応するため。
6+my $funcnum=0;
7+
8+# フローチャートの要素データ(参照)リスト
9+# 要素内容は以下(将来的にはClass::Struct化したい)
10+# ID => {
11+# ID => ユニークな識別子(コマンド_行番号),
12+# command => コマンド種別,
13+# args => コマンド引数,
14+# ref => 参照元ID等のリスト(参照)@refIDs,
15+# level => 深さ,
16+# }
17+my %nodelist;
18+
19+# @nodelist->{ref}用の参照元データ(参照)リスト
20+# 要素内容は以下(将来的にはClass::Struct化したい)
21+# [ID,args]
22+my @refIDs;
23+# endswitchでの合流用にbreakを保持する、参照元データ(参照)リスト
24+# 要素内容は@refIDsと同じ
25+my @breakstack;
26+# switch->caseの参照情報を保持する、参照元データ(参照)リスト
27+# switchが深くなるほど、要素が増えていく。最終要素は直近のswitch
28+# 要素内容は@refIDsと同じ
29+my @switchstack;
30+# endsubでの合流用にbreakを保持する、参照元データ(参照)リスト
31+# 要素内容は@refIDsと同じ
32+my @returnlist;
33+
34+# ラベルへの参照元リスト
35+# ラベル名 => { ID=>ID, ref=>[@refIDsと同じ] }
36+my %labellist;
37+
38+
39+print "digraph {\n\n";
40+while (<>) {
41+ my($command,$args) = /^\s*(\w+)\s*(.*?)\s*$/;
42+ next if not $command;
43+ SWITCH_COMMAND: {
44+ $_ = $command;
45+ my $currentID = "${command}_$.";
46+
47+ # コメント行はスキップ
48+ next if /^#/;
49+
50+ # case break(非フローチャート要素)
51+ /^break$/ && do {
52+ push @breakstack, $refIDs[-1];
53+ last;
54+ };
55+ # case endswitch(非フローチャート要素)
56+ /^endswitch$/ && do {
57+ @refIDs=@breakstack;
58+ pop @switchstack;
59+ last;
60+ };
61+
62+ # case sub
63+ /^sub$/ && do {
64+ $funcnum++;
65+ @returnlist = ();
66+ @switchstack = ();
67+ @refIDs = ();
68+ %nodelist = ();
69+ $command = "start_end";
70+ print qq/subgraph cluster_$funcnum { label="$args";\n/;
71+ };
72+ # case endsub
73+ /^endsub$/ && do {
74+ $args = "END";
75+ $command = "start_end";
76+ # return->endsub
77+ push @refIDs, @returnlist;
78+ # goto->label
79+ foreach my $label (keys %labellist) {
80+ if (not exists $labellist{$label}{ID}) {
81+ warn "ERROR: not defined label(${label})\n";
82+ } else {
83+ if (exists $labellist{$label}{ref}) {
84+ push @{$nodelist{$labellist{$label}{ID}}{ref}}, @{$labellist{$label}{ref}};
85+ }
86+ }
87+ }
88+ };
89+ # case switch
90+ /^switch$/ && do {
91+ @breakstack = ();
92+ push @switchstack, $currentID;
93+ };
94+ # case label
95+ /^label$/ && do {
96+ $labellist{$args}{ID} = $currentID;
97+ };
98+ # calse goto
99+ /^goto$/ && do {
100+ # ラベルへの参照元リストへ追加
101+ # 現状では、参照情報に引数は設定しない(将来的にはコメント的なテキストを設定したい)
102+ if (not exists $labellist{$args}{ref}) {
103+ $labellist{$args}{ref} ||= [];
104+ }
105+ push @{$labellist{$args}{ref}}, [$currentID, ""];
106+ };
107+ # case return
108+ /^return$/ && do {
109+ push @returnlist, [$currentID, $args];
110+ $command = "goto";
111+ };
112+ # case case
113+ /^case$/ && do {
114+ @refIDs=([$switchstack[-1], $args]);
115+ $args = $currentID;
116+ $command = "label";
117+ };
118+
119+ # default(全フローチャート要素)
120+ do {
121+ $nodelist{$currentID} = {
122+ ID => $currentID,
123+ command => $command,
124+ args => $args,
125+ ref => [@refIDs],
126+ level => scalar @switchstack,
127+ };
128+ @refIDs=([$currentID, ""]);
129+ };
130+ # case endsub
131+ /^endsub$/ && do {
132+ print @{nodedump(\%nodelist)};
133+ print "}\n\n";
134+ };
135+ }
136+}
137+
138+print "}\n";
139+
140+
141+
142+sub nodedump {
143+ my $nodelist = shift;
144+ my @ret;
145+
146+ # default node
147+ push @ret,
148+ qq/# default\n/,
149+ qq/edge[labeldistance=1.5,tailport=s,headport=n];\n/,
150+ qq/node[height=0.2, width=1];\n/;
151+ push @ret, "\n";
152+
153+ # switch
154+ push @ret,
155+ qq/# switch\n/,
156+ qq/node[shape="diamond", style=""];\n/;
157+ foreach my $i (grep {$_->{command} eq "switch"} values(%$nodelist)) {
158+ push @ret,
159+ qq/$i->{ID}\[label="$i->{args}", group="$i->{level}"\];\n/;
160+ }
161+ push @ret, "\n";
162+
163+ # do
164+ push @ret,
165+ qq/# do\n/,
166+ qq/node[shape="rect", style=""];\n/;
167+ foreach my $i (grep {$_->{command} eq "do"} values(%$nodelist)) {
168+ push @ret,
169+ qq/$i->{ID}\[label="$i->{args}", group="$i->{level}"\];\n/;
170+ }
171+ push @ret, "\n";
172+
173+ # call
174+ push @ret,
175+ qq/# call\n/,
176+ qq/node[shape="record", style=""];\n/;
177+ foreach my $i (grep {$_->{command} eq "call"} values(%$nodelist)) {
178+ push @ret,
179+ qq/$i->{ID}\[label="\\ |$i->{args}|\\ ", group="$i->{level}"\];\n/;
180+ }
181+ push @ret, "\n";
182+
183+ # start_end
184+ push @ret,
185+ qq/# start_end\n/,
186+ qq/node[shape="rect", style="rounded"];\n/;
187+ foreach my $i (grep {$_->{command} eq "start_end"} values(%$nodelist)) {
188+ push @ret,
189+ qq/$i->{ID}\[label="$i->{args}", group="$i->{level}"\];\n/;
190+ }
191+ push @ret, "\n";
192+
193+ # return
194+ push @ret,
195+ qq/# goto(and return)\n/,
196+ qq/node[shape="point", height=0, width=0];\n/;
197+ foreach my $i (grep {$_->{command} eq "goto"} values(%$nodelist)) {
198+ push @ret,
199+ qq/$i->{ID}\[group="$i->{level}"\];\n/;
200+ }
201+ push @ret, "\n";
202+
203+ # label
204+ push @ret,
205+ qq/# label\n/,
206+ qq/node[shape="point", height=0, width=0];\n/;
207+ foreach my $i (grep {$_->{command} eq "label"} values(%$nodelist)) {
208+ push @ret,
209+ qq/$i->{ID}\[group="$i->{level}"\];\n/;
210+ }
211+ push @ret, "\n";
212+
213+ # edge
214+ foreach my $i (values(%$nodelist)) {
215+ foreach my $ref (@{$i->{ref}}) {
216+ push @ret,
217+ qq/$ref->[0] -> $i->{ID}/;
218+
219+ push @ret,
220+ qq/[label="$ref->[1]"]/
221+ if $ref->[1];
222+
223+ if ((@{$i->{ref}} == 1) && ($i->{command} eq "goto")) {
224+ push @ret,
225+ qq/[arrowhead="none"]/;
226+ }
227+ if (($nodelist->{$ref->[0]}{command} ne "goto") && ($i->{command} eq "label")) {
228+ push @ret,
229+ qq/[arrowhead="none"]/;
230+ }
231+ if (($nodelist->{$ref->[0]}{command} eq "goto") && (not $ref->[1])) {
232+ push @ret,
233+ qq/[headport=e, constraint=false]/;
234+ }
235+
236+ push @ret, ";\n";
237+ }
238+ }
239+ push @ret, "\n";
240+
241+ # rank
242+ foreach my $i (grep {$_->{command} eq "switch"} values(%$nodelist)) {
243+ my @temp;
244+ push @ret,
245+ qq/{rank=same;/;
246+ foreach my $j (values(%$nodelist)) {
247+ next if not @{$j->{ref}};
248+ if (grep {$_ eq $i->{ID}} map {$_->[0]} @{$j->{ref}}) {
249+ push @ret,
250+ qq/$j->{ID};/;
251+
252+ foreach my $k (values(%$nodelist)) {
253+ next if @{$k->{ref}} != 1;
254+ push @temp,
255+ qq/$k->{ID}/
256+ if grep {$_ eq $j->{ID}} map {$_->[0]} @{$k->{ref}};
257+ }
258+ }
259+ }
260+ push @ret,
261+ qq/}\n/;
262+ push @ret,
263+ qq/{rank=same;/,
264+ join(";", @temp),
265+ qq/}\n/;
266+ }
267+ push @ret, "\n";
268+
269+
270+ return \@ret;
271+}
272+
273+
274+__DATA__
275+sub main2
276+ do init
277+label startSwitch
278+ switch OK?
279+ #return a
280+ case 1
281+ call error_func
282+ return a
283+ case 2
284+ break
285+ case 4
286+ do foo
287+ break
288+ case X
289+ goto startSwitch
290+ endswitch
291+endsub
Show on old repository browser