File Coverage

blib/lib/Fortran/F90Namelist.pm

Criterion	Covered	Total	%
statement	461	542	85.0
branch	126	172	73.2
condition	70	99	70.7
subroutine	46	50	92.0
pod	8	25	32.0
total	711	888	80.0

#
#                            F90Namelist.pm
#                            --------------
#
# Description:
#   Parse F90 namelist into a hash and export in different formats.
# Author: wd ([e-mail])
# $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
(L) to import the values of
all available input parameters into GDL/IDL or other visualization
software.

=head2 Methods

=over 4


=item B<$nl-Enew>()

Create a new namelist object


=item B<$nl-Eparse>(I)

=item B<$nl-Eparse>(text => I)

=item B<$nl-Eparse>(file =>(I|I))

=item B<$nl-Eparse>(file => (I|I) [, I ])

=item B<$nl-Eparse>(\%options)

Parse I or the file represented by I or I (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 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
is the more appropriate tool for handling several namelists in one file or
string.


Additional I are:

=over 8

=item B

If true, merge data from namelist with any data that may already be
stored in the object.
See L for a more
flexible framework for dealing with groups of namelists.

=item B

If true, parse all namelists from string or file and merge them into one
namelist object.

=item B

Set name of resulting namelist (default: name of first namelist read).

=item B

With B, don't warn if new slots have same names, but different
values as existing slots.

=item B

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-Emerge>($nl2 [, I])

Merge namelist object $nl2 into $nl.

I are:

=over 8

=item B

Set name of resulting namelist (default: name of $nl).

=item B

With B, don't warn if new slots have same names, but different
values as existing slots.

=back


=item B<$nl-Ename>()

=item B<$nl-Ename>($newname)

Return or set name of namelist.


=item B<$nl-Enslots>()

Return number of slots in namelist


=item B<$nl-Eslots>()

Return ref to list of variable (slot) names in original order


=item B<$nl-Ehash>()

Return namelists as Perl hashref.
See L below for details of the hash format.


=item B<$nl-Eoutput>([options])

Write namelist in given I.

Options are

=over 8

=item B=I

Set the output format.
Currently supported formats are `f90' (default), and `idl'.

=item B=I

Set the name of the namelist (default: C<$nl-Ename>()).

=item B

Trim all trailing whitespace from strings.

=item B

Write all floating point numbers as double precision numbers.

=item B

Print whole namelist in one line (if compatible with the output format).

=item B=I

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 is dangerous.

=back

=back


=head1 HASH FORMAT

The B 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 is a number identifying each data type, while
I 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 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


=head1 LICENSE AND COPYRIGHT

Copyright (c) 2007, Wolfgang Dobler .
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 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 => ); 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 => , 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 = ;
            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 => , 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 => , 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
    #
    # $head_suff
    # $slot_pref
    #
    # $slot_join
    #
    # [...]
    #
    # $slot_suff
    # [...]
    #
    # $last_suff
    # $foot_pref
    #
    # $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  or
	    $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