File Coverage

blib/lib/Fortran/Namelist.pm

Criterion	Covered	Total	%
statement	6	363	1.6
branch	0	100	0.0
condition	0	52	0.0
subroutine	2	23	8.7
pod	0	21	0.0
total	8	559	1.4

package Fortran::Namelist;

our $VERSION = '0.10';

use Carp;
use Scalar::Util qw(looks_like_number);

our @nml_groups=();

sub new {
   my $class = shift;
   my %opt  = @_;
   my $self = {};
   $self->{nml} = {};
   $self->{groups} = [];
   bless $self,$class;
   return $self->init(%opt);
}

sub init {
  my $self = shift;
  my %opt = (
     file => '',
     fh   => '',
     nml  => '',
     @_,
  );
  if ( $opt{nml} && ref $opt{nml} eq 'HASH' ) {
      $self->set( %{$opt{nml}} );
  }
  if ( $opt{file} || $opt{fh} ) {
      $self->load( %opt ) or croak "Error loading namelist\n";
  }
  return $self
}

sub nml {
   my $self      = shift;
   my $grp_name  = shift ||'';
   my $var_name  = shift ||'';
   ( $grp_name ) =  grep { lc $grp_name eq lc $_  } %{$self->{nml}};
   ( $var_name ) =  grep { lc $var_name eq lc $_  } %{$self->{nml}{$grp_name}};
   my $nml = $grp_name &&   $var_name ? $self->{nml}{$grp_name}{$var_name} :
             $grp_name && ! $var_name ? $self->{nml}{$grp_name}            :
                                        $self->{nml};
   return $nml
}
sub set {
   my $self = shift;
   my %opt = (
      @_,
   );
   if ( ! keys %opt  ) {
      return;
   }
   my $new = $self->read_group(%opt);
   my %seen;
   my @grp_names = keys %{$self->{nml}};
   my (%hg,%hv,$grp,$gname);
   @hg{ map { lc } @grp_names }= @grp_names;
   foreach my $g ( keys %{$new} ){
      # create the group if doesn't exist
      if ( ! exists $hg{ lc $g } ) {
        $self->new_group( $g ,$new->{$g});

      }
      else {
        $gname = $hg{ lc $g};
        my $hlines = $self->parse_group($gname);
        my $grp = $self->group($gname);
        my @var_names =  keys %{$self->{nml}{ $gname }};
        @hv{ map { lc } @var_names }= @var_names;
        my $vars = [];
        %seen=();
        foreach my $h (  @$hlines  ) {
           ($vname) = keys %$h;
           my ($v) =  grep { lc $_ eq lc $vname } keys %{$new->{$g}};
           #$self->assign_hvar($gname,$vname,$h);
           #my $vval = $self->{nml}{$gname}{$vname};
           #push @{$vars},@{$self->new_vars($gname,$self->{nml}{$gname} ) };
           if ( $v ) {
             next if $seen{$v}++;
             my $hh = { $vname => {} };
             $hh->{$vname} = $new->{$g}{$v};
             $self->assign_hvar($gname,$vname,$hh );
           }
           #next if $seen{$vname}++;
           my ($idx,$val) = $self->unassign($self->{nml}{$gname}{$vname});
           my $j = 0;
           foreach my $i ( @$idx ) {
             my $line =  $self->write_var("$vname$i",$val->[$j++]);
             push @{$vars},$line;
           }
        }
        foreach my $v ( grep { ! exists $hv{lc $_} } keys %{$new->{$g}} ) {
           my $h = { $v => $new->{$g}{$v} };
           push @$vars, @{$self->new_vars($gname,$h)};
        }
        $grp->{vars}=$vars;
      }
   }
   return
}

sub assign_hvar {
  my $self   = shift;
  my $gname  = shift;
  my $vname  = shift;
  my $h      = shift;
  my ($nidx,$nval) = ([],[]);
  ($nidx,$nval) = $self->unassign($h->{$vname});
  my $j=0;
  $self->{nml}{$gname}{$vname} = {} if ! exists $self->{nml}{$gname}{$vname};
  foreach my $ni ( @$nidx ) {
      $ni =~ s/^\(//;
      $ni =~ s/\)$//;
      my $ii = [split /,/,$ni];
      $self->assign($self->{nml}{$gname}{$vname},$ii,$nval->[$j++]);
   }
   return $self->{nml}{$gname}{$vname}
}


sub read_group {
 my $self = shift;
 my %grp = @_;
 foreach my $v ( keys %grp ) {
    $grp{$v}= $self->fix_val( $grp{$v} );
 }
 return \%grp
}

sub fix_val {
   my $self = shift;
   my $val = shift;
   if ( ref ($val) eq 'HASH' ) {
      foreach my $k ( keys %$val ) {
         $val->{$k} = $self->fix_val( $val->{$k} );
      }
   }
   elsif ( ref $val eq 'ARRAY' ) {
    foreach my $v ( @$val ) {
       $v = trim($v);
       $v =~ s/^'//;
       $v =~ s/'$//;
       if ( ! looks_like_number($v) ) {
          $v = "'$v'" ;
       }
     }
   }
   return $val
}
sub print {
    my $self = shift;
    my %opt = (
       group => '',
       file  => '',
       fh    => \*STDOUT,
       @_,
    );
    my $fh = $opt{fh};
    if ( $opt{file} ) {
       $fh = \*FILE;
       open( $fh ,'>', $opt{file} ) or
         croak "couldn't open file: $opt{file} $!\n"
    }
    my $groups = $self->{groups};
    foreach my $g ( @$groups ) {
       if ( exists $g->{comment} ) {
         print $fh "$g->{comment}\n";
         next;
       }
       next if $opt{group} && lc $opt{group} ne lc $g->{name};
       print $fh "$g->{ch_start}$g->{name}\n\n";
       foreach my $v ( @{$g->{vars}} ) {
           print $fh "$v\n";
       }
       print $fh "\n$g->{ch_end}\n";
    }
}


sub write_var {
  my $self = shift;
  my $lhs  = shift;
  my $rhs = shift;
  my $nl  = shift || 80;
  my @l;
  my $eq  = trim($lhs) ? '=' : ' ' ;
  $l[0]  = "   $lhs $eq ";
  my $line = '';
  my $lpad = ' 'x(length $l[0]);
  my $sep = @$rhs > 1 ? ', ': '' ;
  my @r = @$rhs;
  while ( @r ) {
    my $v = shift @r;
    my $lvs=length( "$l[-1]$sep$v$sep");
    if ( @r ) {
       if ( $lvs < $nl ) {
         $l[-1] .= "$v$sep";
       }
       else {
         $l[-1] .= "\n";
         push @l, "$lpad$v$sep";
       }
    }
    else  {
      if ( $lvs < $nl ) {
        $l[-1].= $v;
      }
      else {
        $l[-1] .= "\n";
        push @l, "$lpad$v";
      }
    }
   }
  $line = join '',@l;
  return $line
}

sub load {
  my $self = shift;
  my %opt = (
    fh        => '',
    file      => '',
    nml       => '',
    @_,
  );

  $self->{nml} = $opt{nml} && ref $opt{nml} eq 'HASH' ?  $opt{nml} :  {};
  my ($gname,$var,$val,$type,$ch_start,$ch_end);
  my $fh = $opt{fh};
  if ( $opt{file} ) {
   open( $fh ,"<",$opt{file} ) or
     croak "Couldn't open $opt{file} for reading $!\n";
  }
  my $lines=[''];
  my $comment='';
  $ch_start='';
  $ch_end='';
  my $l='';
  while ( <$fh> ) {
    $l = $_;
    chomp;
    chomp $l;
    if ( /^(\s*\!.*)$/ ) {
       $comment = $l;
       if ( ! $ch_start ) {
          push @{$self->{groups}},{ comment => $comment };
        }
        else {
          push @{$lines},$comment;
        }
        $comment='';
    }
    s/\!.*$//;
    s/^\s+//;
    s/\s+$//;
    next unless length;
    if ( /(\$|\&)(\w+)(.*)(\$end|\/)/ixmsg  ) {
         $ch_start = $1;
         $gname =  $2;
         $ch_end = $4;
         $lines = [ trim($3) ];
         $self->{nml}{$gname}={};
         push @{$self->{groups}},{ name     => $gname,
                                   ch_start => $ch_start ,
                                   ch_end   => $ch_end,
                                   vars     => $lines,
                                  };
         $lines = [];
         $ch_start='';
         $ch_end='';
         next;
    }

    if ( /(\$end|\/)$/i ) {
      $ch_end = $1;
      push @{$self->{groups}},{ name     => $gname,
                                ch_start => $ch_start ,
                                ch_end   => $ch_end,
                                vars     => $lines,
                              };
      #print join "\n",@lines,"\n";
      #if ( ! $opt{nml} || $group eq $opt{nml} )
      #$self->parse_group( $group, @lines );
      $ch_start='';
      $ch_end='';
      next;
    }
    if ( /^(\$|\&)([A-Za-z]\w+)( |$)/  ) {
      $ch_start = $1;
      $gname = $2;
      $self->{nml}{$gname}={};
      #print "$group $_\n";
      $lines = [];
      #$nml->{$group} = [];
      #$nml->{$group}{comment} = [$comment] if $comment;
      #$comment = '';
      next;
    }
    push @$lines,$l;
  }
  my $ok = $ch_start || $ch_end ? 0 : 1;

  return $ok
}
sub new_group {
  my $self = shift;
  my $name = shift;
  my $h    = shift  ;
  my $g    = { name     => $name,
               ch_start => '$' ,
               ch_end   => '$end',
               vars     => $self->new_vars($name,$h),
              };
  $self->{nml}{$name}= {} if ! exists $self->{nml}{$name};
  foreach my $v ( keys %$h ) {
     $self->{nml}{$name}{$v}={};
     $self->{nml}{$name}{$v}=$self->assign_hvar($name,$v,$h);
  }
  push @{$self->{groups}},$g;
  return $g
}
sub new_vars {
   my $self   = shift;
   my $gname  = shift;
   my $h      = shift;
   my ($idx,$val,$j);
   my $vars = [];
   foreach my $var ( keys %{$h} ) {
    ($idx,$val) = $self->unassign($h->{$var});
    $j=0; #print $var,"\n";
    foreach my $i ( @$idx ) {
      my $line =  $self->write_var("$var$i",$val->[$j++]);
      push @{$vars},$line;
    }
  }
  return $vars
}
sub group {
  my $self = shift;
  my $gname = shift || croak "No group name given!\n";
  my $g = {};
  ($g) = grep { lc $_->{name} eq lc $gname  } @{$self->{groups}};
  if ( ! $g ) {
    carp "Group $gname not found\n";
  }
  return $g
}
sub group_lines {
  my $self = shift;
  my $gname = shift || croak "No group name given!\n";
  my $var   = shift || '';
  my @lines = ('');
  my $g = $self->group($gname);
  foreach my $l ( @{$g->{vars}} ) {
     chomp $l;
     $l=~ s/\!.*$//;
     if ( $l !~ /=/ ) {
        $lines[-1] .= " $l";
        next;
     }
     else {
        push @lines,$l;
     }
  }
  return \@lines
}


sub parse_group {
   my $self = shift;
   my $gname = shift;
   my $vname = shift || '';
   my $group_lines = $self->group_lines($gname);
   my $group = $self->group($gname);
   my $vars = [];
   my $vlines =[];
   my $comment = '';
   foreach my $l (  @$group_lines ) {
      #print "$l\n";
      if ( $l !~ /^\s*\!/ ) {
        my $hl = $self->parse_vars($gname,$l);
        #foreach my $h ( @$hl ) {
        #   my ($vname) = keys %$h;
        #   $self->assign_hvar($gname,$vname,$h);
        #   push @$vars,@{$self->new_vars($gname,$h) };
        #}
        push @$vlines,@$hl;
      }
      else {
        push @$vars,$l;
      }
   }
   $group->{vars} = $vars;
   return $vlines;
}


sub parse_vars {
  my $self = shift;
  my $gname  = shift;
  my $line  = shift;
  my $v=[];
                      # [A-Za-z_0-9\(\),\s\#\-\:]+
                      #    \( [\s0-9\.DdEe\-\+]+ , [\s0-9\.DdEe\-\+]+ \)
  while ( $line =~ / (
                       [A-Za-z_0-9]+
                       (\s*|
                        \( \s*
                           (
                             \s*\d\s*(,|\s*|)
                           )+
                         \s* \)
                       )\s*
                       =
                       (
                         (\s*\d+\s*\*|)
                         (
                                \s*\'.*\'\s*            |
                           [\s\-\+A-Za-z_0-9\.'\:,]+    |
                           \s*\(
                             [\s0-9\.DdEeIi\-\+]+
                             \s*,\s*
                             [\s0-9\.DdEeIi\-\+]+
                           \)\s*
                         )
                         (,|,\s*|$)
                         |
                       )+

                     )+
                  /xmsg ) {
     #print "line  : $line\n";
     ($var,$val) = split /=/,$1;
     #print "parsing  $var = $val\n";
     my $index=[];
     ($var,$index) = $self->var_index($var);
     my @i= @$index;

     #print "index = @$index\n";
     $val = trim($val);
     $val = $self->parse_val($val,$var);
     my $h = { $var => {} };
     if ( ! exists $self->{nml}{$gname}{$var} )  {
       $self->{nml}{$gname}{$var} = {};
     }
     $self->assign($self->{nml}{$gname}{$var},$index,$val);
     $self->assign($h->{$var},$index,$val);
     #$h->{$var} = $self->{nml}{$gname}{$var};
     #print "$var@{$index}=  @{$h->{$var}} \n";
     #print "var $var @{$i} = @{$val}\n";
     push @$v , $h;
  }
  return $v
}
sub unassign {
   my $self = shift;
   my $h = shift;
   my $index  = shift || [''];
   my $idx = shift || [];
   my $vals = shift || [];
   my $v = '';
   my $l = [];
   my @k = ref $h eq 'HASH' ? sort { $a <=> $b } keys %$h : ();
   #print "keys @k\n";
   #print "$index->[-1]\n";
   if ( @k ) {
     my $ii = $index->[-1];
     my $i=$k[0];
     while ( @k ) {
       $i=shift @k;
       push @{$index},$ii ;
       $index->[-1] .= " $i";
       #print "$index->[-1]\n";
       #push @$vals,$h->{$i} if ref $h->{$i} eq 'ARRAY';
       $self->unassign($h->{$i},$index,$idx,$vals);
     }
   }
   else {
     my @ii =  split ' ',$index->[-1];
     my $j = (join ',', @ii) || '';
     $index->[-1] = $j ? "($j)" : '';
     push @$idx,$index->[-1];
     push @$vals,$h;
   }

   return ($idx,$vals)
}

sub assign {
  my $self = shift;
  my $h = shift;
  my $index = shift;
  my $val   = shift;
  if ( @$index ) {
     my $i = shift @$index;
     $h->{$i}= ! @$index       ? $val     :
               exists $h->{$i} ? $h->{$i} :
                                 {}       ;
     $self->assign( $h->{$i},$index,$val );
  }
  elsif ( ref $h eq 'HASH' ) {
    my ($i) = keys %$h;
    $h->{$i}=$val;
  }
  else {
    $h = $val;
  }

  return $h
}

sub var_index {
   my $self = shift;
   my $var = shift;
   $var =~ s/\s+//g;
   my $index = [];
   if ( $var =~ s/(
                   \(.*\)       # match indexes between parenthesis
                  )
                  (|            # nothing or,
                   \(\d*:\d*\)  # substring indexes, but we will not use them
                                # for now
                  )
                 //x ) {
      my $i= $1;
      $i  =~ s/(\(|\))//g;
      $index = [ split /,/,$i ];
      #print "index @{$index}\n";
   }
   #$index =~ s/\s+//g if $index ;
   return (trim($var),$index);
}

sub parse_val {
   my $self = shift;
   my $val = shift;
   my $var = shift ||'';
   my $values = [];
   my $all = $val ;
   my $ok = 1;
   return  [$val]  if $val =~ /\.(true|false)\./i ;
   while ( $val =~ / (\s*,\s*|\s*)               # match starting null value
                     ((\s*\d+\s*)\*|)            # match multiplier
                     (                           # begin matching values
                       \s*\'.*?\'\s*           | #  quoted string
                         [DdEe_0-9\.\-\+\:]+   | #  numeric variable
                      \s*\(                      #  start complex number
                           [\s0-9\.DdEeIi\-\+]+  #    real part
                           \s* , \s*             #    comma
                           [\s0-9\.DdEeIi\-\+]+  #    imaginary part
                         \)\s*                |  #  end complex  number
                         \s*,\s*                 #  separator
                     )                           # end matching values
                     (                           # begin separators:
                       \s*,\s* |                 #   match null value ',,'
                       \s*     |                 #   blanks spaces,tabs,etc
                       $                         #   end of string or new line
                     )                           # end separators
                  /xmsg ) {
      my $nv  = $1;
      my $ntimes = $2;
      my $n = $3 || 1;
      my $c = $4 ;
      my $sep = $5;
      my $pv = $c;
      $nv = trim($nv);
      push @$values,$nv if $nv;

      #$c = ! looks_like_number($c) ? "'$c'" : $c;
      #print "! sep= |$sep| bnv = |$nv| rep = |$n| |$ntimes| ";
      #print "! parsing : $var = |$c|\n";
      $pv =~ s/(\+|\(|\)|\.)/\\$1/g;
      $ntimes =~ s/(\*)/\\$1/g;
      $all =~ s/($nv$ntimes$pv$sep)?//;
      $ok = ! $sep && $c eq ',' ?  0 : 1;
      #push @$values,split(/,/,$c);
      push @$values,(trim($c))x($n) if $ok ;
      #my $vv = [ split /$sep/,$val ];
      #foreach my $c ( @$vv ) {
      #   print "var $var| val $val|c $c \n";
      #}
  }
  if ( trim($all) ) { print "left overs |$all|\n";}
  #print "@$values ",scalar @$values,"\n";
  #return scalar @$values > 1 ? $values : $values->[0];
  return $values
}

sub trim {
  my $s = shift;
  $s =~ s/^\s+//;
  $s =~ s/\s+$//;
  return $s
}
1;

__END__