New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
CfgLine.pm in branches/UKMO/dev_r5518_25hr_mean_assim_bkg/NEMOGCM/EXTERNAL/fcm/lib/Fcm – NEMO

source: branches/UKMO/dev_r5518_25hr_mean_assim_bkg/NEMOGCM/EXTERNAL/fcm/lib/Fcm/CfgLine.pm @ 6757

Last change on this file since 6757 was 6757, checked in by kingr, 8 years ago

Cleared SVN keywords.

File size: 8.9 KB
Line 
1# ------------------------------------------------------------------------------
2# NAME
3#   Fcm::CfgLine
4#
5# DESCRIPTION
6#   This class is used for grouping the settings in each line of a FCM
7#   configuration file.
8#
9# COPYRIGHT
10#   (C) Crown copyright Met Office. All rights reserved.
11#   For further details please refer to the file COPYRIGHT.txt
12#   which you should have received as part of this distribution.
13# ------------------------------------------------------------------------------
14
15package Fcm::CfgLine;
16@ISA = qw(Fcm::Base);
17
18# Standard pragma
19use warnings;
20use strict;
21
22# Standard modules
23use File::Basename;
24
25# In-house modules
26use Fcm::Base;
27use Fcm::Config;
28use Fcm::Util;
29
30# List of property methods for this class
31my @scalar_properties = (
32  'bvalue',  # line value, in boolean
33  'comment', # (in)line comment
34  'error',   # error message for incorrect usage while parsing the line
35  'label',   # line label
36  'line',    # content of the line
37  'number',  # line number in source file
38  'parsed',  # has this line been parsed (by the extract/build system)?
39  'prefix',  # optional prefix for line label
40  'slabel',  # label without the optional prefix
41  'src',     # name of source file
42  'value',   # line value
43  'warning', # warning message for deprecated usage
44);
45
46# Useful variables
47our $COMMENT_RULER = '-' x 78;
48
49# ------------------------------------------------------------------------------
50# SYNOPSIS
51#   @cfglines = Fcm::CfgLine->comment_block (@comment);
52#
53# DESCRIPTION
54#   This method returns a list of Fcm::CfgLine objects representing a comment
55#   block with the comment string @comment.
56# ------------------------------------------------------------------------------
57
58sub comment_block {
59  my @return = (
60    Fcm::CfgLine->new (comment => $COMMENT_RULER),
61    (map {Fcm::CfgLine->new (comment => $_)} @_),
62    Fcm::CfgLine->new (comment => $COMMENT_RULER),
63    Fcm::CfgLine->new (),
64  );
65
66  return @return;
67}
68
69# ------------------------------------------------------------------------------
70# SYNOPSIS
71#   $obj = Fcm::CfgLine->new (%args);
72#
73# DESCRIPTION
74#   This method constructs a new instance of the Fcm::CfgLine class. See above
75#   for allowed list of properties. (KEYS should be in uppercase.)
76# ------------------------------------------------------------------------------
77
78sub new {
79  my $this  = shift;
80  my %args  = @_;
81  my $class = ref $this || $this;
82
83  my $self = Fcm::Base->new (%args);
84
85  for (@scalar_properties) {
86    $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef;
87    $self->{$_} = $args{$_} if exists $args{$_};
88  }
89
90  bless $self, $class;
91  return $self;
92}
93
94# ------------------------------------------------------------------------------
95# SYNOPSIS
96#   $value = $obj->X;
97#   $obj->X ($value);
98#
99# DESCRIPTION
100#   Details of these properties are explained in @scalar_properties.
101# ------------------------------------------------------------------------------
102
103for my $name (@scalar_properties) {
104  no strict 'refs';
105
106  *$name = sub {
107    my $self = shift;
108
109    if (@_) {
110      $self->{$name} = $_[0];
111
112      if ($name eq 'line' or $name eq 'label') {
113        $self->{slabel} = undef;
114
115      } elsif ($name eq 'line' or $name eq 'value') {
116        $self->{bvalue} = undef;
117      }
118    }
119
120    # Default value for property
121    if (not defined $self->{$name}) {
122      if ($name =~ /^(?:comment|error|label|line|prefix|src|value)$/) {
123        # Blank
124        $self->{$name} = '';
125
126      } elsif ($name eq 'slabel') {
127        if ($self->prefix and $self->label_starts_with ($self->prefix)) {
128          $self->{$name} = $self->label_from_field (1);
129
130        } else {
131          $self->{$name} = $self->label;
132        }
133
134      } elsif ($name eq 'bvalue') {
135        if (defined ($self->value)) {
136          $self->{$name} = ($self->value =~ /^(\s*|false|no|off|0*)$/i)
137                           ? 0 : $self->value;
138        }
139      }
140    }
141
142    return $self->{$name};
143  }
144}
145
146# ------------------------------------------------------------------------------
147# SYNOPSIS
148#   @fields = $obj->label_fields ();
149#   @fields = $obj->slabel_fields ();
150#
151# DESCRIPTION
152#   These method returns a list of fields in the (s)label.
153# ------------------------------------------------------------------------------
154
155for my $name (qw/label slabel/) {
156  no strict 'refs';
157
158  my $sub_name = $name . '_fields';
159  *$sub_name = sub  {
160    return (split (/$Fcm::Config::DELIMITER_PATTERN/, $_[0]->$name));
161  }
162}
163
164# ------------------------------------------------------------------------------
165# SYNOPSIS
166#   $string = $obj->label_from_field ($index);
167#   $string = $obj->slabel_from_field ($index);
168#
169# DESCRIPTION
170#   These method returns the (s)label from field $index onwards.
171# ------------------------------------------------------------------------------
172
173for my $name (qw/label slabel/) {
174  no strict 'refs';
175
176  my $sub_name = $name . '_from_field';
177  *$sub_name = sub  {
178    my ($self, $index) = @_;
179    my $method = $name . '_fields';
180    my @fields = $self->$method;
181    return join ($Fcm::Config::DELIMITER, @fields[$index .. $#fields]);
182  }
183}
184
185# ------------------------------------------------------------------------------
186# SYNOPSIS
187#   $flag = $obj->label_starts_with (@fields);
188#   $flag = $obj->slabel_starts_with (@fields);
189#
190# DESCRIPTION
191#   These method returns a true if (s)label starts with the labels in @fields
192#   (ignore case).
193# ------------------------------------------------------------------------------
194
195for my $name (qw/label slabel/) {
196  no strict 'refs';
197
198  my $sub_name = $name . '_starts_with';
199  *$sub_name = sub  {
200    my ($self, @fields) = @_;
201    my $return = 1;
202
203    my $method = $name . '_fields';
204    my @all_fields = $self->$method;
205
206    for my $i (0 .. $#fields) {
207      next if lc ($fields[$i]) eq lc ($all_fields[$i] || '');
208      $return = 0;
209      last;
210    }
211
212    return $return;
213  }
214}
215
216# ------------------------------------------------------------------------------
217# SYNOPSIS
218#   $flag = $obj->label_starts_with_cfg (@fields);
219#   $flag = $obj->slabel_starts_with_cfg (@fields);
220#
221# DESCRIPTION
222#   These method returns a true if (s)label starts with the configuration file
223#   labels in @fields (ignore case).
224# ------------------------------------------------------------------------------
225
226for my $name (qw/label slabel/) {
227  no strict 'refs';
228
229  my $sub_name = $name . '_starts_with_cfg';
230  *$sub_name = sub  {
231    my ($self, @fields) = @_;
232
233    for my $field (@fields) {
234      $field = $self->cfglabel ($field);
235    }
236
237    my $method = $name . '_starts_with';
238    return $self->$method (@fields);
239  }
240}
241
242# ------------------------------------------------------------------------------
243# SYNOPSIS
244#   $mesg = $obj->format_error ();
245#
246# DESCRIPTION
247#   This method returns a string containing a formatted error message for
248#   anything reported to the current line.
249# ------------------------------------------------------------------------------
250
251sub format_error {
252  my ($self) = @_;
253  my $mesg = '';
254
255  $mesg .= $self->format_warning;
256
257  if ($self->error or not $self->parsed) {
258    $mesg = 'ERROR: ' . $self->src . ': LINE ' . $self->number . ':' . "\n";
259    if ($self->error) {
260      $mesg .= '       ' . $self->error;
261
262    } else {
263      $mesg .= '       ' . $self->label . ': label not recognised.';
264    }
265  }
266
267  return $mesg;
268}
269
270# ------------------------------------------------------------------------------
271# SYNOPSIS
272#   $mesg = $obj->format_warning ();
273#
274# DESCRIPTION
275#   This method returns a string containing a formatted warning message for
276#   any warning reported to the current line.
277# ------------------------------------------------------------------------------
278
279sub format_warning {
280  my ($self) = @_;
281  my $mesg = '';
282
283  if ($self->warning) {
284    $mesg = 'WARNING: ' . $self->src . ': LINE ' . $self->number . ':' . "\n";
285    $mesg .= '         ' . $self->warning;
286  }
287
288  return $mesg;
289}
290
291# ------------------------------------------------------------------------------
292# SYNOPSIS
293#   $line = $obj->print_line ([$space]);
294#
295# DESCRIPTION
296#   This method returns a configuration line using $self->label, $self->value
297#   and $self->comment. The value in $self->line is re-set. If $space is set
298#   and is a positive integer, it sets the spacing between the label and the
299#   value in the line. The default is 1.
300# ------------------------------------------------------------------------------
301
302sub print_line {
303  my ($self, $space) = @_;
304
305  # Set space between label and value, default to 1 character
306  $space = 1 unless $space and $space =~ /^[1-9]\d*$/;
307
308  my $line = '';
309
310  # Add label and value, if label is set
311  if ($self->label) {
312    $line .= $self->label . ' ' x $space;
313    $line .= $self->value if defined $self->value;
314  }
315
316  # Add comment if necessary
317  my $comment = $self->comment;
318  $comment =~ s/^\s*//;
319
320  if ($comment) {
321    $comment = '# ' . $comment if $comment !~ /^#/;
322    $line .= ' ' if $line;
323    $line .= $comment;
324  }
325
326  return $self->line ($line);
327}
328
329# ------------------------------------------------------------------------------
330
3311;
332
333__END__
Note: See TracBrowser for help on using the repository browser.