view src/gearsTools/lib/Gears/Context.pm @ 395:17e8a4bc06a7 default tip

add macOS AR/RANLIB
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Mon, 14 Dec 2020 21:59:50 +0900
parents 599ad98aee00
children
line wrap: on
line source

package Gears::Context;

use strict;
use warnings;

use Gears::Util;

use Module::Load qw/load/;

use Carp qw/croak carp/;

sub new {
  my ($class, %args) = @_;
  my $self = {
    data_gears_with_count => {},
    find_root => $args{find_root} // ".",
    output    => $args{output},
    template  => $args{template}  // "Gears::Context::Template",
  };

  if ($args{compile_sources}) {
    $self->{compile_sources} = $args{compile_sources};
    map { Gears::Util->file_checking($_); } @{$self->{compile_sources}};
  }

  return bless $self, $class;
}


sub extraction_dg_compile_sources {
  my ($self, $compile_sources) = @_;
  return Gears::Util->extraction_dg_compile_sources($compile_sources);
}

sub set_data_gear_header_path {
  my $self = shift;
  my @data_gears_name;
  map { push (@data_gears_name,$_) if $_ ne "Context" } @_;
  return Gears::Util->docking_header_name_to_path($self->{find_root},\@data_gears_name);
}

sub update_dg_each_header_path {
  my ($self, $dgs, $dg2path) = @_;
  my $new_dgs;
  for my $kind (keys %$dgs) {
    for my $dg_name (keys %{$dgs->{$kind}}) {
      if ($dg2path->{$dg_name}) {
        $new_dgs->{$kind}->{$dg_name} = $dg2path->{$dg_name};
      } else {
        croak "failed trans header $dg_name\n";
      }
    }
  }

  for my $kind (keys %$dgs) {
    map {
      if ($new_dgs->{$kind}->{$_} =~ /^\d+$/) {
        carp "failed: not found $_.(h|dg)\n";
        delete $new_dgs->{$kind}->{$_};
      }
    } keys %{$new_dgs->{$kind}};
  }
  return $new_dgs;
}

sub tree2create_context_h {
  my ($self, $dg2path) = @_;


  unless ($dg2path) {
    croak "require ast at tree2create_context_h";
  }

  my $template = $self->{template};
  load $template;

  my ($data_struct_str, $from_header_to_caller) = $self->tree2data_struct_str($dg2path);

  my $output = $self->_select_output();
  $template->emit_top_header($output);
  if (%{$from_header_to_caller}) {
    $template->emit_include_header($output,$from_header_to_caller);
  }
  $template->emit_start_context($output);
  $template->emit_data_gears($output,$data_struct_str);
  $template->emit_last_header($output);
  close $output;
}

sub _select_output {
  my $self = shift;
  print "$self->{output}\n";
  if ($self->{output} eq  'stdout') {
    return *STDOUT;
  }
  open my $fh, '>', $self->{output};
  return $fh;
}


# Generate a header with include file list from a structure's tree structure
sub tree2data_struct_str {
  my ($self, $dg_str) = @_;
  my %from_header_to_caller;

  my $data_struct_str  = "";
  for my $interface (sort keys %$dg_str) {
    my $elem = $dg_str->{$interface}->{elem};
    $data_struct_str .= $self->h2context_str_w_macro($elem);

    for my $header (_find_include_header_each_cbc($elem)) {
      push(@{$from_header_to_caller{$header}},$elem->{file_name});
    }

    my $root_impl = $dg_str->{$interface}->{impl};

    next unless ($root_impl);
    for my $impl_name (sort keys %{$root_impl}) {
      my $impl = $root_impl->{$impl_name};
      $data_struct_str .= $self->h2context_str_w_macro($impl);
      for my $header (_find_include_header_each_cbc($impl)) {
        push(@{$from_header_to_caller{$header}},$impl->{file_name});
      }
    }
  }
  return $data_struct_str, \%from_header_to_caller;
}

sub _find_include_header_each_cbc {
  my $ir = shift;
  unless (exists $ir->{cbc_context_include_headers}) {
   return ();
  }
   return @{$ir->{cbc_context_include_headers}};
}

sub createImplTree_from_header {
  my ($self, $dg2path) = @_;
  my %dg_str = ();

  my $inters = $dg2path->{interfaces};
  my $impls = $dg2path->{impl};

  use Data::Dumper;
  # print Dumper $dg2path;
  # print Dumper  $self;

  map {  my $ir = Gears::Util->parse_interface($inters->{$_});   $dg_str{$_}->{elem} = $ir if $ir} keys %$inters;

  map {
    my $res = Gears::Util->parse($impls->{$_});
    if ($res) {
      if ($res->{isa}) {
          $dg_str{$res->{isa}}->{impl}->{$_} = $res;
      } else {
          $dg_str{$_}->{elem} = $res;
      }
    }
  } keys %$impls;

  return \%dg_str;
}

sub h2context_str_w_macro {
  my ($self, $h2context) = @_;
  my $space = '    ';
  my $context = "${space}//$h2context->{file_name}\n";
  $context .= "#ifndef ". uc($h2context->{name}) ."_STRUCT \n";
  $context .= $self->h2context_str($h2context);
  $context .= "#define ". uc($h2context->{name}) ."_STRUCT \n";
  $context .= "#else\n";
  $context .=  "${space}struct $h2context->{name};\n";
  $context .= "#endif\n";
  return $context;
}

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

  my $context =  "${space}struct $h2context->{name} {\n";
  my $content_space;

  my @enumCodes;
  my @var;

  for my $c (@{$h2context->{content}}) {
    if ($c =~ /\A\s*enum Code/) {
      push(@enumCodes,$c);
    } else  {
      push(@var,$c);
    }
  }

  if (@var){
    my @chars = split //, $var[0];
    for my $w (@chars) {
      last if ($w !~ /\s/);
      $content_space .= $w;
    }
  }

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

  for my $c (@var) {
    $c =~ s/$content_space//;
    $context .= "${space}${space}$c";
  }

  for my $c (@enumCodes) {
    $c =~ s/$content_space//;
    $context .= "${space}${space}$c";
  }

  $context .= "${space}} $h2context->{name};\n";
  return $context;
}

1;