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 | |
---|
15 | package Fcm::CfgLine; |
---|
16 | @ISA = qw(Fcm::Base); |
---|
17 | |
---|
18 | # Standard pragma |
---|
19 | use warnings; |
---|
20 | use strict; |
---|
21 | |
---|
22 | # Standard modules |
---|
23 | use File::Basename; |
---|
24 | |
---|
25 | # In-house modules |
---|
26 | use Fcm::Base; |
---|
27 | use Fcm::Config; |
---|
28 | use Fcm::Util; |
---|
29 | |
---|
30 | # List of property methods for this class |
---|
31 | my @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 |
---|
47 | our $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 | |
---|
58 | sub 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 | |
---|
78 | sub 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 | |
---|
103 | for 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 | |
---|
155 | for 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 | |
---|
173 | for 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 | |
---|
195 | for 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 | |
---|
226 | for 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 | |
---|
251 | sub 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 | |
---|
279 | sub 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 | |
---|
302 | sub 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 | |
---|
331 | 1; |
---|
332 | |
---|
333 | __END__ |
---|