fcml2dot Ver.0.1
| @@ -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 |