view src/gearsTools/update_header.pl @ 255:07c731e47330

add update_header.pl (uncomplete...)
author anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp>
date Tue, 04 Feb 2020 16:51:27 +0900
parents
children
line wrap: on
line source

#!/usr/bibn/env perl
use strict;
use warnings;

use Carp qw/croak/;
use DDP {deparse => 1};

my $header_file = shift // croak 'require header file!';
my ($header_con,$interface_name) = search_slurp_header_file($header_file);

my %cbc_code_names = ( order => 0, codes => {});

while (@ARGV) {
  face_or_impl = find_codes_from_cbc(shift @ARGV, $interface_name, \%cbc_code_names);
}

map  { push(@{$cbc_code_names{order_list}}, [$_,$cbc_code_names{codes}->{$_}->{order}])}  
        sort { $cbc_code_names{codes}->{$a}->{order} <=> $cbc_code_names{codes}->{$b}->{order} } keys %{$cbc_code_names{codes}};

p $header_con;
p %cbc_code_names;

sub search_slurp_header_file {
  my $header_file = shift;
  
  my %contents;
  my %order;
  my $i = 0;
  my $interface_name;

  open my $fh, '<', $header_file;

  if (<$fh> =~ /struct (\w+)\s*</) {
    $interface_name = $1;
  }
  while (my $line = <$fh>) {
    chomp $line;
    if ($line =~ /\A\s*__code (\w+)\(/) {
      $contents{$1} = $line;
      $order{$1} = $i;
      $i++;
    }
  }
  close $fh;
  my @order_code_names;
  map  { push(@order_code_names, [$_,$order{$_}])}  sort { $order{$a} <=> $order{$b} } keys %order;
  return { codes => \%contents, order => \@order_code_names }, $interface_name;
}

sub find_codes_from_cbc {
  my ($cbc_file, $inter_name, $ccn) = @_;

  #my $inter_name = $header_type->{interface} // undef;
  #my $impl_name  = $header_type->{impl} // undef;


  open my $fh, '<', $cbc_file;
  while (my $line = <$fh>) {
    chomp $line;
    if ($line =~ /\A\s*__code (\w+)\(/) {
      my $cg_name = $1;
      $line =~ s/\s+{\s*/;/;
      $line =~ s/struct $inter_name/Type/g;
      $ccn->{codes}->{$cg_name} = { line =>$line, file => $cbc_file, order => $ccn->{order} };
      $ccn->{order}++;
    }
  }
  close $fh;
}

sub create_new_header_codes {
  my ($header_con, $cbc_con) = @_;
  while (@{$header_con->{order}}) {
     my ($header_cg_name, $hader_cg_order) = @{$header_con->{order}->[0]};
  }
}