view src/gearsTools/lib/Gears/Util.pm @ 360:3d7e1c9a852e

...
author anatofuz
date Fri, 26 Jun 2020 15:30:42 +0900
parents 599ad98aee00
children 874577d7505f
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 $file_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>;
  my $static_data_gear_write_mode = 0;

  my $directory_containing_file = "";

  if ($file  =~ m<([\.\w/]+)/\w+\.(?:cbc|h|c)>) {
     $directory_containing_file = $1;
  }


  while ($line =~ /#include\s+"([\w\/\.]+)"/) {
    my $header_file = $1;
    if ($header_file =~ m|\./context\.h|) {
      next;
     }
    push(@{$ir->{cbc_context_include_headers}}, "$directory_containing_file/$header_file");
    $line = <$fh>;
  }

  # skip space

  while ($line =~ /^\s*$/) {
    $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;
    }
  }

  unless ($ir->{name}) {
    return undef;
  }

  my @tmp_args;
  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+)|) {
      push(@tmp_args,"enum Code $1;\n");
      next if $static_data_gear_write_mode;
      my $args = $';
      #$args eq  (Impl* vm, pde_t* pgdir, char* init, uint sz, __code next(...));
      while ($args =~ /\s*(struct|union|const|enum)?\s*([\w*\[\]_]+)\s*(\w+),?/g) {
        my $const_type = $1;
        my $type = $2;
        my $vname = $3;
        next if ($type eq '__code');
        $type =~ s/^(?:Impl|Type|Isa)\s*(\*)?/union Data$1/;
        my $val = "$type $vname;\n";
        push(@tmp_args, $const_type ?  "$const_type $val" : $val);
      }
      next;
    }

    $line =~ s/^\s+//;
    push(@tmp_args,$line);
    $static_data_gear_write_mode = 1;
  }

  push(@{$ir->{content}}, _uniq(@tmp_args));
  return $ir;
}

sub _uniq {
  my %seen;
  return grep { !$seen{$_}++ } @_;
}

sub parse_with_separate_code_data_gears{
  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_using_interface_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 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*include\s*"(.*)\.(?:h|dg)?"/) {
          push(@{$include_pool{$1}->{$cbc_file}},$.);
          next;
       }

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


       if ($line =~ /^(\w+)\*\s*create(\w+)\(([*\w\s]+)\)/) {
          my $interface = $1;
          my $implementation = $2;
          my $arg = $3;
          if ($arg eq "") {
            next;
          }
          push(@{$counter{interfaces}->{$interface}->{$cbc_file}},$.);
          push(@{$counter{impl}->{$implementation}->{$cbc_file}},$.);
          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;
}

sub docking_header_name_to_path {
  my ($class, $search_bash_path, $targets) = @_;
  my %res;
  map { $res{$_}++ } @$targets;

  my $header_paths = Gears::Util->find_headers_path($search_bash_path);
  map {
    if (/(\w+)\.(?:h|dg)$/) {
        my $header_file = $1;
        if (exists $res{$header_file}) {
          if ($res{$header_file} =~ /^\d+$/){
            $res{$header_file} = $_;
          } elsif (($_ =~ /\.dg$/) && ($res{$header_file} =~ /\.h$/)) {
            $res{$header_file} = $_;
          }
        }
    }
  } sort @$header_paths;
  return \%res;
}

1;