OSDN Git Service

Version 5.91
[vbslib/main.git] / GPL_bin_fullset / NaturalDocs / Modules / NaturalDocs / ConfigFile.pm
1 ###############################################################################
2 #
3 #   Package: NaturalDocs::ConfigFile
4 #
5 ###############################################################################
6 #
7 #   A package to manage Natural Docs' configuration files.
8 #
9 #   Usage:
10 #
11 #       - Only one configuration file can be managed with this package at a time.  You must close the file before opening another
12 #         one.
13 #
14 ###############################################################################
15
16 # This file is part of Natural Docs, which is Copyright © 2003-2010 Greg Valure
17 # Natural Docs is licensed under version 3 of the GNU Affero General Public License (AGPL)
18 # Refer to License.txt for the complete details
19
20 use strict;
21 use integer;
22
23 package NaturalDocs::ConfigFile;
24
25
26
27 #
28 #   Topic: Format
29 #
30 #   All configuration files are text files.
31 #
32 #   > # [comment]
33 #
34 #   Comments start with the # character.
35 #
36 #   > Format: [version]
37 #
38 #   All configuration files *must* have a format line as its first line containing content.  Whitespace and comments are permitted
39 #   ahead of it.
40 #
41 #   > [keyword]: [value]
42 #
43 #   Keywords can only contain <CFChars>.  Keywords are not case sensitive.  Values can be anything and run until the end of
44 #   the line or a comment.
45 #
46 #   > [value]
47 #
48 #   Lines that don't start with a valid keyword format are considered to be all value.
49 #
50 #   > [line] { [line] } [line]
51 #
52 #   Files supporting brace groups (specified in <Open()>) may also have braces that can appear anywhere.  It allows more than
53 #   one thing to appear per line, which isn't supported otherwise.  Consequently, values may not have braces.
54 #
55
56
57 #
58 #   Type: CFChars
59 #
60 #   The characters that can appear in configuration file keywords and user-defined element names: letters, numbers, spaces,
61 #   dashes, slashes, apostrophes, and periods.
62 #
63 #   Although the list above is exhaustive, it should be noted that you especially can *not* use colons (messes up keyword: value
64 #   sequences) commas (messes up item, item, item list sequences) and hashes (messes up comment detection.)
65 #
66 #   You can search the source code for [CFChars] to find all the instances where this definition is used.
67 #
68
69
70 ###############################################################################
71 # Group: Variables
72
73 #
74 #   handle: CONFIG_FILEHANDLE
75 #
76 #   The file handle used for the configuration file.
77 #
78
79
80 #
81 #   string: file
82 #
83 #   The <FileName> for the current configuration file being parsed.
84 #
85 my $file;
86
87
88 #
89 #       var: lineReader
90 #
91 #       The <LineReader> used to read the configuration file.
92 #
93 my $lineReader;
94
95
96 #
97 #   array: errors
98 #
99 #   An array of errors added by <AddError()>.  Every odd entry is the line number, and every even entry following is the
100 #   error message.
101 #
102 my @errors;
103
104
105 #
106 #   var: lineNumber
107 #
108 #   The current line number for the configuration file.
109 #
110 my $lineNumber;
111
112
113 #
114 #   bool: hasBraceGroups
115 #
116 #   Whether the file has brace groups or not.
117 #
118 my $hasBraceGroups;
119
120
121 #
122 #   array: virtualLines
123 #
124 #   An array of virtual lines if a line from the file contained more than one.
125 #
126 #   Files with brace groups may have more than one virtual line per actual file line, such as "Group: A { Group: B".  When that
127 #   happens, any extra virtual lines are put into here so they can be returned on the next call.
128 #
129 my @virtualLines;
130
131
132
133 ###############################################################################
134 # Group: Functions
135
136
137 #
138 #   Function: Open
139 #
140 #   Opens a configuration file for parsing and returns the format <VersionInt>.
141 #
142 #   Parameters:
143 #
144 #       file - The <FileName> to parse.
145 #       hasBraceGroups - Whether the file supports brace groups or not.  If so, lines with braces will be split apart behind the
146 #                                  scenes.
147 #
148 #   Returns:
149 #
150 #       The <VersionInt> of the file, or undef if the file doesn't exist.
151 #
152 sub Open #(file, hasBraceGroups)
153     {
154     my $self;
155     ($self, $file, $hasBraceGroups) = @_;
156
157     @errors = ( );
158
159     # It will be incremented to one when the first line is read from the file.
160     $lineNumber = 0;
161
162     open(CONFIG_FILEHANDLE, '<' . $file) or return undef;
163     $lineReader = NaturalDocs::LineReader->New(\*CONFIG_FILEHANDLE);
164
165
166     # Get the format line.
167
168     my ($keyword, $value, $comment) = $self->GetLine();
169
170     if ($keyword eq 'format')
171         {  return NaturalDocs::Version->FromString($value);  }
172     else
173         {  die "The first content line in " . $file . " must be the Format: line.\n";  };
174     };
175
176
177 #
178 #   Function: Close
179 #
180 #   Closes the current configuration file.
181 #
182 sub Close
183     {
184     my $self = shift;
185     close(CONFIG_FILEHANDLE);
186     };
187
188
189 #
190 #   Function: GetLine
191 #
192 #   Returns the next line containing content, or an empty array if none.
193 #
194 #   Returns:
195 #
196 #       Returns the array ( keyword, value, comment ), or an empty array if none.  All tabs will be converted to spaces, and all
197 #       whitespace will be condensed into a single space.
198 #
199 #       keyword - The keyword part of the line, if any.  Is converted to lowercase and doesn't include the colon.  If the file supports
200 #                       brace groups, opening and closing braces will be returned as keywords.
201 #       value - The value part of the line, minus any whitespace.  Keeps its original case.
202 #       comment - The comment following the line, if any.  This includes the # symbol and a leading space if there was
203 #                       any whitespace, since it may be significant.  Otherwise undef.  Used for lines where the # character needs to be
204 #                       accepted as part of the value.
205 #
206 sub GetLine
207     {
208     my $self = shift;
209
210     my ($line, $comment);
211
212
213     # Get the next line with content.
214
215     do
216         {
217         # Get the next line.
218
219         my $isFileLine;
220
221         if (scalar @virtualLines)
222             {
223             $line = shift @virtualLines;
224             $isFileLine = 0;
225             }
226         else
227             {
228             $line = $lineReader->Get();
229             $lineNumber++;
230
231             if (!defined $line)
232                 {  return ( );  };
233
234             # Condense spaces and tabs into a single space.
235             $line =~ tr/\t /  /s;
236             $isFileLine = 1;
237             };
238
239
240         # Split off the comment.
241
242         if ($line =~ /^(.*?)( ?#.*)$/)
243             {  ($line, $comment) = ($1, $2);  }
244         else
245             {  $comment = undef;  };
246
247
248         # Split any brace groups.
249
250         if ($isFileLine && $hasBraceGroups && $line =~ /[\{\}]/)
251             {
252             ($line, @virtualLines) = split(/([\{\}])/, $line);
253
254             $virtualLines[-1] .= $comment;
255             $comment = undef;
256             };
257
258
259         # Remove whitespace.
260
261         $line =~ s/^ //;
262         $line =~ s/ $//;
263         $comment =~ s/ $//;
264         # We want to keep the leading space on a comment.
265         }
266     while (!$line);
267
268
269     # Process the line.
270
271     if ($hasBraceGroups && ($line eq '{' || $line eq '}'))
272         {
273         return ($line, undef, undef);
274         };
275
276
277     if ($line =~ /^([a-z0-9\ \'\/\.\-]+?) ?: ?(.*)$/i) # [CFChars]
278         {
279         my ($keyword, $value) = ($1, $2);
280         return (lc($keyword), $value, $comment);
281         }
282
283     else
284         {
285         return (undef, $line, $comment);
286         };
287     };
288
289
290 #
291 #   Function: LineNumber
292 #
293 #   Returns the line number for the line last returned by <GetLine()>.
294 #
295 sub LineNumber
296     {  return $lineNumber;  };
297
298
299
300 ###############################################################################
301 # Group: Error Functions
302
303
304 #
305 #   Function: AddError
306 #
307 #   Stores an error for the current configuration file.  Will be attached to the last line read by <GetLine()>.
308 #
309 #   Parameters:
310 #
311 #       message - The error message.
312 #       lineNumber - The line number to use.  If not specified, it will use the line number from the last call to <GetLine()>.
313 #
314 sub AddError #(message, lineNumber)
315     {
316     my ($self, $message, $messageLineNumber) = @_;
317
318     if (!defined $messageLineNumber)
319         {  $messageLineNumber = $lineNumber;  };
320
321     push @errors, $messageLineNumber, $message;
322     };
323
324
325 #
326 #   Function: ErrorCount
327 #
328 #   Returns how many errors the configuration file has.
329 #
330 sub ErrorCount
331     {
332     return (scalar @errors) / 2;
333     };
334
335
336 #
337 #   Function: PrintErrorsAndAnnotateFile
338 #
339 #   Prints the errors to STDERR in the standard GNU format and annotates the configuration file with them.  It does *not* end
340 #   execution.  <Close()> *must* be called before this function.
341 #
342 sub PrintErrorsAndAnnotateFile
343     {
344     my ($self) = @_;
345
346     if (scalar @errors)
347         {
348         open(CONFIG_FILEHANDLE, '<' . $file);
349
350         my $lineReader = NaturalDocs::LineReader->New(\*CONFIG_FILEHANDLE);
351         my @lines = $lineReader->GetAll();
352
353         close(CONFIG_FILEHANDLE);
354
355         # We need to keep track of both the real and the original line numbers.  The original line numbers are for matching errors in
356         # the errors array, and don't include any comment lines added or deleted.  Line number is the current line number including
357         # those comment lines for sending to the display.
358         my $lineNumber = 1;
359         my $originalLineNumber = 1;
360
361         open(CONFIG_FILEHANDLE, '>' . $file);
362
363         # We don't want to keep the old error header, if present.
364         if ($lines[0] =~ /^\# There (?:is an error|are \d+ errors) in this file\./)
365             {
366             shift @lines;
367             $originalLineNumber++;
368
369             # We want to drop the blank line after it as well.
370             if ($lines[0] eq "\n")
371                 {
372                 shift @lines;
373                 $originalLineNumber++;
374                 };
375             };
376
377         if ($self->ErrorCount() == 1)
378             {
379             print CONFIG_FILEHANDLE
380             "# There is an error in this file.  Search for ERROR to find it.\n\n";
381             }
382         else
383             {
384             print CONFIG_FILEHANDLE
385             "# There are " . $self->ErrorCount() . " errors in this file.  Search for ERROR to find them.\n\n";
386             };
387
388         $lineNumber += 2;
389
390
391         foreach my $line (@lines)
392             {
393             while (scalar @errors && $originalLineNumber == $errors[0])
394                 {
395                 my $errorLine = shift @errors;
396                 my $errorMessage = shift @errors;
397
398                 print CONFIG_FILEHANDLE "# ERROR: " . $errorMessage . "\n";
399
400                 # Use the GNU error format, which should make it easier to handle errors when Natural Docs is part of a build process.
401                 # See http://www.gnu.org/prep/standards_15.html
402
403                 $errorMessage = lcfirst($errorMessage);
404                 $errorMessage =~ s/\.$//;
405
406                 print STDERR 'NaturalDocs:' . $file . ':' . $lineNumber . ': ' . $errorMessage . "\n";
407
408                 $lineNumber++;
409                 };
410
411             # We want to remove error lines from previous runs.
412             if (substr($line, 0, 9) ne '# ERROR: ')
413                 {
414                 print CONFIG_FILEHANDLE $line;
415                 $lineNumber++;
416                 };
417
418             $originalLineNumber++;
419             };
420
421         # Clean up any remaining errors.
422         while (scalar @errors)
423             {
424             my $errorLine = shift @errors;
425             my $errorMessage = shift @errors;
426
427             print CONFIG_FILEHANDLE "# ERROR: " . $errorMessage . "\n";
428
429             # Use the GNU error format, which should make it easier to handle errors when Natural Docs is part of a build process.
430             # See http://www.gnu.org/prep/standards_15.html
431
432             $errorMessage = lcfirst($errorMessage);
433             $errorMessage =~ s/\.$//;
434
435             print STDERR 'NaturalDocs:' . $file . ':' . $lineNumber . ': ' . $errorMessage . "\n";
436             };
437
438         close(CONFIG_FILEHANDLE);
439         };
440     };
441
442
443
444 ###############################################################################
445 # Group: Misc Functions
446
447
448 #
449 #   Function: HasOnlyCFChars
450 #
451 #   Returns whether the passed string contains only <CFChars>.
452 #
453 sub HasOnlyCFChars #(string)
454     {
455     my ($self, $string) = @_;
456     return ($string =~ /^[a-z0-9\ \.\-\/\']*$/i);  # [CFChars]
457     };
458
459
460 #
461 #   Function: CFCharNames
462 #
463 #   Returns a plain-english list of <CFChars> which can be embedded in a sentence.  For example, "You can only use
464 #   [CFCharsList()] in the name.
465 #
466 sub CFCharNames
467     {
468     # [CFChars]
469     return 'letters, numbers, spaces, periods, dashes, slashes, and apostrophes';
470     };
471
472
473 #
474 #   Function: Obscure
475 #
476 #   Obscures the passed text so that it is not user editable and returns it.  The encoding method is not secure; it is just designed
477 #   to be fast and to discourage user editing.
478 #
479 sub Obscure #(text)
480     {
481     my ($self, $text) = @_;
482
483     # ` is specifically chosen to encode to space because of its rarity.  We don't want a trailing one to get cut off before decoding.
484     $text =~ tr{a-zA-Z0-9\ \\\/\.\:\_\-\`}
485                     {pY9fGc\`R8lAoE\\uIdH6tN\/7sQjKx0B5mW\.vZ41PyFg\:CrLaO\_eUi2DhT\-nSqJkXb3MwVz\ };
486
487     return $text;
488     };
489
490
491 #
492 #   Function: Unobscure
493 #
494 #   Restores text encoded with <Obscure()> and returns it.
495 #
496 sub Unobscure #(text)
497     {
498     my ($self, $text) = @_;
499
500     $text =~ tr{pY9fGc\`R8lAoE\\uIdH6tN\/7sQjKx0B5mW\.vZ41PyFg\:CrLaO\_eUi2DhT\-nSqJkXb3MwVz\ }
501                     {a-zA-Z0-9\ \\\/\.\:\_\-\`};
502
503     return $text;
504     };
505
506
507
508 1;