view src/gearsTools/lib/Gears/Util.pm @ 280:21a5761e3e7a

mv_extraction_dg_compile_sources Context2Util
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Tue, 28 Jan 2020 15:20:34 +0900
parents 84ab6c197dd8
children 4d76280758db
line wrap: on
line source

package Gears::Util;
use strict;
use warnings;
use Carp qw/croak/;
use File::Find;

sub parse {
  my ($class, $file_name) = @_;
  my $ir = _parse_base($file_name);
  return $ir;
}


sub parse_interface {
  my ($class, $file_name) = @_;
  my $ir = _parse_base($file_name);
  
  unless ($ir->{name}) {
    croak 'invalid struct name';
  }
  return $ir;
}


sub _parse_base {
  my ($file,$code_verbose) = @_;
  my $ir  = {};
  $ir->{file_name} = $file;

  Gears::Util->file_checking($file);
  open my $fh, '<', $file;
  my $line = <$fh>;

  if ($line =~ /typedef struct (\w+)\s?<.*>([\s\w{]+)/) {
    die "invalied struct name $1" unless $1;
    $ir->{name} = $1;

    if ($2 =~ m|\s*impl\s*([\w+]+)\s*{|) {
      $ir->{isa} = $1;
    }
  }

  while ($line = <$fh>) {
    if ($line =~ m|\s*/\*|) {
      while ( $line !~ m|\*/|) {
        $line = <$fh>;
        next;
      }
      next;
    }
    next if ($line =~ /^\s+$/);
    next if ($line =~ m[^\s*//]);
    next if ($line =~ m[^\}\s*$ir->{name};]);

    if ($line =~ m|__code (\w+)\(([()\.\*\s\w,_]+)\)|) {
      $line = "enum Code $1;\n";
    }

    push(@{$ir->{content}},$line);
  }

  return $ir;
}

sub parse_with_rewrite {
  my ($class, $file)  = @_;
  my $ir = _parse_base($file);

  my @data_gears;
  my @code_gears;
  map { push (@data_gears, $_) unless ($_ =~ /enum Code/);} @{$ir->{content}};
  map { push (@code_gears, $1) if ($_ =~ /enum Code (\w+);/);} @{$ir->{content}};

  open my $fh , '<', $file;
  my $i = 0;
  while (($i < scalar @code_gears) && (my $line = <$fh>)) {
      my $cg = $code_gears[$i];
      if ($line =~ m|__code $cg\(([()\.\*\s\w,_]+)\)|) {
        $code_gears[$i] = {
          name => $cg,
          args => $1,
        };
        $i++;
      }
  }
  $ir->{codes} = \@code_gears;
  $ir->{data}  = \@data_gears;
  return $ir;
}

sub file_checking {
  my ($class, $file_name) = @_;
  unless (-f $file_name) {
    croak "invalid filepath :$file_name\n";
  }
}

sub slup {
  my ($class,$file) = @_;
  open my $fh, '<', $file;
  local $/;
  my $f = <$fh>;
  return $f;
}

sub find_header {
  my $class = shift;
  my $header_name = shift;

  my $find_path = shift // ".";
  my @header_list = ();

  find(
    {
      wanted => sub {
        if ($_ =~ /\/$header_name\.(h|dg)$/) {
          push(@header_list,$_);
        }
      },
      no_chdir => 1,
    },
    $find_path);
  my @find_headers =  grep { $_ =~ /\/$header_name\.(h|dg)/} @header_list;
  if (@find_headers > 1) {
      @find_headers =  grep { $_ =~ /\/$header_name\.dg/} @find_headers;
  }
  return shift @find_headers;
}

sub find_headers_path {
  my $class = shift;
  my $find_path = shift // ".";

  my @files;
  find( { wanted => sub { push @files, $_ if /\.(?:h|dg)/ }, no_chdir => 1 }, $find_path);

  return \@files;
}

sub h2context_str {
  my ($class, $h2context) = @_;
  my $space = '    ';

  my $context = "${space}//$h2context->{file_name}\n";
  $context .=  "${space}struct $h2context->{name} {\n";
  my $content_space;
  if (exists $h2context->{content}){
    my @chars = split //, $h2context->{content}->[0];
    for my $w (@chars) {
      last if ($w !~ /\s/);
      $content_space .= $w;
    }
  }

  unless (defined $content_space) {
    $content_space = "";
  }

  for my $c (@{$h2context->{content}}) {
    $c =~ s/$content_space//;
    $context .= "${space}${space}$c";
  }
  $context .= "${space}} $h2context->{name};\n";
  return $context;
}

sub extraction_dg_compile_sources {
  my ($class, $compile_sources) = @_;
  my %counter;
  my %include_pool = ();
  for my $cbc_file (@{$compile_sources}) {
    open my $fh , '<', $cbc_file;
    while (my $line = <$fh>) {
        if ($line =~ m|//\s*:skip|) {
         next;
        }

       if ($line =~ /#interface\s*"(.*)\.h"/) {
          push(@{$counter{interfaces}->{$1}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /^\/\/\s*data_gear\s*"(.*)\.(?:h|dg)?"/) {
          push(@{$include_pool{$1}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ m|//\s*Skip:\s*generate_context|) {
         $line = <$fh>;
         next;
       }


       #if ($line =~ /^(\w+)(\*)+  *create(\w+)\(([^]]*)\)/) {
       #   my $interface = $1;
       #   my $implementation = $3;
       #   $self->{data_gears_with_count}->{$interface}->{caller}->{$cbc_file}++;
       #   $self->{data_gears_with_count}->{$implementation}->{caller}->{$cbc_file}++;
       #   $counter{interfaces}->{$interface}++;
       #   $counter{impl}->{$implementation}++;
       #   next;
       #}

       if ($line =~ /Gearef\(context,\s*(\w+)\)/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

    #Element* element = &ALLOCATE(cbc_context, Element)->Element;
       if ($line =~ /ALLOCATE\w*\((?:cbc_)?context,\s*(\w+)\)/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /ALLOCATE_(?:PTR_)?ARRAY\((?:cbc_)?context,\s*(\w+),[\s\w]+\)/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /new\s+(\w+?)\([\w\s]*\);/) {
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /ALLOCATE_DATA_GEAR\((\w+),\s*(\w+)\)/) {
          my $implementation = $2;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          next;
       }

       #TaskManagerImpl* taskManager = (TaskManagerImpl*)GearImpl(context, TaskManager, taskManager);
       if ($line =~ /\((\w+)\*\)GearImpl\(context,\s*(\w+),\s*(\w+)\)/) {
          my $interface = $2;
          my $implementation = $1;
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.);
          next;
       }

       if ($line =~ /^__code/) {
         while ($line =~ /struct (\w+)\s*\*/g) {
           next if $1 eq "Context";
           next if (exists $counter{interfaces}->{$1});
           push(@{$counter{impl}->{$1}->{$cbc_file}},$.);
         }
       }
    }
    close $fh;
  }
  use Data::Dumper;

  for my $cg_name (keys %include_pool) {
    my @tmp_cbc_file_names  = keys %{$include_pool{$cg_name}};
    my $tmp_cbc_file_name  = shift @tmp_cbc_file_names;
    if (exists $counter{interfaces}->{$cg_name}){
      push(@{$counter{interfaces}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name});
      delete $include_pool{$cg_name};
      next;
    }

    if (exists $counter{impl}->{$cg_name}){
      push(@{$counter{impl}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name});
      delete $include_pool{$cg_name};
      next;
    }
    push(@{$counter{interfaces}->{$cg_name}->{$tmp_cbc_file_name}},$include_pool{$cg_name}->{$tmp_cbc_file_name});
    delete $include_pool{$cg_name};
  }

  $counter{interfaces}->{Meta}++;
  $counter{interfaces}->{TaskManager}++;
  print "-----------\n";
  print Dumper \%counter;
  print "-----------\n";
  return \%counter;
}



1;