source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM1/CfgLine.pm @ 5134

Last change on this file since 5134 was 5129, checked in by abarral, 5 months ago

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