URL https://opencores.org/ocsvn/an-fpga-implementation-of-low-latency-noc-based-mpsoc/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk
Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc

[/] [an-fpga-implementation-of-low-latency-noc-based-mpsoc/] [trunk/] [mpsoc/] [perl_gui/] [lib/] [perl/] [common.pl] - Blame information for rev 54

Details | Compare with Previous | View Log

#!/usr/bin/perl -w
 
use strict;
use warnings;
 
use String::Similarity;
use Proc::Background;
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep  clock_gettime clock_getres clock_nanosleep clock stat );
 
use List::MoreUtils qw(uniq);
use POSIX qw(ceil floor);
 
use Cwd 'abs_path';
use Term::ANSIColor qw(:constants);
use IPC::Run qw(start pump finish timeout pumpable);
 
use FindBin;
use lib $FindBin::Bin;
use constant::boolean;
use IO::CaptureOutput qw(capture qxx qxy);
 
 
our %glob_setting;
$glob_setting{'FONT_SIZE'}='default';
$glob_setting{'ICON_SIZE'}='default';
$glob_setting{'DSPLY_X'}  ='default';
$glob_setting{'DSPLY_Y'}  ='default';
 
 
 
 
sub log2{
        my $num=shift;
        my $log=($num <=1) ? 1: 0;
        while( (1<< $log)  < $num) {
                                $log++;
        }
        return  $log;
}
 
sub find_the_most_similar_position{
        my ($item ,@list)=@_;
        my $most_similar_pos=0;
        my $lastsim=0;
        my $i=0;
        # convert item to lowercase
        $item = lc $item;
        foreach my $p(@list){
                my $similarity= similarity $item, $p;
                if ($similarity > $lastsim){
                        $lastsim=$similarity;
                        $most_similar_pos=$i;
                }
                $i++;
        }
        return $most_similar_pos;
}
 
sub is_integer {
   defined $_[0] && $_[0] =~ /^[+-]?\d+$/;
}
 
 
####################
#        verilog file
##################
 
 
sub read_verilog_file{
        my @files            = @_;
        my %cmd_line_defines = ();
        my $quiet            = 1;
        my @inc_dirs         = ();
        my @lib_dirs         = ();
        my @lib_exts         = ();
        my $vdb = rvp->read_verilog(\@files,[],\%cmd_line_defines,
                          $quiet,\@inc_dirs,\@lib_dirs,\@lib_exts);
 
        my @problems = $vdb->get_problems();
        if (@problems) {
            foreach my $problem ($vdb->get_problems()) {
                print STDERR "$problem.\n" unless ( $problem =~ /smartflit_chanel_t/);
            }
            # die "Warnings parsing files!";
        }
        return $vdb;
}
 
 
sub verilog_file_get_ports_list{
        my ($vdb,$top_module)=@_;
        my @ports;
 
        foreach my $sig (sort $vdb->get_modules_signals($top_module)) {
        my ($line,$a_line,$i_line,$type,$file,$posedge,$negedge,
         $type2,$s_file,$s_line,$range,$a_file,$i_file,$dims) =
           $vdb->get_module_signal($top_module,$sig);
 
                if($type eq "input" or $type eq "inout" or $type eq "output" ){
                        push(@ports, $sig);
 
                }
        }
        return @ports;
}
 
 
 
sub get_ports_type{
        my ($vdb,$top_module)=@_;
        my %ports;
 
        foreach my $sig (sort $vdb->get_modules_signals($top_module)) {
        my ($line,$a_line,$i_line,$type,$file,$posedge,$negedge,
         $type2,$s_file,$s_line,$range,$a_file,$i_file,$dims) =
           $vdb->get_module_signal($top_module,$sig);
 
                if($type eq "input" or $type eq "inout" or $type eq "output" ){
                        $ports{$sig}=$type;
 
                }
        }
        return %ports;
}
 
 
 
sub get_ports_rang{
        my ($vdb,$top_module)=@_;
        my %ports;
 
        foreach my $sig (sort $vdb->get_modules_signals($top_module)) {
        my ($line,$a_line,$i_line,$type,$file,$posedge,$negedge,
         $type2,$s_file,$s_line,$range,$a_file,$i_file,$dims) =
           $vdb->get_module_signal($top_module,$sig);
 
                if($type eq "input" or $type eq "inout" or $type eq "output" ){
 
 
 
                        $ports{$sig}=remove_all_white_spaces($range);
 
                }
        }
        return %ports;
}
 
 
 
 
sub get_param_list_in_order {
   my $ref =shift;
   return undef if (!defined $ref);
   my %param=%{$ref};
   my @array = sort keys %param;
   my $l= scalar @array;
   SCAN: {
   foreach my $i (0..($l-2)) {
      my $str1=$array[$i];
      foreach my $j ($i+1..($l-1)) {
      my $str2=$array[$j];
        if ($param{$str1} =~ /\b$str2\b/ ) {
 
        my $tmp = $array[$i];
        $array[$i] =$array[$j];
        $array[$j]=$tmp;
 
        redo SCAN;
      }
    }
    }
  }
 
  return @array;
}
 
sub gen_verilator_makefile{
        my ($top_ref,$target_dir) =@_;
        my %tops = %{$top_ref};
        my $p='';
        my $q='';
        my $h='';
        my $l;
        my $lib_num=0;
        my $all_lib="";
        foreach my $top (sort keys %tops) {
                $p = "$p ${top}__ALL.a ";
                $q = $q."lib$lib_num:\n\t\$(MAKE) -f ${top}.mk\n";
                $h = "$h ${top}.h ";
                $l = $top;
                $all_lib=$all_lib." lib$lib_num";
                $lib_num++;
        }
 
        my $make= "
 
default: sim
 
 
 
include $l.mk
 
lib: $all_lib
 
$q
 
 
#######################################################################
# Compile flags
 
CPPFLAGS += -DVL_DEBUG=1
ifeq (\$(CFG_WITH_CCWARN),yes)  # Local... Else don't burden users
CPPFLAGS += -DVL_THREADED=1
CPPFLAGS += -W -Werror -Wall
endif
 
SLIB =
HLIB =
ifneq (\$(wildcard synful/synful.a),)
SLIB += synful/synful.a
HLIB += synful/synful.h
endif
 
#######################################################################
# Linking final exe -- presumes have a sim_main.cpp
 
 
sim:    testbench.o \$(VK_GLOBAL_OBJS) $p \$(SLIB)
        \$(LINK) \$(LDFLAGS) -g \$^ \$(LOADLIBES) \$(LDLIBS) -o testbench \$(LIBS) -Wall -O3 -lpthread 2>&1 | c++filt
 
testbench.o: testbench.cpp $h  \$(HLIB)
 
clean:
        rm *.o *.a testbench
";
 
save_file ($target_dir,$make);
 
}
 
 
####################
#        file
##################
 
 
sub append_text_to_file {
        my  ($file_path,$text)=@_;
        open(my $fd, ">>$file_path") or die "could not open $file_path: $!";
        print $fd $text;
        close $fd;
}
 
 
 
 
sub save_file {
        my  ($file_path,$text)=@_;
        open my $fd, ">$file_path" or die "could not open $file_path: $!";
        print $fd $text;
        close $fd;
}
 
sub load_file {
        my $file_path=shift;
        my $str;
        if (-f "$file_path") {
 
                $str = do {
                        local $/ = undef;
                        open my $fh, "<", $file_path
                        or die "could not open $file_path: $!";
                        <$fh>;
                };
 
        }
        return $str;
}
 
sub merg_files {
        my  ($source_file_path,$dest_file_path)=@_;
        local $/=undef;
        open FILE, $source_file_path or die "Couldn't open file: $!";
        my $string = <FILE>;
        close FILE;
         append_text_to_file ($dest_file_path,$string);
}
 
 
 
sub copy_file_and_folders{
        my ($file_ref,$project_dir,$target_dir)=@_;
 
        foreach my $f(@{$file_ref}){
                my $name= basename($f);
 
                my $n="$project_dir$f";
                if (-f "$n") { #copy file
                        copy ("$n","$target_dir/$name");
                }elsif(-f "$f" ){
                        copy ("$f","$target_dir/$name");
                }elsif (-d "$n") {#copy folder
                        dircopy ("$n","$target_dir/$name");
                }elsif(-d "$f" ){
                        dircopy ("$f","$target_dir/$name");
 
                }
        }
 
}
 
 
sub remove_file_and_folders{
        my ($file_ref,$project_dir)=@_;
 
        foreach my $f(@{$file_ref}){
                my $name= basename($f);
                my $n="$project_dir$f";
                if (-f "$n") { #copy file
                        unlink ("$n");
                }elsif(-f "$f" ){
                        unlink ("$f");
                }elsif (-d "$n") {#copy folder
                        rmtree ("$n");
                }elsif(-d "$f" ){
                        rmtree ("$f");
                }
        }
 
}
 
sub read_file_cntent {
        my ($f,$project_dir)=@_;
        my $n="$project_dir$f";
        my $str;
        if (-f "$n") {
 
                $str = do {
                        local $/ = undef;
                        open my $fh, "<", $n
                        or die "could not open $n: $!";
                        <$fh>;
                };
 
        }elsif(-f "$f" ){
                $str = do {
                        local $/ = undef;
                        open my $fh, "<", $f
                        or die "could not open $f: $!";
                        <$fh>;
                };
 
 
        }
        return $str;
 
}
 
 
sub check_file_has_string {
    my ($file,$string)=@_;
    my $r;
    open(FILE,$file);
    if (grep{/$string/} <FILE>){
       $r= 1; #print "word  found\n";
    }else{
       $r= 0; #print "word not found\n";
    }
    close FILE;
    return $r;
}
 
#return lines containig pattern in a givn file
sub unix_grep {
        my ($file,$pattern)=@_;
    open(FILE,$file);
    my @arr = <FILE>;
    my @lines = grep /$pattern/, @arr;
        return @lines;
}
 
 
sub count_file_line_num {
    my ($file)=@_;
    open(FILE,$file);
    my $n=0;
    while (my $line = <FILE>) {
           $n++;
        }
    close FILE;
    return $n;
}
 
sub set_path_env{
        my $project_dir   = get_project_dir(); #mpsoc dir addr
        my $paths_file= "$project_dir/mpsoc/perl_gui/lib/Paths";
        #print "$paths_file\n";
        my $paths= do $paths_file;
        my $pronoc_work =object_get_attribute($paths,"PATH","PRONOC_WORK");
        my $quartus = object_get_attribute($paths,"PATH","QUARTUS_BIN");
        my $vivado  = object_get_attribute($paths,"PATH","VIVADO_BIN");
        my $sdk     = object_get_attribute($paths,"PATH","SDK_BIN");
 
        my $modelsim = object_get_attribute($paths,"PATH","MODELSIM_BIN");
        $ENV{'PRONOC_WORK'}= $pronoc_work if( defined $pronoc_work);
        $ENV{'QUARTUS_BIN'}= $quartus if( defined $quartus);
        $ENV{'VIVADO_BIN'}= $vivado if( defined $vivado);
        $ENV{'SDK_BIN'}= $vivado if( defined $sdk);
        $ENV{'MODELSIM_BIN'}= $modelsim if( defined $modelsim);
 
        if( defined $pronoc_work){if(-d $pronoc_work ){
                        mkpath("$pronoc_work/emulate",1,01777) unless -d "$pronoc_work/emulate";
                        mkpath("$pronoc_work/simulate",1,01777) unless -d "$pronoc_work/simulate";
                        mkpath("$pronoc_work/tmp",1,01777) unless -d "$pronoc_work/tmp";
        }}
 
        #add quartus_bin to PATH linux environment if it does not exist in PATH
        my $add;
        if( defined $quartus){
                my @q =split  (/:/,$ENV{'PATH'});
                my $p=get_scolar_pos ($quartus,@q);
                $ENV{'PATH'}= $ENV{'PATH'}.":$quartus" unless ( defined $p);
                $add=(defined $add)? $add.":$quartus" : $quartus unless ( defined $p);
 
        }
 
        if( defined $vivado){
                my @q =split  (/:/,$ENV{'PATH'});
                my $p=get_scolar_pos ($vivado,@q);
                $ENV{'PATH'}= $ENV{'PATH'}.":$vivado" unless ( defined $p);
                $add=(defined $add)? $add.":$vivado" : $vivado unless ( defined $p);
 
        }
 
        if( defined $sdk){
                my @q =split  (/:/,$ENV{'PATH'});
                my $p=get_scolar_pos ($sdk,@q);
                $ENV{'PATH'}= $ENV{'PATH'}.":$sdk" unless ( defined $p);
                $add=(defined $add)? $add.":$sdk" : $sdk unless ( defined $p);
 
        }
        if(defined $add){
                print GREEN, "Info: $add has been added to linux PATH envirement.\n",RESET,"\n";
 
        }
 
 
}
 
 
 
sub source_file {
    my $file = shift;
    open my $fh, "<", $file   or return  "could not open $file: $!";
 
    while (<$fh>) {
        chomp;
        #FIXME: this regex isn't quite good enough
        next unless my ($var, $value) = /\s*(\w+)=([^#]+)/;
        $ENV{$var} = $value;
    }
    return undef;
}
 
 
##############
#  clone_obj
#############
 
sub clone_obj{
        my ($self,$clone)=@_;
 
        foreach my $p (keys %$self){
                delete ($self->{$p});
        }
        foreach my $p (keys %$clone){
                $self->{$p}= $clone->{$p};
                my $ref= ref ($clone->{$p});
                if( $ref eq 'HASH' ){
 
                        foreach my $q (keys %{$clone->{$p}}){
                                $self->{$p}{$q}= $clone->{$p}{$q};
                                my $ref= ref ($self->{$p}{$q});
                                if( $ref eq 'HASH' ){
 
                                        foreach my $z (keys %{$clone->{$p}{$q}}){
                                                $self->{$p}{$q}{$z}= $clone->{$p}{$q}{$z};
                                                my $ref= ref ($self->{$p}{$q}{$z});
                                                if( $ref eq 'HASH' ){
 
                                                        foreach my $w (keys %{$clone->{$p}{$q}{$z}}){
                                                                $self->{$p}{$q}{$z}{$w}= $clone->{$p}{$q}{$z}{$w};
                                                                my $ref= ref ($self->{$p}{$q}{$z}{$w});
                                                                if( $ref eq 'HASH' ){
 
 
                                                                        foreach my $m (keys %{$clone->{$p}{$q}{$z}{$w}}){
                                                                                $self->{$p}{$q}{$z}{$w}{$m}= $clone->{$p}{$q}{$z}{$w}{$m};
                                                                                my $ref= ref ($self->{$p}{$q}{$z}{$w}{$m});
                                                                                if( $ref eq 'HASH' ){
 
                                                                                        foreach my $n (keys %{$clone->{$p}{$q}{$z}{$w}{$m}}){
                                                                                                $self->{$p}{$q}{$z}{$w}{$m}{$n}= $clone->{$p}{$q}{$z}{$w}{$m}{$n};
                                                                                                my $ref= ref ($self->{$p}{$q}{$z}{$w}{$m}{$n});
                                                                                                if( $ref eq 'HASH' ){
 
                                                                                                        foreach my $l (keys %{$clone->{$p}{$q}{$z}{$w}{$m}{$n}}){
                                                                                                                $self->{$p}{$q}{$z}{$w}{$m}{$n}{$l}= $clone->{$p}{$q}{$z}{$w}{$m}{$n}{$l};
                                                                                                                my $ref= ref ($self->{$p}{$q}{$z}{$w}{$m}{$n}{$l});
                                                                                                                if( $ref eq 'HASH' ){
                                                                                                                }
                                                                                                        }
 
                                                                                                }#if                                                                                                            
                                                                                        }#n
                                                                                }#if
                                                                        }#m                                                     
                                                                }#if
                                                        }#w
                                                }#if
                                        }#z
                                }#if
                        }#q
                }#if    
        }#p
}#sub   
 
 
sub get_project_dir{ #mpsoc directory address
        my $dir = Cwd::getcwd();
        my @p=  split('/perl_gui',$dir);
        @p=     split('/Integration_test',$p[0]);
    my $d         = abs_path("$p[0]/../");
 
        return $d;
}
 
sub cut_dir_path{
        my ($dir,$folder_name) = @_;
        my @p=  split (/\/$folder_name\//,$dir);
        return $p[-1];
}
 
 
sub remove_project_dir_from_addr{
        my $file=shift;
        my $project_dir   = get_project_dir();
        $file =~ s/$project_dir//;
        return $file;
}
 
sub add_project_dir_to_addr{
        my $file=shift;
        my $project_dir   = get_project_dir();
        return $file if(-f $file );
        return "$project_dir/$file";
 
}
 
sub get_full_path_addr{
        my $file=shift;
        my $dir = Cwd::getcwd();
        my $full_path = "$dir/$file";
        return $full_path  if -f ($full_path );
        return $file;
}
 
sub regen_object {
        my $path=shift;
        $path = get_full_path_addr($path);
        my $pp= eval { do $path };
        my $r= ($@ || !defined $pp);
        return ($pp,$r,$@);
}
 
 
################
#       general
#################
 
sub remove_not_hex {
        my $s=shift;
        $s =~ s/[^0-9a-fA-F]//g;
        return $s;
}
 
sub remove_not_number {
        my $s=shift;
        $s =~ s/[^0-9]//g;
        return $s;
 
}
 
sub  trim { my $s = shift;  $s=~s/[\n]//gs; return $s };
 
sub remove_all_white_spaces($)
{
  my $string = shift;
  $string =~ s/\s+//g;
  return $string;
}
 
 
sub check_scolar_exist_in_array{
        my ($value,$ref)=@_;
        my @array= @{$ref};
        if ( grep( /^\Q$value\E$/, @array ) ) {
          return 1;
        }
        return 0
}
 
sub get_item_pos{#if not in return 0
                my ($item,@list)=@_;
                my $pos=0;
                foreach my $p (@list){
                                #print "$p eq $item\n";
                                if ($p eq $item){return $pos;}
                                $pos++;
                }
                return 0;
 
}
 
sub get_scolar_pos{
        my ($item,@list)=@_;
        my $pos;
        my $i=0;
        foreach my $c (@list)
        {
                if(  $c eq $item) {$pos=$i}
                $i++;
        }
        return $pos;
}
 
sub get_pos{
        my ($item,@list)=@_;
        my $pos=0;
        foreach my $p (@list){
                #print "$p eq $item\n";
                if ($p eq $item){return $pos;}
                $pos++;
        }
        return undef;
}
 
sub remove_scolar_from_array{
        my ($array_ref,$item)=@_;
        my @array=@{$array_ref};
        my @new;
        foreach my $p (@array){
                if($p ne $item ){
                        push(@new,$p);
                }
        }
        return @new;
}
 
sub replace_in_array{
        my ($array_ref,$item1,$item2)=@_;
        my @array=@{$array_ref};
        my @new;
        foreach my $p (@array){
                if($p eq $item1 ){
                        push(@new,$item2);
                }else{
                        push(@new,$p);
                }
        }
        return @new;
}
 
 
 
# return an array of common elemnts between two input arays 
sub get_common_array{
        my ($a_ref,$b_ref)=@_;
        my @A=@{$a_ref};
        my @B=@{$b_ref};
        my @C;
        foreach my $p (@A){
                if( grep (/^\Q$p\E$/,@B)){push(@C,$p)};
        }
        return  @C;
}
 
#a-b
sub get_diff_array{
        my ($a_ref,$b_ref)=@_;
        my @A=@{$a_ref};
        my @B=@{$b_ref};
        my @C;
        foreach my $p (@A){
                if( !grep  (/^\Q$p\E$/,@B)){push(@C,$p)};
        }
        return  @C;
 
}
 
 
sub return_not_unique_names_in_array{
        my @array = @_;
        my %seen;
        my @r;
        foreach my $value (@array) {
                if (! $seen{$value}) {
                $seen{$value} = 1;
                }else{
                        push(@r,$value);
                }
        }
        return @r;
}
 
 
sub compress_nums{
        my      @nums=@_;
        my @f=sort { $a <=> $b } @nums;
        my $s;
        my $ls;
        my $range=0;
        my $x;
 
 
        foreach my $p (@f){
                if(!defined $x) {
                        $s="$p";
                        $ls=$p;
 
                }
                else{
                        if($p-$x>1){ #gap exist
                                if( $range){
                                        $s=($x-$ls>1 )? "$s:$x,$p": "$s,$x,$p";
                                        $ls=$p;
                                        $range=0;
                                }else{
                                $s= "$s,$p";
                                $ls=$p;
 
                                }
 
                        }else {$range=1;}
 
 
 
                }
 
                $x=$p
        }
        if($range==1){ $s= ($x-$ls>1 )? "$s:$x":  "$s,$x";}
        #update $s($ls,$hs);
 
        return $s;
 
}
 
 
 
sub metric_conversion{
        my $size=shift;
        my $size_text=  $size<=0  ? 'Error ':
                        $size<(1 << 10)? $size:
                        $size<(1 << 20)? join (' ', ($size>>10,"K")) :
                        $size<(1 << 30)? join (' ', ($size>>20,"M")) :
                                         join (' ', ($size>>30,"G")) ;
return $size_text;
}
 
 
 
 
 
######
#  state
#####
sub set_gui_status{
        my ($object,$status,$timeout)=@_;
        $object->object_add_attribute('gui_status','status',$status);
        $object->object_add_attribute('gui_status','timeout',$timeout);
}
 
 
sub get_gui_status{
        my ($object)=@_;
        my $status= $object->object_get_attribute('gui_status','status');
        my $timeout=$object->object_get_attribute('gui_status','timeout');
        return ($status,$timeout);
}
 
 
 
 
###########
#  color
#########
 
 
 
sub get_color {
        my $num=shift;
 
        my @colors=(
        0x6495ED,#Cornflower Blue
        0xFAEBD7,#Antiquewhite
        0xC71585,#Violet Red
        0xC0C0C0,#silver
        0xADD8E6,#Lightblue     
        0x6A5ACD,#Slate Blue
        0x00CED1,#Dark Turquoise
        0x008080,#Teal
        0x2E8B57,#SeaGreen
        0xFFB6C1,#Light Pink
        0x008000,#Green
        0xFF0000,#red
        0x808080,#Gray
        0x808000,#Olive
        0xFF69B4,#Hot Pink
        0xFFD700,#Gold
        0xDAA520,#Goldenrod
        0xFFA500,#Orange
        0x32CD32,#LimeGreen
        0x0000FF,#Blue
        0xFF8C00,#DarkOrange
        0xA0522D,#Sienna
        0xFF6347,#Tomato
        0x0000CD,#Medium Blue
        0xFF4500,#OrangeRed
        0xDC143C,#Crimson       
        0x9932CC,#Dark Orchid
        0x800000,#marron
        0x800080,#Purple
        0x4B0082,#Indigo
        0xFFFFFF,#white 
        0x000000, #Black                
                #heatmap
        0xbdff00, #     (189,255,0)
        0xe3f018, #     (227,240,24)
        0xffce00, #     (255,206,0)
        0xff6612, #     (255,102,18)
        0xc12424, #     (193,36,36)
                );
 
        my $color=      ($num< scalar (@colors))? $colors[$num]: 0xFFFFFF;
        my $red=        ($color & 0xFF0000) >> 8;
        my $green=      ($color & 0x00FF00);
        my $blue=       ($color & 0x0000FF) << 8;
 
        return ($red,$green,$blue);
 
}
 
 
sub get_color_hex_string {
        my $num=shift;
 
        my @colors=(
        "6495ED",#Cornflower Blue
        "FAEBD7",#Antiquewhite
        "C71585",#Violet Red
        "C0C0C0",#silver
        "ADD8E6",#Lightblue     
        "6A5ACD",#Slate Blue
        "00CED1",#Dark Turquoise
        "008080",#Teal
        "2E8B57",#SeaGreen
        "FFB6C1",#Light Pink
        "008000",#Green
        "FF0000",#red
        "808080",#Gray
        "808000",#Olive
        "FF69B4",#Hot Pink
        "FFD700",#Gold
        "DAA520",#Goldenrod
        "FFA500",#Orange
        "32CD32",#LimeGreen
        "0000FF",#Blue
        "FF8C00",#DarkOrange
        "A0522D",#Sienna
        "FF6347",#Tomato
        "0000CD",#Medium Blue
        "FF4500",#OrangeRed
        "DC143C",#Crimson       
        "9932CC",#Dark Orchid
        "800000",#marron
        "800080",#Purple
        "4B0082",#Indigo
        "FFFFFF",#white 
        "000000", #Black        
                #heatmap
        "bdff00", #     (189,255,0)
        "e3f018", #     (227,240,24)
        "ffce00", #     (255,206,0)
        "ff6612", #     (255,102,18)
        "c12424", #     (193,36,36)
 
 
                );
 
        my $color=      ($num< scalar (@colors))? $colors[$num]: "FFFFFF";
        return $color;
 
}
 
 
 
 
 
sub check_verilog_identifier_syntax {
        my $in=shift;
        my $error=0;
        my $message='';
#check if $in is defined
        if(!defined $in){
                return "Identifier is not defined! An Identifier must begin with an alphabetic character.\n";
        }
 
        if(length $in ==0){
                return "Identifier length is zero! An Identifier must begin with an alphabetic character.\n";
        }
 
# an Identifiers must begin with an alphabetic character or the underscore character
        if ($in =~ /^[0-9\$]/){
                return "An Identifier must begin with an alphabetic character or the underscore character.\n";
        }
 
 
#       Identifiers may contain alphabetic characters, numeric characters, the underscore, and the dollar sign (a-z A-Z 0-9 _ $ )
        if ($in =~ /[^a-zA-Z0-9_\$]+/){
                 #print "use of illegal character after\n" ;
                 my @w= split /([^a-zA-Z0-9_\$]+)/, $in;
                 return "Contain illegal character of \"$w[1]\" after $w[0]. Identifiers may contain alphabetic characters, numeric characters, the underscore, and the dollar sign (a-z A-Z 0-9 _ \$ )\n";
 
        }
 
 
# check Verilog reserved words
        my @keys =                      ("always","and","assign","automatic","begin","buf","bufif0","bufif1","case","casex","casez","cell","cmos","config","deassign","default","defparam","design","disable","edge","else","end","endcase","endconfig","endfunction","endgenerate","endmodule","endprimitive","endspecify","endtable","endtask","event","for","force","forever","fork","function","generate","genvar","highz0","highz1","if","ifnone","incdir","include","initial","inout","input","instance","integer","join","large","liblist","library","localparam","macromodule","medium","module","nand","negedge","nmos","nor","noshowcancelled","not","notif0","notif1","or","output","parameter","pmos","posedge","primitive","pull0","pull1","pulldown","pullup","pulsestyle_onevent","pulsestyle_ondetect","remos","real","realtime","reg","release","repeat","rnmos","rpmos","rtran","rtranif0","rtranif1","scalared","showcancelled","signed","small","specify","specparam","strong0","strong1","supply0","supply1","table","task","time","tran","tranif0","tranif1","tri","tri0","tri1","triand","trior","trireg","unsigned","use","vectored","wait","wand","weak0","weak1","while","wire","wor","xnor","xor");
        if( grep (/^$in$/,@keys)){
                return  "$in is a Verlig reserved word.\n";
        }
        return undef;
 
}
 
 
sub capture_number_after {
        my ($after,$text)=@_;
        my @q =split  (/$after/,$text);
        #my $d=$q[1];
        my @d = split (/[^0-9. ]/,$q[1]);
        return $d[0];
 
}
 
sub capture_string_between {
        my ($start,$text,$end)=@_;
        my @q =split  (/$start/,$text);
        my @d = split (/$end/,$q[1]);
        return $d[0];
}
 
sub capture_cores_data {
        my ($data,$text)=@_;
        my %result;
        my @q =split  (/End_point/,$text);
        my $i=0;
        foreach my $p (@q){
                if ($i!=0){
                        my @d = split (/[^0-9. ]/,$p);
                        my $n=  $d[0];
                        my $val = capture_number_after("$data",$p);
                        $result{remove_all_white_spaces($n)}=remove_all_white_spaces($val);
                }
                $i++;
        }
        return %result;
}
 
sub make_undef_as_string {
        foreach my $p  (@_){
                $$p= 'undef' if (! defined $$p);
 
        }
}
 
sub powi{ # x^y
        my ($x,$y)=@_; # compute x to the y
        my $r=1;
        for (my $i = 0; $i < $y; ++$i ) {
        $r *= $x;
        }
  return $r;
}
 
sub sum_powi{ # x^(y-1) + x^(y-2) + ...+ 1;
        my ($x,$y)=@_; # compute x to the y
        my $r = 0;
    for (my $i = 0; $i < $y; $i++){
        $r += powi( $x, $i );
    }
        return $r;
}
 
 
 
 
 
#############
# object
############
 
sub object_add_attribute{
        my ($self,$attribute1,$attribute2,$value)=@_;
        if(!defined $attribute2){$self->{$attribute1}=$value;}
        else {$self->{$attribute1}{$attribute2}=$value;}
 
}
 
 
 
sub object_get_attribute{
        my ($self,$attribute1,$attribute2)=@_;
        if(!defined $attribute2) {return $self->{$attribute1};}
        return $self->{$attribute1}{$attribute2};
}
 
 
sub object_add_attribute_order{
        my ($self,$attribute,@param)=@_;
        my $r = $self->{'parameters_order'}{$attribute};
        my @a;
        @a = @{$r} if(defined $r);
        push (@a,@param);
        @a=uniq(@a);
        $self->{'parameters_order'}{$attribute} =\@a;
}
 
sub object_remove_attribute_order{
        my ($self,$attribute,$param)=@_;
        my @r=@{$self->{parameters_order}{$attribute}};
        my @n;
        foreach my $p(@r){
                if( $p ne $param) {push(@n,$p)};
 
        }
        $self->{parameters_order}{$attribute}=\@n;
 
}
 
sub object_get_attribute_order{
        my ($self,$attribute)=@_;
        return unless(defined $self->{parameters_order}{$attribute});
        my @order=@{$self->{parameters_order}{$attribute}};
        return uniq(@order)
}
 
sub object_remove_attribute{
        my ($self,$attribute1,$attribute2)=@_;
        if(!defined $attribute2){
                delete $self->{$attribute1} if ( exists( $self->{$attribute1}));
        }
        else {
                delete $self->{$attribute1}{$attribute2} if ( exists( $self->{$attribute1}{$attribute2})); ;
        }
}
 
 
#############
#  graphviz
#############
 
 
sub generate_and_show_graph_using_graphviz {
        my ($self,$scrolled_win,$dotfile, $graph_name)=@_;
 
 
        #empty the scrolled win 
        if(defined $scrolled_win){
                my @list = $scrolled_win->get_children();
                foreach my $l (@list){
                        $scrolled_win->remove($l);
                }
        }
 
        my $scale=$self->object_get_attribute($graph_name,"scale");
        $scale= 1 if (!defined $scale);
        my $diagram;
 
        my $cmd = "echo \'$dotfile\' | dot -Tpng -q";
        my ($stdout,$exit,$stderr)= run_cmd_in_back_ground_get_stdout ($cmd);
        if ( length( $stderr || '' ) !=0)  {
                message_dialog("$stderr\nHave you installed graphviz? If not run \n \t \"sudo apt-get install graphviz\" \n in terminal",'error');
        }
        $diagram =open_inline_image( $stdout,70*$scale,70*$scale,'percent');
        if(defined $scrolled_win){
                add_widget_to_scrolled_win($diagram,$scrolled_win);
                $scrolled_win->show_all();
        }
    my $save=$self->object_get_attribute("graph_save","enable");
        $save=0 if(!defined $save);
        if($save==1){
                my $file = $self->object_get_attribute("graph_save","name");
                my $ext  = $self->object_get_attribute("graph_save","extension");
                my $pixbuff= $diagram->get_pixbuf;
            $pixbuff->save ("$file.$ext", "$ext");
            $self->object_add_attribute("graph_save","enable",'0');
        }
 
 
}
 
 
###########
#       run_multiple_proc_in_background (@cmds) 
#       run parallel application in background and return err, stdout
#       return for $ith application i start from 0
#               $pipes{$i}{"out"}= stdout;
#               $pipes{$i}{"err"}= stderr;     
###########
 
sub run_multiple_proc_in_background
{
        my @cmds = @_;
        my %pipes;
    my $i=0;
        #open seprate pipe for each command
        foreach my $cmd (@cmds){
                #print "$cmd\n";
                my ($pipe,$in, $out, $err,$r);
                $pipes{$i}{"out"}=\$out;
                $pipes{$i}{"err"}=\$err;
        $pipes{$i}{"pipe"}=\$pipe;
                my @cat = split ('\s+', $cmd );
                my $cmd_name=$cat[0];
                #perevent pipe from crock               
                if (!(-e $cmd_name)) {
                        $err= "file not found: $cmd_name";
                }elsif (!(-f $cmd_name)) {
                $err= "not a file: $cmd_name";
                }elsif (!(-x $cmd_name)) {
                        $err= "permission denied: $cmd_name";
                }
                if (defined  $err){
                        $i++;
                        next;
                }
 
                $pipe =start \@cat, \$in, \$out, \$err or $r=$?;
                if(defined $r){
                        #add_colored_info($tview," quartus_stp got an Error: $r\n",'red');
                        $err= "Pipe got an Error: $r\n";
                        $i++;
                        next;
                }
        $i++;
        }
 
        my $pumpble=0;
        my $cnt=0;
        do{
                $pumpble=0;
                for (my $i=0; $i< scalar @cmds; $i++){
                        my $pipe= ${$pipes{$i}{"pipe"}};
                        next if(!defined $pipe);
                        if (pumpable ($pipe)) {
                                pump $pipe;
                            $pumpble=1;
                            print "pump $i\n";
                        }
                }
                #if($cnt==100) {
                #               $cnt=0;                 
                                refresh_gui();
                #}
                #$cnt++
        }while($pumpble);
 
 
        for (my $i=0; $i< scalar @cmds; $i++){
                my $pipe= ${$pipes{$i}{"pipe"}};
                next if(!defined $pipe);
                finish $pipe;
        }
        return %pipes;
}
 
 
sub add_param_widget {
         my ($self,$name,$param, $default,$type,$content,$info, $table,$row,$column,$show,$attribut1,$ref_delay,$new_status,$loc)=@_;
         my $label;
         $label =gen_label_in_left(" $name") if(defined $name);
         my $widget;
         my $value=$self->object_get_attribute($attribut1,$param);
         if(! defined $value) {
                        $self->object_add_attribute($attribut1,$param,$default);
                        $self->object_add_attribute_order($attribut1,$param);
                        $value=$default;
         }
         if(! defined $new_status){
                $new_status='ref';
         }
         if (! defined $loc){
                 $loc = "vertical";
         }
         if ($type eq "Entry"){
                $widget=gen_entry($value);
                $widget-> signal_connect("changed" => sub{
                        my $new_param_value=$widget->get_text();
                        $self->object_add_attribute($attribut1,$param,$new_param_value);
                        set_gui_status($self,$new_status,$ref_delay) if(defined $ref_delay);
                });
         }
         elsif ($type eq "Combo-box"){
                 my @combo_list=split(/\s*,\s*/,$content);
                 my $pos=get_pos($value, @combo_list) if(defined $value);
                 if(!defined $pos){
                        $self->object_add_attribute($attribut1,$param,$default);
                        $pos=get_item_pos($default, @combo_list) if (defined $default);
 
                 }
                #print " my $pos=get_item_pos($value, @combo_list);\n";
                 $widget=gen_combo(\@combo_list, $pos);
                 $widget-> signal_connect("changed" => sub{
                 my $new_param_value=$widget->get_active_text();
                 $self->object_add_attribute($attribut1,$param,$new_param_value);
                 set_gui_status($self,$new_status,$ref_delay) if(defined $ref_delay);
                 });
 
         }
         elsif ($type eq "EntryCombo"){
                 my @combo_list;
                 @combo_list=split(/\s*,\s*/,$content) if(defined $content);
                 my $pos=get_pos($value, @combo_list) if(defined $value && defined $content);
                 $widget= gen_combo_entry (\@combo_list,$pos);
                 my $child = combo_entry_get_chiled($widget);
                 $child->signal_connect('changed' => sub {
                                my ($entry) = @_;
                                my $new_param_value=$entry->get_text();
                                $self->object_add_attribute($attribut1,$param,$new_param_value);
                                set_gui_status($self,$new_status,$ref_delay) if(defined $ref_delay);
                 });
         }
 
         elsif  ($type eq "Spin-button"){
                my ($min,$max,$step,$digit)=split(/\s*,\s*/,$content);
 
                $value=~ s/[^0-9.\-]//g;
                $min=~   s/[^0-9.\-]//g;
                $max=~   s/[^0-9.\-]//g;
                $step=~  s/[^0-9.\-]//g;
                $digit=~ s/[^0-9.\-]//g if (defined $digit);
                  #$max = $min if($max<$min);
                  $widget=gen_spin($min,$max,$step,$digit);
                  $widget->set_value($value);
                  $widget-> signal_connect("value_changed" => sub{
                  my $new_param_value=$widget->get_value();
                  $self->object_add_attribute($attribut1,$param,$new_param_value);
                  set_gui_status($self,$new_status,$ref_delay) if(defined $ref_delay);
              });
 
                 # $box=def_label_spin_help_box ($param,$info, $value,$min,$max,$step, 2);
         }
 
        elsif ( $type eq "Check-box"){
                $widget = def_hbox(FALSE,0);
                my @check;
                for (my $i=0;$i<$content;$i++){
                        $check[$i]= gen_checkbutton();
                }
                for (my $i=0;$i<$content;$i++){
                        $widget->pack_end(  $check[$i], FALSE, FALSE, 0);
 
                        my @chars = split("",$value);
                        #check if saved value match the size of check box
                        if($chars[0] ne $content ) {
                                $self->object_add_attribute($attribut1,$param,$default);
                                $value=$default;
                                @chars = split("",$value);
                        }
                        #set initial value
 
                        #print "\@chars=@chars\n";
                        for (my $i=0;$i<$content;$i++){
                                my $loc= (scalar @chars) -($i+1);
                                        if( $chars[$loc] eq '1') {$check[$i]->set_active(TRUE);}
                                        else {$check[$i]->set_active(FALSE);}
                        }
 
 
                        #get new value
                        $check[$i]-> signal_connect("toggled" => sub{
                                my $new_val="$content\'b";
 
                                for (my $i=$content-1; $i >= 0; $i--){
                                        if($check[$i]->get_active()) {$new_val="${new_val}1" ;}
                                        else {$new_val="${new_val}0" ;}
                                }
                                $self->object_add_attribute($attribut1,$param,$new_val);
                                #print "\$new_val=$new_val\n";
                                set_gui_status($self,$new_status,$ref_delay) if(defined $ref_delay);
                        });
                }
 
        }
        elsif ( $type eq "DIR_path"){
                        $widget =get_dir_in_object ($self,$attribut1,$param,$value,'ref',10,$default);
                        set_gui_status($self,$new_status,$ref_delay) if(defined $ref_delay);
        }
        elsif ( $type eq "FILE_path"){ # use $content as extention
                        $widget =get_file_name_object ($self,$attribut1,$param,$content,undef,$new_status,$ref_delay);
 
        }
        elsif ( $type eq 'Fixed'){
                 $self->object_add_attribute($attribut1,$param,$default);
                 $widget =gen_label_in_left("$default");
        }
        else {
                 $widget =gen_label_in_left("unsuported widget type!");
        }
 
        my $inf_bt= (defined $info)? gen_button_message ($info,"icons/help.png"):gen_label_in_left(" ");
        if($show==1){
                attach_widget_to_table ($table,$row,$label,$inf_bt,$widget,$column);
                if ($loc eq "vertical"){
                        #print "$loc\n";
                         $row ++;}
                else {
 
                        $column+=4;
                }
        }
    return ($row,$column,$widget);
}
 
 
#get the list of files matching the given extention
sub get_file_list_by_extention {
        my ($open_in, $ext)=@_;
        my @files = glob "$open_in/*";
        my $file_list="";
        foreach my $file (@files){
                my ($name,$path,$suffix) = fileparse("$file",qr"\..[^.]*$");
                if($suffix eq $ext || $suffix eq ".$ext" ){
                        $file_list.=",$name";
                }
        }
        return  ($file_list,\@files);
}
 
 
 
 
sub set_gui_setting{
        my $paths=shift;
        my %p=%{$paths};
        $glob_setting{'FONT_SIZE'}= $p{'GUI_SETTING'}{'FONT_SIZE'} if (defined $p{'GUI_SETTING'}{'FONT_SIZE'});
        $glob_setting{'ICON_SIZE'}= $p{'GUI_SETTING'}{'ICON_SIZE'} if (defined $p{'GUI_SETTING'}{'ICON_SIZE'});
        $glob_setting{'DSPLY_X'}  = $p{'GUI_SETTING'}{'DSPLY_X'}   if (defined $p{'GUI_SETTING'}{'DSPLY_X'});
        $glob_setting{'DSPLY_Y'}  = $p{'GUI_SETTING'}{'DSPLY_Y'}   if (defined $p{'GUI_SETTING'}{'DSPLY_Y'});
}
 
my ($screen_x,$screen_y);
 
sub get_default_screen_size{
        return  ($screen_x,$screen_y) if (defined $screen_x && defined $screen_y);
 
        my $fh= 'xrandr --current | awk \'$2~/\*/{print $1}\'' ;
        my ($stdout, $stderr, $success) = qxx( ($fh) );
        my @a = split ("\n",$stdout);
        ($screen_x,$screen_y) = split ("x",$a[0]);
        $screen_x = 600 if(!defined $screen_x);
        $screen_y = 800 if(!defined $screen_y);
        return  ($screen_x,$screen_y);
}
 
 
sub get_current_monitor_working_area{
    my $screen = get_default_screen();
        my $hight = $screen->get_height();
        my $active = $screen->get_active_window();
        my $monitor =   $screen->get_monitor_at_window($active);
        my $warea = $screen->get_monitor_workarea($monitor);#get_width(); 
        #print  Data::Dumper->Dump ([$warea],['ttt']);  
        return ($warea->{'width'},$warea->{'height'});
}
 
 
 
 
sub max_win_size {
        my ($x,$y);
        $x= int($glob_setting{'DSPLY_X'}) if ($glob_setting{'DSPLY_X'} ne 'default');
        $y= int($glob_setting{'DSPLY_Y'}) if ($glob_setting{'DSPLY_Y'} ne 'default');
        if (!defined $x || !defined $y){
                my ($X,$Y)=get_current_monitor_working_area();
                $x=$X if (!defined $x);
                $y=$Y if (!defined $y);
        }
 
        return ($x,$y);
 
 
}
 
 
1
Browse

Tools

Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc

[/] [an-fpga-implementation-of-low-latency-noc-based-mpsoc/] [trunk/] [mpsoc/] [perl_gui/] [lib/] [perl/] [common.pl] - Blame information for rev 54

Line No.	Rev	Author	Line
1	54	alirezamon	`#!/usr/bin/perl -w`
2
3	43	alirezamon	`use strict;`
4			`use warnings;`
5
6			`use String::Similarity;`
7	48	alirezamon	`use Proc::Background;`
8			`use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep clock_gettime clock_getres clock_nanosleep clock stat );`
9	43	alirezamon
10	48	alirezamon	`use List::MoreUtils qw(uniq);`
11			`use POSIX qw(ceil floor);`
12
13			`use Cwd 'abs_path';`
14			`use Term::ANSIColor qw(:constants);`
15			`use IPC::Run qw(start pump finish timeout pumpable);`
16	43	alirezamon
17	54	alirezamon	`use FindBin;`
18			`use lib $FindBin::Bin;`
19			`use constant::boolean;`
20			`use IO::CaptureOutput qw(capture qxx qxy);`
21	48	alirezamon
22	54	alirezamon
23			`our %glob_setting;`
24			`$glob_setting{'FONT_SIZE'}='default';`
25			`$glob_setting{'ICON_SIZE'}='default';`
26			`$glob_setting{'DSPLY_X'} ='default';`
27			`$glob_setting{'DSPLY_Y'} ='default';`
28
29
30
31
32	48	alirezamon	`sub log2{`
33			`my $num=shift;`
34			`my $log=($num <=1) ? 1: 0;`
35			`while( (1<< $log) < $num) {`
36			`$log++;`
37			`}`
38			`return $log;`
39			`}`
40