https://git.spwbk.site/swatson/modmark/raw/master/pl_proto.pl
___________________________________
#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper;
use lib "/home/swatson/perl5/lib/perl5";
use GraphViz2;

my $SOURCE_FILE = $ARGV[0];

sub read_to_var($) {
       my $file_path = shift;
       my $content;
       open(my $fh, '<', $file_path) or die "cannot open file $file_path";
       {
               local $/;
               $content = <$fh>;
       }
       close($fh);

       return $content;
}

my $src_content = read_to_var($SOURCE_FILE);

sub trim($) {
       my $str = shift;
       $str =~ s/^\s+|\s+$//g;
       return $str;
}

my @module_library_paths = (
       ".",
);
my %modules;

sub parse_module_file {
       my $src = shift;

       my %module;


       my $last_proc_type = "null";
       my $last_input = "null";
       my $last_output = "null";
       foreach my $line ( split("\n", $src) ) {
               chomp $line;
               if ( $line =~ m/^#/ ) {
                       next;
               }

               if ( $line =~ m/^Manufacturer:(.*)/ ) {
                       my $manu = $1;
                       $manu = trim($manu);
                       $module{'Manufacturer'} = $manu;
               }

               if ( $line =~ m/^Module:(.*)/ ) {
                       my $mod = $1;
                       $mod = trim($mod);
                       $module{'Module'} = $mod;
               }

               if ( $line =~ m/^Revision:(.*)/ ) {
                       my $rev = $1;
                       $rev = trim($rev);
                       $module{'Rev'} = $rev;
               }

               if ( $line =~ m/^-\ / ) {
                       if ( $line =~ m/^-\ Input:(.*)/ ) {
                               my $input = $1;
                               $input = trim($input);
                               my %input_chars;
                               $last_input = $input;
                               $last_proc_type = "input";
                               $module{'Inputs'}->{$input} = \%input_chars;
                       }

                       if ( $line =~ m/^-\ Knob:(.*)/ ) {
                               my $knob = $1;
                               $knob = trim($knob);
                               my %knob_chars;
                               $last_input = $knob;
                               $last_proc_type = "input";
                               $module{'Inputs'}->{$knob} = \%knob_chars;
                       }

                       if ( $line =~ m/^-\ Output:(.*)/ ) {
                               my $output = $1;
                               $output = trim($output);
                               my %output_chars;
                               $last_output = $output;
                               $last_proc_type = "output";
                               $module{'Outputs'}->{$output} = \%output_chars;
                       }

                       if ( $line =~ m/^-\ Button:(.*)/ ) {
                               my $button = $1;
                               $button = trim($button);
                               my %button_chars;
                               $last_input = $button;
                               $last_proc_type = "input";
                               $module{'Inputs'}->{$button} = \%button_chars;
                       }

               }

               if ( $line =~ m/^--\ / ) {
                       if ( $line =~ m/^--\ Position:(.*)/ ) {
                               my $pos_args = $1;
                               $pos_args = trim($pos_args);
                               if ( $last_proc_type eq "input" ) {
                                       $module{'Inputs'}->{$last_input}->{'pos'} = $pos_args;
                               } elsif ( $last_proc_type eq "output" ) {
                                       $module{'Outputs'}->{$last_output}->{'pos'} = $pos_args;
                               }
                       }
               }

       }

       return \%module;
}

my %AST;

my %PARSE_TABLE = (
       'comment' => '^#.*$',
       'title' => '^Title: (.*)$',
       'mod_path' => '^ModuleDir\ "(.*)"$',
       'import' => '^import (Module)::([a-zA-Z0-9]{1,})::([a-zA-Z0-9]{1,})(.*$)',
       'set' => '^set\ (.*)$',
       'connect' => '^connect(.*)$',
);

my %PARSE_RULES = (
       'comment' => sub {
               # Do nothing, throw this line out
       },
       'title' => sub {
               my $title = shift;
               $AST{'Title'} = $title;
       },
       'mod_path' => sub {
               my $file_path = shift;
               if ( ! -d $file_path ) {
                       die "Path: $file_path doesn't look like a directory, exiting";
               }

               push(@module_library_paths, $file_path);
       },
       'import' => sub {
               my $module_import = shift;
               my $import_manu = shift;
               my $import_mod = shift;
               my $import_as = shift;
               my @module_files = sub {
                       my @files;
                       foreach my $path ( @module_library_paths ) {
                               my @f = split("\n", `find $path`);
                               foreach my $file ( @f ) {
                                       if ( $file =~ m/.module$/ ) {
                                               my $f_bn = `basename $file`;
                                               chomp $f_bn;
                                               if ( ! grep(/$f_bn/, @files) ) {
                                                       push(@files, $file);
                                               }
                                       }
                               }
                       }
                       return @files;
               }->();
               foreach my $mod_file ( @module_files ) {
                       my $mod_file_content = read_to_var($mod_file);
                       my $mod_ref = parse_module_file($mod_file_content);

                       if ( $import_mod eq $$mod_ref{'Module'} ) {

                               if ( defined $AST{'Modules'} ) {
                                       my $r = grep { $import_mod eq $_->{'Module'} } @{$AST{'Modules'}};
                                       if ( $r == 0 ) {
                                               push(@{$AST{'Modules'}}, $mod_ref);
                                       }
                               } else {
                                       push(@{$AST{'Modules'}}, $mod_ref);
                               }
                       } else {
                               next;
                       }
               }
       },
       'set' => sub {
               my $set_line = shift;
               my $mod_to_set;
               my $attr_to_set;
               my $attr_param;
               my $value;
               my $setter = sub {
                       my $mod_to_set = shift;
                       my $attr_to_set = shift;
                       my $attr_param = shift;
                       if ( $attr_param eq "position" ) {
                               $attr_param = "pos";
                       }
                       my $value = shift;

                       my %set_params = (
                               'Param' => $attr_param,
                               'Value' => $value,
                       );

                       # Check values against mod definition
                       # Pull mod ref out of AST for straight forward checking
                       my $mod_ref;
                       # Check we have module in AST
                       my $r = grep { $mod_to_set eq $_->{'Module'} } @{$AST{'Modules'}};
                       if ( $r eq 0 ) {
                               die "Can't set value on module that is not imported: $mod_to_set\n";
                       } else {
                               foreach my $module_ref ( @{$AST{'Modules'}} ) {
                                       if ( $mod_to_set eq $$module_ref{'Module'} ) {
                                               $mod_ref = $module_ref;
                                               last;
                                       }
                               }
                       }

                       # Check that module has param we want to set
                       if ( ! $attr_to_set eq $$mod_ref{'Inputs'}->{$attr_to_set} ) {
                               die "Can't set a param that doesn't existing in the module spec: $attr_to_set";
                       }

                       # If the set has an attr param, check that it's in the allowed range on the attr
                       if ( $attr_param ne "null" ) {
                               my $attr_range = $$mod_ref{'Inputs'}->{$attr_to_set}->{'pos'};
                               if ( $attr_range =~ m/([0-9]{1,2})\-([0-9]{1,2})/ ) {
                                       my $r_begin = $1;
                                       my $r_end = $2;
                                       if ( $value > $r_end || $value < $r_begin ) {
                                               die "Parse error: attr_param value: $value for $attr_to_set : $attr_param is outside of range: $r_begin $r_end";
                                       }
                               } else {
                                       die "Somehow encountered parse error in setter for module file $$mod_ref{'Module'}\n";
                               }
                       }

                       $AST{'Sets'}->{$mod_to_set}->{$attr_to_set} = \%set_params;
               };

               if ( $set_line =~ m/(^[A-Z]{1}[A-Za-z0-9]{1,})\.{1}([A-Za-z0-9]{1,})\ \=\ (.*)$/ ) {
                       $mod_to_set = $1;
                       $attr_to_set = $2;
                       $value = $3;
               } elsif ( $set_line =~ m/(^[A-Z]{1}[A-Za-z]{1,})\.{1}([A-Za-z0-9]{1,})\.([A-Za-z0-9]{1,})\ \=\ (.*)$/ ) {
                       $mod_to_set = $1;
                       $attr_to_set = $2;
                       $attr_param = $3;
                       $value = $4;
               } else {
                       die "Parse error at $set_line";
               }

               if ( ! defined $attr_param || $attr_param eq "" ) {
                       $attr_param = "null",
               };

               $setter->($mod_to_set,$attr_to_set,$attr_param,$value);
       },
       'connect' => sub {
               my $connect_line = shift;
               $connect_line = trim($connect_line);
               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,})/ ) {
                       my $output_mod = $1;
                       my $output_mod_port = $2;
                       my $input_mod = $3;
                       my $input_mod_dst = $4;

                       # Check we have modules defined
                       if ( ! defined $AST{'Modules'} ) {
                               die "Parse error: Encountered connection but no modules are imported: $connect_line"
                       } else {
                               # Check that connect references imported modules and get module refs
                               my $output_mod_ref;
                               my $input_mod_ref;
                               foreach my $mod_ref ( @{$AST{'Modules'}} ) {
                                       if ( $$mod_ref{'Module'} eq $output_mod ) {
                                               $output_mod_ref = $mod_ref;
                                       } elsif ( $$mod_ref{'Module'} eq $input_mod ) {
                                               $input_mod_ref = $mod_ref;
                                       }
                               }
                               # If we reach the end of the loop and input/output refs are not set
                               # we didn't find the module, and it's a parse error
                               if ( ! defined $output_mod_ref ||
                                    $output_mod_ref eq "" ||
                                    ! defined $input_mod_ref ||
                                    $input_mod_ref eq "" ) {
                                       die "Parse error, couldn't find $output_mod or $input_mod in AST"
                               }

                               # Check src/dst ports
                               if ( ! defined $$output_mod_ref{'Outputs'}->{$output_mod_port} ) {
                                       die "Parse error: $output_mod_port is not defined in module $output_mod"
                               } elsif ( ! defined $$input_mod_ref{'Inputs'}->{$input_mod_dst} ) {
                                       die "Parse error: $input_mod_dst is not defined in module $input_mod"
                               }

                               # Everything looks good, make connection
                               my $get_conn_id = sub {
                                       if ( ! defined $AST{'Connections'} ) {
                                               return 0;
                                       } else {
                                               my $c = 0;
                                               foreach my $conn_id ( keys %{$AST{'Connections'}} ) {
                                                       $c++;
                                               }
                                               return $c;
                                       }
                               };
                               my $conn_id = $get_conn_id->();
                               my %conn_map = (
                                       'Output_Module' => $output_mod,
                                       'Output_Port' => $output_mod_port,
                                       'Input_Module' => $input_mod,
                                       'Input_Mod_Dst' => $input_mod_dst,
                               );
                               $AST{'Connections'}->{$conn_id} = \%conn_map;

                       }
               } else {
                       die "Parse error at $connect_line";
               }
       },

);

# Basic line parser
sub line_parse($) {
       my $line = shift;
       my $line_type = "null";
       my @line_caps;
       foreach my $key ( keys %PARSE_TABLE ) {
               if ( $line =~ m/$PARSE_TABLE{$key}/ ) {
                       $line_type = $key;
               }
       }

       if ( $line_type ne "null" && $line =~ m/$PARSE_TABLE{$line_type}/) {
               if ( defined $1 && ! defined $2 ) {
                       $PARSE_RULES{$line_type}->($1);
               } elsif ( defined $1 && defined $2 && defined $3 && defined $4 ) {
                       # This is for `import`
                       $PARSE_RULES{$line_type}->($1,$2,$3,$4);
               } else {
                       $PARSE_RULES{$line_type}->();
               }
       } else {
               print("$line\n");
       }
}

# For testing module definitions
if ( defined $ARGV[1] && $ARGV[1] eq "--import-test" ) {
       my $mod_ref = parse_module_file($src_content);
       print Dumper $mod_ref;
       exit 0;
}

# MAIN starts here - split the input and parse it
foreach my $line ( split("\n", $src_content) ) {
       chomp $line;
       if ( $line eq "" ) {
               next;
       }
       line_parse($line);
}

# Dump the AST for now. This is where we'd render the output
print Dumper %AST;

my $graph = GraphViz2->new(
       edge   => {color => 'grey'},
       global => {directed => 1},
       graph  => {label => $AST{'Title'}, rankdir => 'TB'},
       node   => {shape => 'square'},
);

# Given a mod_ref, construct a graph object
# that represents a module
sub module_node_constructor($$) {
       my $graph = shift;
       my $mod_ref = shift;
       $graph->push_subgraph(
               name => "cluster_$$mod_ref{'Module'}",
               graph => {label => "$$mod_ref{'Module'}"},
               node => {color => 'black', shape => 'circle'},
       );

       # $graph->push_subgraph(
       #               name => "cluster_mod_info",
       #               graph => {label => "mod_info"},
       #               node => {color => 'grey', shape => 'square'},
       # );
       # foreach my $node_name ( keys %{$mod_ref} ) {
       #       if ( $node_name =~ m/Module|Manufacturer|Rev/ ) {
       #               $graph->add_node(name => "$node_name\n: $$mod_ref{$node_name}", shape => 'square');
       #       }
       # }

       # $graph->pop_subgraph;

       if ( defined $AST{'Sets'}->{$$mod_ref{'Module'}} ) {
               my $sets_ref = $AST{'Sets'}->{$$mod_ref{'Module'}};
               foreach my $set ( keys %{$sets_ref} ) {
                       my $name = "cluster" . "_" . "$set";
                       my $label = "$set" . "_" . "settings";
                       $graph->push_subgraph(
                               name => $name,
                               graph => {label => $label},
                               node => {color => "green", shape => 'square'},
                       );
                       $graph->add_node(name => "$set : $$sets_ref{$set}->{'Param'} : $$sets_ref{$set}->{'Value'}");
                       $graph->pop_subgraph;
               }
       }

       # Handle connections
       if ( defined $AST{'Connections'} ) {
               my $conn_ref = $AST{'Connections'};
               foreach my $conn ( keys %{$conn_ref} ) {
                       if ($$mod_ref{'Module'} eq $$conn_ref{$conn}->{'Output_Module'} ) {
                               my $name = "cluster" . "_" . "$$conn_ref{$conn}->{'Output_Port'}_$conn";
                               my $label = "$$conn_ref{$conn}->{'Output_Port'}_$conn";
                               $graph->push_subgraph(
                                       name => $name,
                                       graph => {label => $label},
                                       node => {color => "blue"},
                               );
                               $graph->add_node(name => "$$conn_ref{$conn}->{'Output_Port'}");
                               $graph->pop_subgraph;
                       } elsif ($$mod_ref{'Module'} eq $$conn_ref{$conn}->{'Input_Module'} ) {
                               my $name = "cluster" . "_" . "$$conn_ref{$conn}->{'Input_Mod_Dst'}_$conn";
                               my $label = "$$conn_ref{$conn}->{'Input_Mod_Dst'}_$conn";
                               $graph->push_subgraph(
                                       name => $name,
                                       graph => {label => $label},
                                       node => {color => 'purple'},
                               );
                               $graph->add_node(name => "$$conn_ref{$conn}->{'Input_Mod_Dst'}");
                               $graph->pop_subgraph;
                       }

               }
       }

       $graph->pop_subgraph;
}

# Draw modules
foreach my $mod_ref ( @{$AST{'Modules'}} ) {
       module_node_constructor($graph,$mod_ref);
}

# Draw connections
foreach my $conn_ref ( keys %{$AST{'Connections'}} ) {
       my $from = $AST{'Connections'}->{$conn_ref}->{'Output_Port'};
       my $to = $AST{'Connections'}->{$conn_ref}->{'Input_Mod_Dst'};
       $graph->add_edge(color => 'red', from => $from, to => $to);
}

my $format = 'svg';
$graph->run(format => $format, output_file => "test.svg");

You are viewing proxied material from chate.io. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.