#
# F90Namelist.pm
# --------------
#
# Description:
# Parse F90 namelist into a hash and export in different formats.
# Author: wd (Wolfgang.Dobler@kis.uni-freiburg.de)
# $Date: 2006/12/18 23:16:04 $
# $Revision: 1.14 $
# [Date and CVS revision are now pretty irrelevant, as I keep the code
# under Darcs now]
package Fortran::F90Namelist;
=head1 NAME
Fortran::F90Namelist - Parse F90 namelists into hash and export in different formats
=head1 SYNOPSIS
use Fortran::F90Namelist;
my $nl = Fortran::F90Namelist->new() or die "Couldn't get object\n";
$nl->parse("&runpars\nx=2,y=3\nvec1=1,2,3\nvec2=3*1.3\n/");
# Operate on each namelist in $text (only works with [mutable]
# strings, not with files)
my $text = "&spars\nx=2,y=3\n/\n&runpars\nvec1=1,2,3\nvec2=3*1.3\n/";
while ($nl->parse($text)) {
print $nl->name(), "\n";
}
Dump in arbitrary order:
use Data::Dumper;
print "F90Namelist ", $nl->name(), " has ", $nl->nslots(), " slots:\n";
print Dumper($nl->hash());
Retain original order:
print "&",$nl->name(),"\n";
my $nl_hash = $nl->hash();
foreach my $var (@{$nl->slots()}) {
print " $var: ", Dumper($nl_hash->{$var});
}
print "/\n";
Read from file:
# Read one namelist from file `one_list.nml'
$nl->parse(file => 't/files/one_list.nml');
# Read one namelist from file handle
open(my $fh , "< t/files/one_list.nml") or die "Couldn't get file handle\n";
$nl->parse(file => $fh);
# or
open(NAMELIST , "< t/files/one_list.nml") or die "Couldn't open file\n";
$nl->parse(file => \*NAMELIST);
Read all namelists from file `start.in' and merge into one namelist
called `nlist'
$nl->parse(file => 't/files/start.in',
all => 1,
namelist => 'nlist');
print "Merged namelist ", $nl->name, " contains:\n",
join(", ", @{$nl->slots}), "\n";
Merge two namelists
my $nl2 = Fortran::F90Namelist->new() or die "Couldn't get object\n";
$nl2->parse(file => 't/files/one_list.nml');
$nl->merge($nl2,
{ dups_ok => 1 } );
print $nl->name, " now has ", $nl->nslots, " slots\n";
Write namelist:
# Write namelist in F90 namelist format
print "F90 format:\n", $nl->output();
# Write namelist as IDL structure
print "IDL format:\n", $nl->output(format => 'idl', name => 'par2');
=head1 DESCRIPTION
Fortran::F90Namelist is a module for parsing Fortran90 namelists into hashs and
re-exporting these hashs in different formats. Currently, the following
data types are supported:
=over 4
=item *
integer
=item *
float/double
=item *
complex numbers
=item *
strings [character(LEN=*)], possibly containing all sorts of quotation
marks
=item *
logical
=back
The following backends exist for re-exporting (or importing into other
languages):
=over 4
=item *
F90 namelist
=item *
IDL struct
=back
This module is used with the I<Pencil Code>
(L<http://www.nordita.dk/software/pencil-code/>) to import the values of
all available input parameters into GDL/IDL or other visualization
software.
=head2 Methods
=over 4
=item B<$nl-E<gt>new>()
Create a new namelist object
=item B<$nl-E<gt>parse>(I<string>)
=item B<$nl-E<gt>parse>(text => I<string>)
=item B<$nl-E<gt>parse>(file =>(I<fname>|I<FHANDLE>))
=item B<$nl-E<gt>parse>(file => (I<fname>|I<FHANDLE>) [, I<options> ])
=item B<$nl-E<gt>parse>(\%options)
Parse I<string> or the file represented by I<fname> or I<FHANDLE> (a file
handle), returns the name of the namelist parsed, or undef if parsing
failed.
When reading from a mutable text string $text, the string is modified and
contains everything following the namelist just parsed.
This allows C<while> loops like
while ($nl->parse($text)) {
print $nl->name(), "\n";
}
to work.
This does however not work for files or immutable strings, so
=for test ignore
while ($nl->parse(file => "t/files/start.in")) {
print $nl->name(), "\n";
}
=for test
and
=for test ignore
while ($nl->parse("&nl1\nx=5.\n/\n&nl2\n/")) {
print $nl->name(), "\n";
}
=for test
will fail.
Generally speaking, L<Fortran::F90Namelist::Group|Fortran::F90Namelist::Group>
is the more appropriate tool for handling several namelists in one file or
string.
Additional I<options> are:
=over 8
=item B<merge>
If true, merge data from namelist with any data that may already be
stored in the object.
See L<Fortran::F90Namelist::Group|Fortran::F90Namelist::Group> for a more
flexible framework for dealing with groups of namelists.
=item B<all>
If true, parse all namelists from string or file and merge them into one
namelist object.
=item B<name>
Set name of resulting namelist (default: name of first namelist read).
=item B<dups_ok>
With B<merge>, don't warn if new slots have same names, but different
values as existing slots.
=item B<broken>
Try to parse broken namelists as produced by ifc 7.x, where you can get
something like
=for test ignore
COOLING_PROFILE='gaussian ',COOLTYPE='Temp
'COOL= 0.0,CS2COOL= 0.0,RCOOL= 1.000000
=for test
if the closing quote for a string (`Temp ') would end up in column 81.
All options can be passed in a hash(-ref):
my %options = ( file => 't/files/one_list.nml',
name => 'broken_nlist',
broken => 1 );
$nl->parse(%options);
$nl->parse(\%options); # the same
=back
=item B<$nl-E<gt>merge>($nl2 [, I<options>])
Merge namelist object $nl2 into $nl.
I<Options> are:
=over 8
=item B<name>
Set name of resulting namelist (default: name of $nl).
=item B<dups_ok>
With B<merge>, don't warn if new slots have same names, but different
values as existing slots.
=back
=item B<$nl-E<gt>name>()
=item B<$nl-E<gt>name>($newname)
Return or set name of namelist.
=item B<$nl-E<gt>nslots>()
Return number of slots in namelist
=item B<$nl-E<gt>slots>()
Return ref to list of variable (slot) names in original order
=item B<$nl-E<gt>hash>()
Return namelists as Perl hashref.
See L<HASH FORMAT|/"HASH FORMAT"> below for details of the hash format.
=item B<$nl-E<gt>output>([options])
Write namelist in given I<format>.
Options are
=over 8
=item B<format>=I<format>
Set the output format.
Currently supported formats are `f90' (default), and `idl'.
=item B<name>=I<name>
Set the name of the namelist (default: C<$nl-E<gt>name>()).
=item B<trim>
Trim all trailing whitespace from strings.
=item B<double>
Write all floating point numbers as double precision numbers.
=item B<oneline>
Print whole namelist in one line (if compatible with the output format).
=item B<maxslots>=I<N>
Print only N slots per line.
Useful for programs like IDL that have restrictions on the length of lines
read from a pipe, so B<oneline> is dangerous.
=back
=back
=head1 HASH FORMAT
The B<hash> method returns a hash reference of the following structure:
=for test ignore
{ 'name of var1' => { 'value' => [ value1, value2, ..],
'type' => numerical_type,
'stype' => "type string"
},
'name of var2' => { 'value' => [ value1, value2, ..],
'type' => numerical_type
'stype' => "type string"
},
...
}
=for test
Here I<numerical_type> is a number identifying each data type, while
I<stype> is a textual description of the given data type.
E.g.
=for test ignore
{ 'xyz0' => { 'value' => [ 0., -3.141593, 0. ],
'type' => 6,
'stype' => 'single precision float'
},
'nt' => { 'value' => [ '1000' ],
'type' => 4,
'stype' => 'integer'
}
}
=for test
Note: This is currently just the internal format used to represent
namelists and can thus change in the future.
In particular the C<type> numbers should not considered to be stable
between releases.
=head1 TO DO
=over 4
=item 1.
new(), parse(), output(), etc. should check for unknown args and complain,
not silently ignore them as is currently the case.
=item 2.
More output methods:
=over 8
=item *
Octave/matlab , C structs, YAML, XML(?), ...
=back
=back
=head1 BUGS AND LIMITATIONS
=over 4
=item *
No user-defined types (records) are supported, so if you have these LaTeX
comment characters in your namelist data, you are out of luck.
=back
=head1 AUTHOR
Wolfgang Dobler <Wolfgang.Dobler@kis.uni-freiburg.de>
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2007, Wolfgang Dobler <Wolfgang.Dobler@kis.uni-freiburg.de>.
All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same conditions as Perl or under the GNU General Public
License, version 2 or later.
=head1 DISCLAIMER OF WARRANTY
Use completely at your own risk.
=head1 SEE ALSO
L<Fortran::Namelist> by Victor Marcello Santillan.
That module has a more limited scope (reading a namelist group from file,
inserting namelists, and writing the resulting group to another file [my
interpretation]), but is way faster on large files.
=cut
use strict;
use Carp;
use vars qw($VERSION);
# Cannot use use Perl5.8's constant { x => 1, y=>2 , ..} because 5.6
# is very popular still
#
# Possible states of parser [used at all?]
use constant UNDEF => -1;
use constant START => 0; # initial state of parser
use constant VAR => 1; # at beginning of variable name
use constant VALUE => 2; # at beginning of value
use constant SQUOTE => 3; # in string after opening single quote
use constant DQUOTE => 4; # in string after opeing double quote
use constant BRACKET => 5; # after opening bracket (e.g. complex number)
use constant COMMENT => 6; # after exclamation mark (F90 comment)
use constant NL_END => 7; # after closing `/'
#
# F90 data types
use constant UNKNOWN => 0;
use constant SQ_STRING => 1;
use constant DQ_STRING => 2;
use constant LOGICAL => 3;
use constant INTEGER => 4;
use constant FLOAT => 5; # a float here can be single or double
use constant SINGLE => 6;
use constant DOUBLE => 7;
use constant COMPLEX => 8;
use constant DCOMPLEX => 9;
use constant MULTIPLE => 20;
#
use constant ID => 100; # variable name (_not_ a data type)
$VERSION = '0.5.1';
## Regexps for integer and floating-point numbers
# general float:
my $numeric = qr/(?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[EeDd](?:[+-]?\d+))?/;
# float:
my $numeric_e = qr/(?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?/;
# double:
my $numeric_d = qr/(?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Dd](?:[+-]?\d+))?/;
# float with decimal point, but w/o exponential part:
my $float = qr/(?:[-+]?(?:\d+\.\d*|\d*\.\d+))/;
## Extend floating-point numeric tpes by one- or two-point
## compactification of real numbers (any mathematicians here?), aka IEEE
## denormalized numbers (for engineers):
my $NaN = qr/NaN/;
my $Inf = qr/(?:[-+]?)Inf/;
my $ieee_denorm = qr/(?:$NaN|$Inf)/;
#$numeric_e = qr/(?:$numeric_e|$ieee_denorm)/;
#$numeric_d = qr/(?:$numeric_d|$ieee_denorm)/;
$numeric = qr/(?:$numeric|$ieee_denorm)/;
$float = qr/(?:$float|$ieee_denorm)/;
## Regexps for the different data type values. Make sure all brackets are
## marked grouping-but-non-capturing (?:...), or else the parsing
## algorithm will fail.
my @regexp;
$regexp[SQ_STRING] = qr/'(?:[^']|'')*'/; # even covers 'toto''s quote'
$regexp[DQ_STRING] = qr/"(?:[^"]|"")*"/; # ditto for double quotes
$regexp[DCOMPLEX] = qr/\(\s*$numeric_d\s*,\s*$numeric_d\s*\)/;
$regexp[COMPLEX] = qr/\(\s*$numeric\s*,\s*$numeric\s*\)/;
$regexp[LOGICAL] = qr/(?:T|F|\.(?:true|TRUE|false|FALSE)\.)/;
$regexp[MULTIPLE] = qr/[0-9]+\*/; # also need special treatment...
$regexp[INTEGER] = qr/[+-]?[0-9]+/;
$regexp[DOUBLE] = qr/$numeric_d/;
$regexp[SINGLE] = qr/$numeric_e/;
$regexp[FLOAT] = qr/$float/;
$regexp[ID] = qr/[a-zA-Z](?:[a-zA-Z0-9_])*/; # allowed namelist/var. names
## Corresponding regexp for compatible type class (numeric, complex, ...)
my @regexp2 = @regexp; # same regexp by default
$regexp2[DCOMPLEX] = qr/\(\s*$numeric\s*,\s*$numeric\s*\)/;
$regexp2[COMPLEX] = qr/\(\s*$numeric\s*,\s*$numeric\s*\)/;
$regexp2[INTEGER] = qr/$numeric/;
$regexp2[DOUBLE] = qr/$numeric/;
$regexp2[SINGLE] = qr/$numeric/;
$regexp2[FLOAT] = qr/$numeric/;
# Hash for looking up symbolic names for type constants. The constants are
# only expanded as numbers if adding 0.
my %stypes = ( UNKNOWN + 0 => 'unknown',
SQ_STRING + 0 => 'single-quote string',
DQ_STRING + 0 => 'double-quote string',
LOGICAL + 0 => 'logical',
INTEGER + 0 => 'integer',
FLOAT + 0 => 'unspecified float',
SINGLE + 0 => 'single precision float',
DOUBLE + 0 => 'double precision float',
COMPLEX + 0 => 'complex number',
DCOMPLEX + 0 => 'double precision complex number',
MULTIPLE + 0 => 'multiple data (array)',
);
# Global variables related to output() method:
my ($cmplx_pref,$cmplx_suff) = ('', ''); # default delimiters for complex nums
# ---------------------------------------------------------------------- #
##
## Object constructor
##
## Internal structure of Namlist objects (update me):
## DATA -- variable names, values, and types (hashref, see below)
## SLOTS -- ordered list of variable names (array ref)
## NSLOTS -- number of slots
## NAME -- name of namelist
## PARSED_ -- flag indicating that argument has been parsed
## DEBUG_ -- debug flag
##
## Structure of DATA slot: Note: One namelist object holds only one
## namelist -- use {$nl1, $nl2, ..} to group them.
##
## $self->{DATA} = data_hash;
## data_hash = { 'name of var1' => { 'value' => [ value1, value2, ..],
## 'type' => numerical_type,
## 'stype' => "type string"
## }
## 'name of var2' => { 'value' => [ value1, value2, ..],
## 'type' => numerical_type
## 'stype' => "type string"
## }
## ...
## };
##
sub new {
# Return new F90Namelist object. By default, the object is unparsed and has
# no name. Use `empty => 1' and `name => $name' to create a complete empty
# namelist with name $name'.
#
# my $nl = Fortran::F90Namelist::new();
# my $nl = Fortran::F90Namelist::new(name => 'toto', empty => 1);
# my $nl = Fortran::F90Namelist::new({name => 'toto', empty => 1});
# IMPLEMENT US:
# my $nl = Fortran::F90Namelist::new({file => $filename);
# my $nl = Fortran::F90Namelist::new({text => $text, debug => 1});
#
my $proto = shift; # either classref or object ref or string
my @argv = @_;
my $class = ref($proto) || $proto;
my $self = {};
my %data = ();
my @slots = ();
my $nslots = undef;
my $parsed = 0;
my $short_usage =
"Usage:\n" .
" Fortran::F90Namelist::new()\n" .
" Fortran::F90Namelist::new(name => \$name)\n" .
" Fortran::F90Namelist::new({name => \$name})\n" ;
# Parse argument(s) (name => <nlname>); may be list or hashref
my %args;
if (@argv) {
if (ref($argv[0]) eq 'HASH') { # parse($hashref)
%args = %{$argv[0]};
} else { # parse(%hash) or parse(@list)
%args = @argv;
}
}
#
my $name = ($args{name} || '' );
my $empty = ($args{empty} || '' );
my $debug = ($args{debug} || 0 );
if ($empty) { # Valid but empty namelist
$nslots = 0;
$parsed = 1;
}
##
## Finish the object
##
# public data of object
$self->{DATA} = \%data;
$self->{SLOTS} = \@slots;
$self->{NSLOTS} = $nslots;
$self->{NAME} = $name;
# internal data
$self->{PARSED_} = $parsed;
$self->{DEBUG_} = $debug;
bless($self,$class);
return($self);
}
# ====================================================================== #
##
## Methods
##
sub parse {
#
# $obj->parse($text)
# $obj->parse(file => $filename)
# $obj->parse(file => $filehandle)
# $obj->parse(file => $filename|$filehandle, merge => 1[, name => $name])
# $obj->parse({file => $filename|$filehandle, merge => 1[, name => $name]})
# $obj->parse({text => $textstring, merge => 1[, name => $name]})
#
# IMPLEMENT ME:
# $obj->parse({text => $textstring, debug => 1})
#
# Parse text or file containing F90 namelist(s)
#
my $self = shift;
my @args = @_; # can't use shift() since we change value
# of $text
my $state = START;
my $debug = $self->{DEBUG_};
my %args;
my $text;
my $textarg = 0;
# Parse arguments (file => <filename>, etc.); may be single string,
# list, hash or hashref
if (ref($args[0]) eq 'HASH') { # parse($hashref)
%args = %{$args[0]};
} else {
if (@_ == 1) { # parse($string)
$textarg = 1;
$text = $args[0];
} else { # parse(%hash) or parse(@list)
%args = @args;
}
}
my $file = ($args{file} || '' );
my $merge = ($args{merge} || 0 );
my $all = ($args{all} || 0 );
my $name = ($args{name} || '' );
my $dups_ok = ($args{dups_ok} || '' );
my $broken = ($args{broken} || 0 );
# Get text from file if necessary
$text = ($args{text} || $text );
if (!defined($text)) {
croak "\$nl->parse(): need text or file argument\n"
unless ($file ne '');
local $/ = undef;
if (ref($file) eq 'GLOB') { # file handle
$text = <$file>;
} else { # file name
open(FH, "< $file") or croak "Cannot open file <$file> for reading";
$text = <FH>;
close(FH);
}
}
if ($merge) {
$name ||= $self->{NAME}; # default to previous name
} else { # clear/reset all data
$self->{DATA} = {};
$self->{SLOTS} = [];
$self->{NSLOTS} = 0;
$self->{NAME} = $name;
}
my $done = 0;
do {
my ($name1, $nslots1, @slots1);
my $href = parse_namelist(\$text, \$name1, \$nslots1, \@slots1,
$broken, $debug);
if (defined($href)
&& defined($name1)
&& $name1 ne ''
) { # really read a namelist
$name ||= $name1; # choose first name if not set yet
# Call merge method to do the actual work
$self->merge([\@slots1, $href],
{ name => $name,
dups_ok => $dups_ok }
);
$done = 1 unless ($all);
} else { # read nothing useful --> get out of this loop
$done = 1;
}
} until ($done);
# Is there a way to find out whether $text is mutable (i.e. no
# constant)? Until I find one, just use brute force:
eval { $_[0] = $text }; # Return remaining $text
$@ = ''; # We won't use this anyway..
# Don't mimic success if we haven't read anything useful
return undef if ($name eq '');
if ($debug) {
print STDERR
"Fortran::F90Namelist->parse: Successfully read namelist <$name>\n";
print STDERR "=================================\n";
}
$self->{PARSED_} = 1;
return $self->{NAME};
}
# ---------------------------------------------------------------------- #
sub merge {
#
# $obj->merge($obj2);
# $obj->merge($obj2, name => $name, $dups_ok => 1 );
# $obj->merge($obj2, { name => $name, $dups_ok => 1 });
#
# Merge another namelist into this one
#
my $self = shift();
my $nl2 = shift();
my @args = @_; # remaining argument(s)
# Arg $nl2 can be a namelist or just a data hashref
my (@slots2,$hashref2);
if (ref($nl2) eq 'Fortran::F90Namelist') {
@slots2 = @{$nl2->{SLOTS}};
$hashref2 = $nl2->{DATA};
} elsif (ref($nl2) eq 'ARRAY') {
@slots2 = @{$$nl2[0]};
$hashref2 = $$nl2[1];
} else {
croak "Fortran::F90Namelist->merge(): "
. "expected Fortran::F90Namelist object or hashref\n";
}
# Parse arguments (name => <name>, etc.); may be hash or hashref
my %args;
if (ref($args[0]) eq 'HASH') { # parse($hashref)
%args = %{$args[0]};
} else {
%args = @args;
}
my $name = ($args{name} || $self->{NAME} );
my $dups_ok = ($args{dups_ok} || '' );
my $nslots = $self->{NSLOTS};
my @slots = @{$self->{SLOTS}};
my $hashref = $self->{DATA};
my $debug = $self->{DEBUG_};
if ($debug) {
print STDERR
"Fortran::F90Namelist->merge: "
, "Merging ", @slots2 + 0,
"-slots namelist into $nslots-slots namelist\n";
}
# Eliminate repeated slots and warn if values don't agree
slot: foreach my $slot (@slots2) {
if (defined($$hashref{$slot})) { # slot already known
my @val1=@{$$hashref{$slot}{'value'}};
my @val2=@{$$hashref2{$slot}{'value'}};
while (@val1 and @val2) {
my $v1 = pop(@val1);
my $v2 = pop(@val2);
if (($v1 ne $v2) && ! $dups_ok) {
carp "WARNING: Conflicting slots" .
" $slot = [@{$$hashref{$slot}{'value'}}]" .
" vs. [@{$$hashref2{$slot}{'value'}}]\n";
next slot;
}
}
} else { # new slot
push @slots, $slot;
$$hashref{$slot} = $$hashref2{$slot};
$nslots++;
}
}
# Wrap it up
$self->{NAME} = $name;
$self->{NSLOTS} = $nslots;
$self->{SLOTS} = \@slots;
$self->{DATA} = $hashref;
if ($debug) {
print STDERR
"Fortran::F90Namelist->merge: "
. "Successfully merged into namelist <$name>\n";
print STDERR "=================================\n";
}
$self->{PARSED_} = 1;
return 1; # success
}
# ---------------------------------------------------------------------- #
sub name {
# Get or set name of parsed namelists
my $self = shift();
if (@_) { $self->{NAME} = shift };
return $self->{NAME};
}
# ---------------------------------------------------------------------- #
sub nslots {
# Get number of slots in namelist
my $self = shift();
return $self->{NSLOTS}
}
# ---------------------------------------------------------------------- #
sub slots { # FIXME
# Return array ref of variable names in slots
my $self = shift();
return $self->{SLOTS}
}
# ---------------------------------------------------------------------- #
sub hash {
# Return hash with parsed namelist contents
my $self = shift;
return $self->{DATA};
}
# ---------------------------------------------------------------------- #
sub output {
# Write namelist in specified format (defaults to 'f90')
my $self = shift();
# Optional arguments:
# format => format ('f90' [default] or 'idl')
# name => nl_name (name of nlist/struct [default: get from nlist])
# trim => 0/1 (trim trailing whitespace off strings)
# double => 0/1 (mark all floats as double precision)
# oneline => 0/1 (write all in one line? [only for some formats])
# maxslots => N (similar to oneline, but split every N slots)
my @argv = @_;
# Parse arguments (file => <filename>, etc.); may be list, hash or hashref
my %args;
if (ref($argv[0]) eq 'HASH') {
%args = %{$argv[0]};
} else {
%args = @argv;
}
my $format = ($args{format} || 'f90');
my $name = ($args{name} || $self->name() || '');
my $trim = ($args{trim} || 0);
my $double = ($args{double} || 0);
my $oneline = ($args{oneline} || 0);
my $maxslots = ($args{maxslots} || 0);
$oneline = 0 if ($maxslots);
# Sanity check
unless ($self->{PARSED_}) {
croak "Called method output() on unparsed namelist";
return undef;
}
# Get name of namelist(s?)
my ($name1,$hashref) = (%{$self->{DATA}}); # hash (name=>valhash) ->
# 2-element array; should
# possibly be a loop over all
# name=>hash pairs?
# Format-dependent settings
# We are printing the following:
# $head_pref
# <header>
# $head_suff
# $slot_pref
# <slot1>
# $slot_join
# <slot2>
# [...]
# <slot_maxslots>
# $slot_suff
# [...]
# <slotN>
# $last_suff
# $foot_pref
# <footer>
# $foot_suff
my ($header,$footer);
my ($head_pref,$head_suff);
my ($slot_pref,$slot_join,$slot_suff,$last_suff);
my ($foot_pref,$foot_suff);
my ($newline,$indent); # to play tricks with $oneline
if ($oneline) {
$newline = " ";
$indent = "";
} else {
$newline = "\n";
$indent = " ";
}
if (lc($format) eq 'f90') {
$header = "\&$name";
$footer = "/";
#
$head_pref = "";
$head_suff = "$newline";
$slot_pref = "$indent";
$slot_join = ", ";
$slot_suff = ",$newline";
$last_suff = "$newline";
$foot_pref = "";
$foot_suff = "\n";
} elsif (lc($format) eq 'idl') {
$header = "$name = {";
$footer = "}";
#
$head_pref = "";
$head_suff = " \$$newline";
$slot_pref = "$indent";
$slot_join = ", ";
$slot_suff = ", \$$newline";
$last_suff = " \$$newline";
$foot_pref = "";
$foot_suff = "\n";
#
if ($oneline) {
$head_suff = "$newline";
$slot_suff = ",$newline";
$last_suff = "$newline";
}
#
$cmplx_pref = "complex"; # complex number prefix
} else {
croak "output(): Format <$format> unknown";
return undef;
}
my @slots = format_slots($self,$format,$double,$trim);
# Take care of $maxslots
@slots = aggregate_slots(\@slots,$maxslots,$slot_join);
# Now construct output string
my $string;
$string .= $head_pref
. $header
. $head_suff;
if (@slots) {
$string .= $slot_pref;
$string .= join($slot_suff . $slot_pref, @slots);
$string .= $last_suff;
}
$string .= $foot_pref
. $footer
. $foot_suff;
return $string;
}
sub debug {
#
# $obj->debug(1) # debugging on
# $obj->debug(0) # debugging off
#
# Undocumented: Set/get debug flag
my $self = shift();
if (@_) { $self->{DEBUG_} = shift };
return $self->{DEBUG_}
}
# ====================================================================== #
## Private utility subroutines:
sub parse_namelist {
#
# Parse first F90 namelist from text string; return reference to hash
#
# parse_namelist(\$text,\$name,\$nslots,\@slots,$broken,$debug);
#
my $textref = shift;
my $nameref = shift;
my $nslotsref = shift;
my $slotsref = shift;
my $broken = shift;
my $debug = shift;
my %hash;
my $nslots = 0;
my $state = START;
my $id = $regexp[ID]; # allowed namelist/variable names
my ($status,$var,@values,$type);
## Reset to reasonable default values
$$nslotsref = 0;
@$slotsref = ();
$$nameref = '';
## Get name of nl
$$nameref = extract_nl_name($textref,$debug) or return undef;
$status = VAR;
## Extract variable slots
my $text = $$textref;
## Apply fix for brokenness
if ($broken) {
$text =~ s{\n'}{',}g;
}
while ($text ne '') {
print STDERR "--------------------\nTop of while loop..\n" if ($debug);
strip_space_and_comment($text);
if ($text =~ s/^($id)(\([0-9, \t]+\))?\s*=\s*//s) {
# string starts with <var=...> or <var(idx,idy,...)=...>
$var = lc($1);
# any array indices following the variable name?
if (defined($2)) {
my $indices = $2;
$indices =~ s/\s+//g; # squeeze out whitespace
$var = $var . $indices;
}
$status = VALUE;
if ($debug) {
print STDERR "parse_namelist 1: \$var=<$var>\n";
print STDERR "parse_namelist 1: \$text=<",
printable_substring($text,50), ">\n";
}
# Get values and check
@values = get_value(\$text,\$type,$var,$debug); # drop $debug here..
if (@values) {
$nslots++;
push @$slotsref, $var;
} else {
show_error("Couldn't read value", "", $text, 1);
return undef;
}
} elsif ($text =~ s{\s*(/|\$end)\s*}{}) { # string is </> or <$end>
$status = NL_END;
last; # end of namelist
} else {
show_error("Expected var=[...] not found ", "", $text, 1);
return undef;
}
print STDERR "[",join(',',@values), "] -> \$hash{$var}\n" if ($debug);
my $stype = ($stypes{$type} || 'Type inconsistency!');
$hash{$var} = { type => $type,
stype => $stype,
value => [@values]
};
}
unless ($status == NL_END) {
carp "Aborted parsing at <",
printable_substring($text,50),">\n",
"trying to read slot `$var'\n";
return undef;
}
print STDERR
"parse_namelist: Namelist <$$nameref> parsed succesfully\n"
if ($debug);
$$textref = $text; # propagate remainder of $text back
$$nslotsref = $nslots; # propagate number of slots back
return \%hash;
}
# ---------------------------------------------------------------------- #
sub extract_nl_name {
# Extract namelist name (the part starting with `&' or `$')
my $textref = shift;
my $debug = shift;
my $text = $$textref;
my $name;
my $id = $regexp[ID]; # allowed namelist/variable names
print STDERR "extract_nl_name 1: \$text=<",
printable_substring($text,50),">\n" if ($debug);
strip_space_and_comment($text);
print STDERR "extract_nl_name 2: \$text=<",
printable_substring($text,50), ">\n" if ($debug);
if ($text =~ s/^(?:&|\$)($id)//) {
$name = lc($1);
} else { # empty (comment/whitespace) or erroneous
if ($text eq '') {
print STDERR "Empty text (at most some comments)" if ($debug);
$$textref = $text; # propagate remainder of $text back
return undef;
} else {
show_error("Namelist does not start with &\n","",$text,1);
return undef; # never got here..
}
}
strip_space_and_comment($text);
if ($debug) {
print STDERR "extract_nl_name 3: \$name=<$name>\n";
print STDERR "extract_nl_name 3: \$text=<",
printable_substring($text,50), ">\n";
}
$$textref = $text; # propagate remainder of $text back
$name;
}
# ---------------------------------------------------------------------- #
sub strip_space_and_comment {
# Strip leading space and anything from possible leading exclamation mark
# til end of line.
$_[0] =~ s/^(\s*(![^\n]*)?)*//s;
}
# ---------------------------------------------------------------------- #
sub get_value {
# Extract one or several values from string that starts off immediately
# after the equal sign of a slot assignment
my $txtptr = shift;
my $typeptr = shift;
my $varname = shift;
my $debug = shift; # Need to somewhow get rid of this argument...
my $text = $$txtptr;
my @values;
strip_space_and_comment($text); # (are comments really allowed here?)
my $type = infer_data_type($text);
if ($debug) { # pretty-printing of type
print STDERR
"Found data of type $type (",
elucidate_type($type),
") in <",
printable_substring($text,40), ">\n";
}
if ($type == UNKNOWN) {
show_error("Cannot identify data type","$varname=","$text");
croak();
}
# Extract data
my $multiregexp = $regexp[MULTIPLE]; # qr// wouldn't expand the CONSTANT...
my $re_type = qr/$regexp2[$type]/;
while ($text =~ s/^
($multiregexp)?($re_type)
\s*
(
(?: ,? \s* ! [^\n]* | , | \s+ )
|
(?=\/|\$end)
)
\s*
//sx) {
my $mul = ( $1 || 1);
my ($val,$rest) = ($2,$3);
$mul =~ s/\*//;
if ($debug) {
print STDERR "\$mul=<$mul>, \$val=<$val>\n";
print STDERR "\$rest=<", printable_substring($rest,2),
">, \$text=<", printable_substring($text,40), ">\n";
}
# `Widen' data type if necessary (e.g. integer -> double for
# `var = 1, 2.D0')
my $valtype = infer_data_type($val);
$type = $valtype if ($valtype > $type);
if ($debug) { # pretty-printing of type
print STDERR
"Data type is now ($valtype) $type (",
elucidate_type($type),
")\n";
}
# Remove quotes around (and doubled in) strings
if ($type == SQ_STRING) {
$val =~ s/^'(.*)'$/$1/s;
$val =~ s/''/'/gs;
}
if ($type == DQ_STRING) {
$val =~ s/^"(.*)"$/$1/s;
$val =~ s/""/"/gs;
}
# Remove embedded newlines from strings (Anders' strange namelist
# samples from Pencil Code with dust density)
if (($type == SQ_STRING) || ($type == DQ_STRING)) {
$val =~ s/\n//g;
}
push @values, ($val) x $mul;
$text =~ s/.*\n// if ($rest eq '!'); # comment
print STDERR "<<", ($mul||'1'), "x>><<$val>> <<",
printable_substring($text), ">>\n" if ($debug);
}
$$txtptr = $text; # return remaining unparsed string
$$typeptr = $type; # return type
@values;
}
# ---------------------------------------------------------------------- #
sub elucidate_type {
# Expand numerical constants into understandable type names
my $type = shift;
my @tp;
$tp[UNKNOWN] = 'UNKNOWN';
$tp[SQ_STRING] = 'SQ_STRING';
$tp[DQ_STRING] = 'DQ_STRING';
$tp[LOGICAL ] = 'LOGICAL';
$tp[INTEGER ] = 'INTEGER';
$tp[FLOAT ] = 'FLOAT';
$tp[SINGLE ] = 'SINGLE';
$tp[DOUBLE ] = 'DOUBLE';
$tp[COMPLEX ] = 'COMPLEX';
$tp[DCOMPLEX ] = 'DCOMPLEX';
$tp[MULTIPLE ] = 'MULTIPLE';
return $tp[$type];
}
# ---------------------------------------------------------------------- #
sub infer_data_type {
# Determine the F90 data type of first item in string, skipping multiplier
# if present
my $text = shift;
$text =~ s/^\s*[0-9]+\*//; # ignore multiplier for finding data type
if ($text =~ /^\s*'/) { SQ_STRING;
} elsif ($text =~ /^\s*"/) { DQ_STRING;
} elsif ($text =~ /^\s*\(\s*$numeric_e\s*,/) { COMPLEX;
} elsif ($text =~ /^\s*\(/) { DCOMPLEX;
} elsif ($text =~ /^\s*(T|F|.(true|false).)/i) { LOGICAL;
} elsif ($text =~ /^\s*[+-]?[0-9]+(\s|,|!|$)/) { INTEGER;
} elsif ($text =~ /^\s*$float(\s|,|!|$)/) { FLOAT;
} elsif ($text =~ /^\s*$numeric_e(\s|,|!|$)/) { SINGLE;
} elsif ($text =~ /^\s*$numeric_d(\s|,|!|$)/) { DOUBLE;
} else { UNKNOWN;
}
}
# ---------------------------------------------------------------------- #
sub show_error {
# Print error message and beginning of string with marker of current
# position [Slightly ridiculous, as the marker will always point to
# beginning of line]
my $errmsg = shift;
my $prefix = shift;
my $text = shift;
my $die = (shift || 0);
chomp($errmsg);
# Escape newlines and only print 75 chars:
my $subtext = $prefix . $text;
$subtext =~ s/\n/\\n/g;
$subtext = substr($subtext,0,75) . "\n";
# Splice in marker line
my $marker = " " x length($prefix) . "^------ HERE\n";
$subtext =~ s/\n/\n$marker/;
# Prefix error message:
$subtext = "\e[01m$errmsg:\e[00m\n" . $subtext;
# Now die
if ($die) {
croak "$subtext"; # die
} else {
carp "$subtext"; # warn
}
}
# ---------------------------------------------------------------------- #
sub printable_substring {
# Extract substring and quote newlines for diagnostic printing
my $string = shift;
my $length = shift || 40;
$string =~ s/\n/\\n/g;
my $oldlen = length($string);
$string = substr($string,0,$length);
substr($string,-3,3) = '...' if ($length<$oldlen);
$string;
}
# ---------------------------------------------------------------------- #
sub assign_slot_val {
#
# Assignment of value to slot variable for output (format-dependent: `='
# for f90, `:' for IDL records, etc.)
#
my $var = shift;
my @vals = @{shift()};
my $format = shift;
my $type = shift;
my $assmnt = "$var";
if ($format eq 'f90') {
$assmnt .= "=";
} elsif ($format eq 'idl') {
$assmnt .= ": "; # structure syntax
} else {
croak "assign_slot_val: Unknown format <$format>\n";
}
encapsulate_values(\@vals,$format,$type); # preprocess values
if (@vals > 1) {
$assmnt .= add_array_bracket(join(",", @vals), $format);
} else {
$assmnt .= $vals[0];
}
$assmnt;
}
# ---------------------------------------------------------------------- #
sub encapsulate_values {
#
# Format-specific preprocessing of data values, e.g. quoting strings,
# mapping logicals to integers for IDL, etc.
#
my $valref = shift;
my $format = shift;
my $type = shift;
my @vals = @$valref;
## Actions for all formats
if ($type==COMPLEX or $type==DCOMPLEX) {
use Data::Dumper;
@vals = map { "${cmplx_pref}$_${cmplx_suff}" } @vals;
}
## Actions specific for some formats
if ($format eq 'f90') {
#
# F90 output format:
# - quote strings
#
if ($type==SQ_STRING or $type==DQ_STRING) {
@vals = map { quote_string_f90($_) } @vals;
}
} elsif ($format eq 'idl') {
#
# IDL output format:
# - convert logicals to integers
# - quote strings
#
if ($type==LOGICAL) {
@vals = map { encaps_logical_idl($_) } @vals;
} elsif ($type==SQ_STRING or $type==DQ_STRING) {
@vals = map { quote_string_f90($_) } @vals;
}
} else {
#
# Invalid format
#
croak "encapsulate_values: Unknown format <$format>\n";
}
@$valref = @vals;
}
# ---------------------------------------------------------------------- #
sub format_slots {
#
# Format all slots for printing and collect in a list
#
my $obj = shift;
my $format = (shift || 0);
my $double = (shift || 0);
my $trim = (shift || 0);
return () unless ($obj->{NSLOTS});
my @slots;
my $slot;
foreach my $var (@{$obj->{SLOTS}}) {
my $valhash = $obj->{DATA}->{$var};
my @vals = @{$$valhash{'value'}};
my $type = $$valhash{'type'};
# Trim trailing whitespace
if ($trim) {
@vals = map { s/\s*$//; $_ } @vals;
}
# Replace E[0-9]+ by, or append `D0' where necessary
if ($double) {
if (($type == FLOAT) ||
($type == SINGLE) ||
($type == DOUBLE) ||
($type == COMPLEX) ||
($type == DCOMPLEX)) {
@vals = map { s/[eEdD]/D/; $_ } @vals;
@vals = map { s/(^|\s|,)($float)($|\s|,)/$1$2D0$3/g; $_ } @vals;
@vals = map { s/(\(\s*)($float)(\s*,\s*)($float)(\s*\))/$1$2D0$3$4D0$5/g; $_ } @vals;
}
}
$slot = assign_slot_val($var,\@vals,$format,$type);
push @slots, $slot;
}
return @slots;
}
# ---------------------------------------------------------------------- #
sub aggregate_slots {
#
# Take list of formatted slot strings, group every $maxslots strings
# together into one string
#
my $slotsref = shift;
my $maxslots = shift;
my $slot_join = shift;
my @slots = @$slotsref;
# Short-circuit if nothing to do
return @slots unless ($maxslots>0);
my @new_slots;
while (@slots) {
# Use a loop here, as @slots[1..$maxslots] would generate trailing
# undefs
my @group_us;
foreach my $i (1..$maxslots) {
push @group_us, shift @slots if (@slots);
}
my $aggregated_slot = join($slot_join, @group_us);
push @new_slots, $aggregated_slot;
}
return @new_slots;
}
# ---------------------------------------------------------------------- #
sub add_array_bracket {
# Add format-specific array delimiters around string
my $string = shift;
my $format = shift;
if ($format eq 'f90') {
# No delimiters
} elsif ($format eq 'idl') {
$string = "[$string]";
} else {
#
# Invalid format
#
croak "add_array_bracket: Unknown format <$format>\n";
}
return $string;
}
# ---------------------------------------------------------------------- #
sub encaps_logical_idl {
# Convert logical string to integer for IDL
my $val = shift;
$val =~ s/(\.false\.|F)/0L/i;
$val =~ s/(\.true\.|T)/-1L/i;
$val;
}
# ---------------------------------------------------------------------- #
sub quote_string_f90 {
# Enclose string by quotation marks, doubling any existing quotation marks
# for Fortran and IDL
my $val = shift;
$val =~ s/'/''/g;
return quote_string($val);
}
# ---------------------------------------------------------------------- #
sub quote_string {
# Enclose string by quotation marks
return "'$_[0]'";
}
# ---------------------------------------------------------------------- #
## Done.
1;
# End of file