pl_proto.pl 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473
  1. #!/usr/bin/perl
  2. use strict;
  3. use warnings;
  4. use Data::Dumper;
  5. use lib "/home/swatson/perl5/lib/perl5";
  6. use GraphViz2;
  7. my $SOURCE_FILE = $ARGV[0];
  8. sub read_to_var($) {
  9. my $file_path = shift;
  10. my $content;
  11. open(my $fh, '<', $file_path) or die "cannot open file $file_path";
  12. {
  13. local $/;
  14. $content = <$fh>;
  15. }
  16. close($fh);
  17. return $content;
  18. }
  19. my $src_content = read_to_var($SOURCE_FILE);
  20. sub trim($) {
  21. my $str = shift;
  22. $str =~ s/^\s+|\s+$//g;
  23. return $str;
  24. }
  25. my @module_library_paths = (
  26. ".",
  27. );
  28. my %modules;
  29. sub parse_module_file {
  30. my $src = shift;
  31. my %module;
  32. my $last_proc_type = "null";
  33. my $last_input = "null";
  34. my $last_output = "null";
  35. foreach my $line ( split("\n", $src) ) {
  36. chomp $line;
  37. if ( $line =~ m/^#/ ) {
  38. next;
  39. }
  40. if ( $line =~ m/^Manufacturer:(.*)/ ) {
  41. my $manu = $1;
  42. $manu = trim($manu);
  43. $module{'Manufacturer'} = $manu;
  44. }
  45. if ( $line =~ m/^Module:(.*)/ ) {
  46. my $mod = $1;
  47. $mod = trim($mod);
  48. $module{'Module'} = $mod;
  49. }
  50. if ( $line =~ m/^Revision:(.*)/ ) {
  51. my $rev = $1;
  52. $rev = trim($rev);
  53. $module{'Rev'} = $rev;
  54. }
  55. if ( $line =~ m/^-\ / ) {
  56. if ( $line =~ m/^-\ Input:(.*)/ ) {
  57. my $input = $1;
  58. $input = trim($input);
  59. my %input_chars;
  60. $last_input = $input;
  61. $last_proc_type = "input";
  62. $module{'Inputs'}->{$input} = \%input_chars;
  63. }
  64. if ( $line =~ m/^-\ Knob:(.*)/ ) {
  65. my $knob = $1;
  66. $knob = trim($knob);
  67. my %knob_chars;
  68. $last_input = $knob;
  69. $last_proc_type = "input";
  70. $module{'Inputs'}->{$knob} = \%knob_chars;
  71. }
  72. if ( $line =~ m/^-\ Output:(.*)/ ) {
  73. my $output = $1;
  74. $output = trim($output);
  75. my %output_chars;
  76. $last_output = $output;
  77. $last_proc_type = "output";
  78. $module{'Outputs'}->{$output} = \%output_chars;
  79. }
  80. if ( $line =~ m/^-\ Button:(.*)/ ) {
  81. my $button = $1;
  82. $button = trim($button);
  83. my %button_chars;
  84. $last_input = $button;
  85. $last_proc_type = "input";
  86. $module{'Inputs'}->{$button} = \%button_chars;
  87. }
  88. }
  89. if ( $line =~ m/^--\ / ) {
  90. if ( $line =~ m/^--\ Position:(.*)/ ) {
  91. my $pos_args = $1;
  92. $pos_args = trim($pos_args);
  93. if ( $last_proc_type eq "input" ) {
  94. $module{'Inputs'}->{$last_input}->{'pos'} = $pos_args;
  95. } elsif ( $last_proc_type eq "output" ) {
  96. $module{'Outputs'}->{$last_output}->{'pos'} = $pos_args;
  97. }
  98. }
  99. }
  100. }
  101. return \%module;
  102. }
  103. my %AST;
  104. my %PARSE_TABLE = (
  105. 'comment' => '^#.*$',
  106. 'title' => '^Title: (.*)$',
  107. 'mod_path' => '^ModuleDir\ "(.*)"$',
  108. 'import' => '^import (Module)::([a-zA-Z0-9]{1,})::([a-zA-Z0-9]{1,})(.*$)',
  109. 'set' => '^set\ (.*)$',
  110. 'connect' => '^connect(.*)$',
  111. );
  112. my %PARSE_RULES = (
  113. 'comment' => sub {
  114. # Do nothing, throw this line out
  115. },
  116. 'title' => sub {
  117. my $title = shift;
  118. $AST{'Title'} = $title;
  119. },
  120. 'mod_path' => sub {
  121. my $file_path = shift;
  122. if ( ! -d $file_path ) {
  123. die "Path: $file_path doesn't look like a directory, exiting";
  124. }
  125. push(@module_library_paths, $file_path);
  126. },
  127. 'import' => sub {
  128. my $module_import = shift;
  129. my $import_manu = shift;
  130. my $import_mod = shift;
  131. my $import_as = shift;
  132. my @module_files = sub {
  133. my @files;
  134. foreach my $path ( @module_library_paths ) {
  135. my @f = split("\n", `find $path`);
  136. foreach my $file ( @f ) {
  137. if ( $file =~ m/.module$/ ) {
  138. my $f_bn = `basename $file`;
  139. chomp $f_bn;
  140. if ( ! grep(/$f_bn/, @files) ) {
  141. push(@files, $file);
  142. }
  143. }
  144. }
  145. }
  146. return @files;
  147. }->();
  148. foreach my $mod_file ( @module_files ) {
  149. my $mod_file_content = read_to_var($mod_file);
  150. my $mod_ref = parse_module_file($mod_file_content);
  151. if ( $import_mod eq $$mod_ref{'Module'} ) {
  152. if ( defined $AST{'Modules'} ) {
  153. my $r = grep { $import_mod eq $_->{'Module'} } @{$AST{'Modules'}};
  154. if ( $r == 0 ) {
  155. push(@{$AST{'Modules'}}, $mod_ref);
  156. }
  157. } else {
  158. push(@{$AST{'Modules'}}, $mod_ref);
  159. }
  160. } else {
  161. next;
  162. }
  163. }
  164. },
  165. 'set' => sub {
  166. my $set_line = shift;
  167. my $mod_to_set;
  168. my $attr_to_set;
  169. my $attr_param;
  170. my $value;
  171. my $setter = sub {
  172. my $mod_to_set = shift;
  173. my $attr_to_set = shift;
  174. my $attr_param = shift;
  175. if ( $attr_param eq "position" ) {
  176. $attr_param = "pos";
  177. }
  178. my $value = shift;
  179. my %set_params = (
  180. 'Param' => $attr_param,
  181. 'Value' => $value,
  182. );
  183. # Check values against mod definition
  184. # Pull mod ref out of AST for straight forward checking
  185. my $mod_ref;
  186. # Check we have module in AST
  187. my $r = grep { $mod_to_set eq $_->{'Module'} } @{$AST{'Modules'}};
  188. if ( $r eq 0 ) {
  189. die "Can't set value on module that is not imported: $mod_to_set\n";
  190. } else {
  191. foreach my $module_ref ( @{$AST{'Modules'}} ) {
  192. if ( $mod_to_set eq $$module_ref{'Module'} ) {
  193. $mod_ref = $module_ref;
  194. last;
  195. }
  196. }
  197. }
  198. # Check that module has param we want to set
  199. if ( ! $attr_to_set eq $$mod_ref{'Inputs'}->{$attr_to_set} ) {
  200. die "Can't set a param that doesn't existing in the module spec: $attr_to_set";
  201. }
  202. # If the set has an attr param, check that it's in the allowed range on the attr
  203. if ( $attr_param ne "null" ) {
  204. my $attr_range = $$mod_ref{'Inputs'}->{$attr_to_set}->{'pos'};
  205. if ( $attr_range =~ m/([0-9]{1,2})\-([0-9]{1,2})/ ) {
  206. my $r_begin = $1;
  207. my $r_end = $2;
  208. if ( $value > $r_end || $value < $r_begin ) {
  209. die "Parse error: attr_param value: $value for $attr_to_set : $attr_param is outside of range: $r_begin $r_end";
  210. }
  211. } else {
  212. die "Somehow encountered parse error in setter for module file $$mod_ref{'Module'}\n";
  213. }
  214. }
  215. $AST{'Sets'}->{$mod_to_set}->{$attr_to_set} = \%set_params;
  216. };
  217. if ( $set_line =~ m/(^[A-Z]{1}[A-Za-z0-9]{1,})\.{1}([A-Za-z0-9]{1,})\ \=\ (.*)$/ ) {
  218. $mod_to_set = $1;
  219. $attr_to_set = $2;
  220. $value = $3;
  221. } elsif ( $set_line =~ m/(^[A-Z]{1}[A-Za-z]{1,})\.{1}([A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})\ \=\ (.*)$/ ) {
  222. $mod_to_set = $1;
  223. $attr_to_set = $2;
  224. $attr_param = $3;
  225. $value = $4;
  226. } else {
  227. die "Parse error at $set_line";
  228. }
  229. if ( ! defined $attr_param || $attr_param eq "" ) {
  230. $attr_param = "null",
  231. };
  232. $setter->($mod_to_set,$attr_to_set,$attr_param,$value);
  233. },
  234. 'connect' => sub {
  235. my $connect_line = shift;
  236. $connect_line = trim($connect_line);
  237. if ( $connect_line =~ m/([A-Z]{1}[A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})\ ([A-Z]{1}[A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})/ ) {
  238. my $output_mod = $1;
  239. my $output_mod_port = $2;
  240. my $input_mod = $3;
  241. my $input_mod_dst = $4;
  242. # Check we have modules defined
  243. if ( ! defined $AST{'Modules'} ) {
  244. die "Parse error: Encountered connection but no modules are imported: $connect_line"
  245. } else {
  246. # Check that connect references imported modules and get module refs
  247. my $output_mod_ref;
  248. my $input_mod_ref;
  249. foreach my $mod_ref ( @{$AST{'Modules'}} ) {
  250. if ( $$mod_ref{'Module'} eq $output_mod ) {
  251. $output_mod_ref = $mod_ref;
  252. } elsif ( $$mod_ref{'Module'} eq $input_mod ) {
  253. $input_mod_ref = $mod_ref;
  254. }
  255. }
  256. # If we reach the end of the loop and input/output refs are not set
  257. # we didn't find the module, and it's a parse error
  258. if ( ! defined $output_mod_ref ||
  259. $output_mod_ref eq "" ||
  260. ! defined $input_mod_ref ||
  261. $input_mod_ref eq "" ) {
  262. die "Parse error, couldn't find $output_mod or $input_mod in AST"
  263. }
  264. # Check src/dst ports
  265. if ( ! defined $$output_mod_ref{'Outputs'}->{$output_mod_port} ) {
  266. die "Parse error: $output_mod_port is not defined in module $output_mod"
  267. } elsif ( ! defined $$input_mod_ref{'Inputs'}->{$input_mod_dst} ) {
  268. die "Parse error: $input_mod_dst is not defined in module $input_mod"
  269. }
  270. # Everything looks good, make connection
  271. my $get_conn_id = sub {
  272. if ( ! defined $AST{'Connections'} ) {
  273. return 0;
  274. } else {
  275. my $c = 0;
  276. foreach my $conn_id ( keys %{$AST{'Connections'}} ) {
  277. $c++;
  278. }
  279. return $c;
  280. }
  281. };
  282. my $conn_id = $get_conn_id->();
  283. my %conn_map = (
  284. 'Output_Module' => $output_mod,
  285. 'Output_Port' => $output_mod_port,
  286. 'Input_Module' => $input_mod,
  287. 'Input_Mod_Dst' => $input_mod_dst,
  288. );
  289. $AST{'Connections'}->{$conn_id} = \%conn_map;
  290. }
  291. } else {
  292. die "Parse error at $connect_line";
  293. }
  294. },
  295. );
  296. # Basic line parser
  297. sub line_parse($) {
  298. my $line = shift;
  299. my $line_type = "null";
  300. my @line_caps;
  301. foreach my $key ( keys %PARSE_TABLE ) {
  302. if ( $line =~ m/$PARSE_TABLE{$key}/ ) {
  303. $line_type = $key;
  304. }
  305. }
  306. if ( $line_type ne "null" && $line =~ m/$PARSE_TABLE{$line_type}/) {
  307. if ( defined $1 && ! defined $2 ) {
  308. $PARSE_RULES{$line_type}->($1);
  309. } elsif ( defined $1 && defined $2 && defined $3 && defined $4 ) {
  310. # This is for `import`
  311. $PARSE_RULES{$line_type}->($1,$2,$3,$4);
  312. } else {
  313. $PARSE_RULES{$line_type}->();
  314. }
  315. } else {
  316. print("$line\n");
  317. }
  318. }
  319. # For testing module definitions
  320. if ( defined $ARGV[1] && $ARGV[1] eq "--import-test" ) {
  321. my $mod_ref = parse_module_file($src_content);
  322. print Dumper $mod_ref;
  323. exit 0;
  324. }
  325. # MAIN starts here - split the input and parse it
  326. foreach my $line ( split("\n", $src_content) ) {
  327. chomp $line;
  328. if ( $line eq "" ) {
  329. next;
  330. }
  331. line_parse($line);
  332. }
  333. # Dump the AST for now. This is where we'd render the output
  334. print Dumper %AST;
  335. my $graph = GraphViz2->new(
  336. edge => {color => 'grey'},
  337. global => {directed => 1},
  338. graph => {label => $AST{'Title'}, rankdir => 'TB'},
  339. node => {shape => 'square'},
  340. );
  341. # Given a mod_ref, construct a graph object
  342. # that represents a module
  343. sub module_node_constructor($$) {
  344. my $graph = shift;
  345. my $mod_ref = shift;
  346. $graph->push_subgraph(
  347. name => "cluster_$$mod_ref{'Module'}",
  348. graph => {label => "$$mod_ref{'Module'}"},
  349. node => {color => 'black', shape => 'circle'},
  350. );
  351. # $graph->push_subgraph(
  352. # name => "cluster_mod_info",
  353. # graph => {label => "mod_info"},
  354. # node => {color => 'grey', shape => 'square'},
  355. # );
  356. # foreach my $node_name ( keys %{$mod_ref} ) {
  357. # if ( $node_name =~ m/Module|Manufacturer|Rev/ ) {
  358. # $graph->add_node(name => "$node_name\n: $$mod_ref{$node_name}", shape => 'square');
  359. # }
  360. # }
  361. # $graph->pop_subgraph;
  362. if ( defined $AST{'Sets'}->{$$mod_ref{'Module'}} ) {
  363. my $sets_ref = $AST{'Sets'}->{$$mod_ref{'Module'}};
  364. foreach my $set ( keys %{$sets_ref} ) {
  365. my $name = "cluster" . "_" . "$set";
  366. my $label = "$set" . "_" . "settings";
  367. $graph->push_subgraph(
  368. name => $name,
  369. graph => {label => $label},
  370. node => {color => "green", shape => 'square'},
  371. );
  372. $graph->add_node(name => "$set : $$sets_ref{$set}->{'Param'} : $$sets_ref{$set}->{'Value'}");
  373. $graph->pop_subgraph;
  374. }
  375. }
  376. # Handle connections
  377. if ( defined $AST{'Connections'} ) {
  378. my $conn_ref = $AST{'Connections'};
  379. foreach my $conn ( keys %{$conn_ref} ) {
  380. if ($$mod_ref{'Module'} eq $$conn_ref{$conn}->{'Output_Module'} ) {
  381. my $name = "cluster" . "_" . "$$conn_ref{$conn}->{'Output_Port'}_$conn";
  382. my $label = "$$conn_ref{$conn}->{'Output_Port'}_$conn";
  383. $graph->push_subgraph(
  384. name => $name,
  385. graph => {label => $label},
  386. node => {color => "blue"},
  387. );
  388. $graph->add_node(name => "$$conn_ref{$conn}->{'Output_Port'}");
  389. $graph->pop_subgraph;
  390. } elsif ($$mod_ref{'Module'} eq $$conn_ref{$conn}->{'Input_Module'} ) {
  391. my $name = "cluster" . "_" . "$$conn_ref{$conn}->{'Input_Mod_Dst'}_$conn";
  392. my $label = "$$conn_ref{$conn}->{'Input_Mod_Dst'}_$conn";
  393. $graph->push_subgraph(
  394. name => $name,
  395. graph => {label => $label},
  396. node => {color => 'purple'},
  397. );
  398. $graph->add_node(name => "$$conn_ref{$conn}->{'Input_Mod_Dst'}");
  399. $graph->pop_subgraph;
  400. }
  401. }
  402. }
  403. $graph->pop_subgraph;
  404. }
  405. # Draw modules
  406. foreach my $mod_ref ( @{$AST{'Modules'}} ) {
  407. module_node_constructor($graph,$mod_ref);
  408. }
  409. # Draw connections
  410. foreach my $conn_ref ( keys %{$AST{'Connections'}} ) {
  411. my $from = $AST{'Connections'}->{$conn_ref}->{'Output_Port'};
  412. my $to = $AST{'Connections'}->{$conn_ref}->{'Input_Mod_Dst'};
  413. $graph->add_edge(color => 'red', from => $from, to => $to);
  414. }
  415. my $format = 'svg';
  416. $graph->run(format => $format, output_file => "test.svg");