##	namelist.pm			Erik Kluzek##	Perl module to deal with FORTRAN namelists.##------------------------------------------------------------------------##	Description of methods:##	new ----------------------- Constructor#	change -------------------- Interactively change values in the namelist#	checkstring --------------- Check that a string namelist item is handled correctly.#	print --------------------- Print namelist to screen.#	Write --------------------- Write the namelist out.#	convert_case -------------- Convert the keys to lowercase.#	parse --------------------- Parse a namelist file into a Perl associative array.##	$Id: namelist.pm,v 1.1.6.1 2002/05/13 17:21:27 eaton Exp $#use strict;#use diagnostics;use Cwd;package namelist;# Some data to make global within this package, but local to inside it## Perl expression to match a fortran variable#$namelist::varmatch = "[A-Za-z_]+[A-Za-z0-9_%()]*";    # % for derived types, () for arrays## Perl pattern to match the value for a fortran constant## Match for logical data$namelist::vallogical = "\\.[Tt][Rr][Uu][Ee]\\.|\\.[Ff][Aa][Ll][Ss][Ee]\\.";# Match for integer data$namelist::valint = "[+-]?[0-9]+";# Match for real data# "_" are for f90 precision specification$namelist::valreal = "$namelist::valint\\.?[0-9]*[Ee]?[0-9+-]*_?[0-9a-z_]*";# Match for string data# One problem with below is strings that have \" or \' in them$namelist::valstring = '\'[^\']+\'|"[^"]+"';# Match for complex data$namelist::valcomplex = "\\($namelist::valreal,$namelist::valreal\\)";# Match for all valid data-types: integer, real, complex, logical, or string data$namelist::valmatch = "$namelist::vallogical|$namelist::valstring|$namelist::valreal|$namelist::valint|$namelist::valcomplex";# Same as above when a match isn't required$namelist::nrvalmatch = $namelist::valmatch. "||";## This script takes the %main::CCMEXP associative array and stores the keys in# Lower case to the following lowercase copies. It uses the values passed in# and sets needed default values based on configuration variables. Then it writes out# a namelist according to the corresponding resultant associative array.#sub new {## Constructor: usage: my $nl = namelist->new( "CCMEXP", "nl.initial", %main::CCMEXP );#  my $class = shift;  my $name  = shift;  my $file  = shift;  my $NLref = shift;  my $printlev = shift;  my $self  = {};  if ( ! defined($name) ) {    die "ERROR:: name not given to namelist constructor\n";  }  if ( ! defined($file) ) {    die "ERROR:: filename not given to namelist constructor\n";  }  if ( ! defined($NLref) || $NLref !~ /HASH/ ) {    die "ERROR:: reference to namelist associative array not given to namelist constructor\n";  }  $self->{'FILENAME'} = $file;                    # Filename of output namelist  $self->{'NLREF'}    = $NLref;                   # Reference to namelist  $self->{'NAME'}     = $name;                    # the name of the namelist  $self->{'printlev'} = $printlev;  $self->{'VAR'}      = undef;                    # Variable name when parsing  $self->{'VALUE'}    = undef;                    # Variable value when parsing  bless( $self, $class );  return( $self );}#============================================================================sub change {## Make changes to the namelist#  my $self = shift;  my $ref = $self->{'NLREF'};  my $name = $self->{'NAME'};  print "Here is the $name namelist:\n";  $self->print;  print "Do you want to add or change any settings? (y/n):";  $_ = <>;   if ( /[yY][Ee]*[sS]*/ ) {    print "Enter changes as: key = value (return to finish)\n";    print "(Be sure and put \' around string values)\n";    my $match = "^\\s*($namelist::varmatch)\\s*=\\s*($namelist::valmatch";    $match = $match . ")[\\s,]*(.*?\$)";    while( defined($_ = <> ) && (/./) ) {      if ( /$match/ ) {        $$ref{$1} = $2;      } else {        print "Warning:: bad input: enter as: key = value :: key and value should conform to f90 rules\n";      }    }    print "Ok, here is the new $name namelist:\n";    $self->print;  }}#============================================================================sub checkstring {## Check that a string namelist item is handled correctly#  my $self = shift;  my $item = shift;  my $EXPNLref = $self->{'NLREF'};  my %EXPNL = %$EXPNLref;  my $name = $EXPNL{$item};  if ( $name !~ /\'(.+)\'/ ) {    die "$item needs \' around the value";  }}#============================================================================sub split_namelist_value {## Return a namelist value split up if longer than 70 characters#  my $self = shift;  my $value = shift;  if ( length($value) > 70 ) {    my $originalvalue = $value;    my $expect = "value";    my @list;    while ( $value =~ /./ ) {       $self->parse_next( \$value, \$expect ) ;      push( @list, $self->{VALUE} );      $expect = "value";    }    my $numberonline = ( 70*($#list+1) ) / length($originalvalue);    my $i = 0;    $value = shift @list;    foreach my $item ( @list ) {      $value = $value . ", $item";      if ( ++$i >= $numberonline ) {        $value = $value . "\n         ";        $i = 0;      }    }  }  return( $value );}#============================================================================sub print {## Print the namelist out#  my $self = shift;  my $ref = $self->{'NLREF'};  my $key;  my %namelist = %$ref;  foreach $key ( sort( keys(%namelist) ) ) {    if ( defined($namelist{$key}) ) {      my $value = $self->split_namelist_value( $namelist{$key} );      print " $key = $value\n";    }  }}#============================================================================sub Write {## Write out the namelist based on values set in the associative# arrays#  my $self = shift;  my $append = shift;  my $ref = $self->{'NLREF'};  my %namelist = %$ref;  my $name = $self->{'NAME'};  my $file = $self->{'FILENAME'};  if ( defined($append) && $append =~ /Append/i ) {    open( OUT, ">>$file" ) || die "Can not open namelist file: $file";  } else {    if ( -f $file ) { unlink( $file ); }    open( OUT, ">$file" ) || die "Can not open namelist file: $file";  }  print OUT "&$name\n";  my $key;  foreach $key ( sort( keys(%namelist) ) ) {    if ( defined($namelist{$key}) ) {      my $value = $self->split_namelist_value( $namelist{$key} );      print OUT " $key\t\t= $value\n";    }  }  print OUT "/\n";  close( OUT );}#============================================================================sub convert_case {## Convert the case of the keys in the main associative arrays to lowercase.# Also terminate if there are two keys with the same name but different case.#  my $self = shift;  my $class = ref($self);  my $nm = "$class\:\:convert_case";  my $ref = $self->{'NLREF'};  my $key;  foreach $key ( keys(%$ref) ) {    if ( defined($$ref{$key}) ) {      my $lckey = $key;      $lckey =~ tr/[A-Z]/[a-z]/;      my $value = $$ref{$key};      if ( $key ne $lckey && defined($$ref{$lckey}) ) {        print "$lckey already defined\n";        die "$nm: Fix your namelist so that two definitions of $lckey do not exist";      }      $$ref{$key}   = undef;      $$ref{$lckey} = $value;    }  }}#============================================================================sub parse {## Parse the namelist from a file#  my $self = shift;  my $filename = shift;  my $class = ref($self);  my $nm = "$class\:\:parse";  my $name = $self->{'NAME'};  if ( ! defined( $filename ) ) {    die "ERROR($nm): Namelist filename not passed to parse method\n";  }  open( NAMELIST, "<$filename") || die "ERROR($nm): Can not open namelist: $filename\n";  print "Parse namelist: $name from file: $filename\n" if ($self->{'printlev'}>2);  #  # Find the designator for this namelist  #  my $found = undef;  my $line;  while ( defined($_ = <NAMELIST>) && (/./)  ) {    if ( /[\$\&]$name(.*?)$/i ) {      $line = $1;      $found = 1;      last;    }  }  if ( ! defined($found) ) {    print "WARNING($nm): did not find the correct namelist: $name in file: $filename\n" if ($self->{'printlev'}>2);    return;  }  my $expect = "variable";  goto LINE;  #  # Loop over each line in the namelist  #NEXT: while ( defined($line = <NAMELIST>) && (/./)  ) {    #    # Loop over each item in each line    #LINE: while ( defined($line) && ($line =~ /./) ) {      $self->parse_next( \$line, \$expect );      if ( $expect eq "end" ) {        last LINE;      }     }    if ( $expect eq "end" ) { last; }  }  close( NAMELIST );  $self->convert_case;}#============================================================================sub setkeypair {## Set the keyword pair#  my $self = shift;  if ( defined( $self->{'VAR'} ) ) {    my $ref = $self->{'NLREF'};    my $var = $self->{'VAR'};    my $val = $self->{'VALUE'};    if ( ! defined($val) ) {      die "ERROR:: Value not defined for variable: $var\n";    }    $$ref{$var} = $val;    $self->{'VAR'}   = undef;    $self->{'VALUE'} = undef;  }}#============================================================================sub parse_next {## Parse the next item in the line# parse_next( \$line, \$expect )#  my $self = shift;  my $line = shift;  my $expect = shift;  my $class = ref($self);  my $nm = "$class\:\:parse_next";  $_ = $$line;  # Blank line, return and continue  if ( /^\s*$/ ) {    $$line = undef;    return;  }  #  # Switch based on what type of item you expect  #  SWITCH: {    # Expect a variable    (($$expect eq "variable") || ($$expect eq "varorvalue")) && do {       # End-designator (F90 form "/" and non-standard F77 forms (&end) )       if ( /^\s*\// || /^\s*[\$\&]end/i ) {         $$line = undef;         $self->setkeypair;         $$expect = "end";         return;       }       # variable       if ( /^\s*,?\s*($namelist::varmatch)(.*?)$/ ) {         $$line = $2;         $$expect = "=";         $self->setkeypair;         $self->{'VAR'} = $1;       } elsif ( $$expect ne "varorvalue" ) {         die "ERROR($nm): expect a variable instead got: $_\n";       # value       } elsif ( $$expect eq "varorvalue"         &&   /^\s*([\s,]*)($namelist::nrvalmatch)([\s,]*)(.*?)$/ ) {         $$line = $4;         $$expect = "varorvalue";         $self->{'VALUE'} = $self->{'VALUE'} . ",$2";         # Comments, only can follow a value         if ( $$line =~ /^([\s,])*![^!]*$/ ) {           $$line = undef;         }       } else {         die "ERROR($nm): expect a value or variable instead got: $_\n";       }       last SWITCH;    };    # Expect a "="    ($$expect eq "=") && do {       if ( /^\s*=(.*?)$/ ) {         $$line = $1;         $$expect = "value";       } else {         die "ERROR($nm): expect a = instead got: $_\n";       }       last SWITCH;    };    # Expect a value    ($$expect eq "value") && do {       # value       if ( /^\s*(${namelist::valmatch})([\s,]*)(.*?)$/ ) {         $$line = $3;         $$expect = "varorvalue";         $self->{'VALUE'} = "$1";         # FORTRAN only allows comments after values         if ( $$line =~ /^\s*![^!]*$/ ) {           $$line = undef;         }       } else {         die "ERROR($nm): expect a value instead got: $_\n";       }       last SWITCH;    };    # default    die "ERROR($nm): Bad value to expect: $$expect\n";  }}#============================================================================# Quoting should be done in the Write method rather# than when string values are added to the namelist hash.# But the namelist variable type isn't known in the Write method.sub quote_string {    my $str = shift;    $str =~ s/^\s+//;    $str =~ s/\s+$//;    unless ($str =~ /^['"]/) {        #"'        $str = "\'$str\'";    }    return $str;}#============================================================================1   # to make use or require happy