ViewVC Help
View File | Revision Log | Show Annotations | View Changeset | Root Listing
root/group/trunk/OOPSE-4/scripts/filepp
Revision: 1538
Committed: Wed Oct 6 22:19:33 2004 UTC (19 years, 9 months ago) by tim
File size: 89721 byte(s)
Log Message:
filepp can handle different fortran module case and suffix

File Contents

# Content
1 #!/usr/bin/perl -w
2 ########################################################################
3 #
4 # filepp is free software; you can redistribute it and/or modify
5 # it under the terms of the GNU General Public License as published by
6 # the Free Software Foundation; either version 2 of the License, or
7 # (at your option) any later version.
8 #
9 # This program is distributed in the hope that it will be useful,
10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 # GNU General Public License for more details.
13 #
14 # You should have received a copy of the GNU General Public License
15 # along with this program; see the file COPYING. If not, write to
16 # the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
17 #
18 ########################################################################
19 #
20 # Project : File Preprocessor
21 # Filename : $RCSfile: filepp,v $
22 # Author : $Author: tim $
23 # Maintainer : Darren Miller: darren@cabaret.demon.co.uk
24 # File version : $Revision: 1.3 $
25 # Last changed : $Date: 2004-10-06 22:19:33 $
26 # Description : Main program
27 # Licence : GNU copyleft
28 #
29 ########################################################################
30
31 package Filepp;
32
33 use strict "vars";
34 use strict "subs";
35 #use Graph;
36 # Used to all filepp to work with any char, not just ascii,
37 # feel free to remove this if it causes you problems
38 use bytes;
39
40 # version number of program
41 my $VERSION = '1.7.1';
42
43 # list of paths to search for modules, normal Perl list + module dir
44 push(@INC, "/home/maul/gezelter/tim/code/OOPSE-2.0/scripts/filepp-1.7.1/modules/f90dpend/");
45
46 # index of keywords supported and functions to deal with them
47 my %Keywords = (
48 '#comment' => \&Comment,
49 '#define' => \&Define,
50 '#elif' => \&Elif,
51 '#else' => \&Else,
52 '#endif' => \&Endif,
53 '#error' => \&Error,
54 '#if' => \&If,
55 '#ifdef' => \&Ifdef,
56 '#ifndef' => \&Ifndef,
57 '#include' => \&Include,
58 '#pragma' => \&Pragma,
59 '#undef' => \&Undef,
60 '#warning' => \&Warning
61 );
62
63 # set of functions which process the file in the Parse routine.
64 # Processors are functions which take in a line and return the processed line.
65 # Note: this is done as a string rather than pointer to a function because
66 # it makes list easier to modify/remove from/print.
67 my @Processors = ( "Filepp::ParseKeywords", "Filepp::ReplaceDefines" );
68 # processor types say what the processor should be run on: choice is:
69 # 0: Everything (default)
70 # 1: Full lines only (lines originating from Parse function)
71 # 2: Part lines only (lines originating from within keywords, eg:
72 # #if "condition", "condition" is a part line)
73 my %ProcessorTypes = (
74 'Filepp::ParseKeywords' => 1,
75 'Filepp::ReplaceDefines' => 0
76 );
77
78 # functions to run each time a new base input file is opened or closed
79 my @OpenInputFuncs = ();
80 my @CloseInputFuncs = ();
81
82 # functions to run each time a new output file is opened or closed
83 my @OpenOutputFuncs = ();
84 my @CloseOutputFuncs = ();
85
86 # safe mode is for the paranoid, when enabled turns off #pragma filepp,
87 # enabled by default
88 my $safe_mode = 0;
89
90 # test for shebang mode, used for "filepp script", ie. executable file with
91 # "#!/usr/bin/perl /usr/local/bin/filepp" at the top
92 my $shebang = 1;
93
94 # allow $keywordchar, $contchar, $optlineendchar and $macroprefix
95 # to be perl regexps
96 my $charperlre = 0;
97
98 # character(s) which prefix environment variables - defaults to shell-style '$'
99 my $envchar = "\$";
100
101 # boolean determining whether line continuation is implicit if there are more
102 # open brackets than close brackets on a line
103 # disabled by default
104 my $parselineend = \&Filepp::ParseLineEnd;
105
106 # character(s) which replace continuation char(s) - defaults to C-style nothing
107 my $contrepchar = "";
108
109 # character(s) which prefix keywords - defaults to C-style '#'
110 my $keywordchar;
111 if($charperlre) { $keywordchar = "\#"; }
112 else { $keywordchar = "\Q#\E"; }
113
114 # character(s) which signifies continuation of a line - defaults to C-style '\'
115 my $contchar;
116 if($charperlre) { $contchar = "\\\\"; }
117 else { $contchar = "\Q\\\E"; }
118
119 # character(s) which optionally signifies the end of a line -
120 # defaults to empty string ''
121 my $optlineendchar = "";
122
123 # character(s) which prefix macros - defaults to nothing
124 my $macroprefix = "";
125
126 # flag to use macro prefix in keywords (on by default)
127 my $macroprefixinkeywords = 1;
128
129 # check if macros must occur as words when replacing, set this to '\b' if
130 # you prefer cpp style behaviour as default
131 my $bound = '';
132
133 # number of line currently being parsed (int)
134 my $line = 0;
135
136 # file currently being parsed
137 my $file = "";
138
139 # list of input files
140 my @Inputfiles;
141
142 # list of files to include macros from
143 my @Imacrofiles;
144
145 # flag to control when output is written
146 my $output = 1;
147
148 # name of outputfile - defaults to STDOUT
149 my $outputfile = "";
150
151 # overwrite mode - automatically overwrites old file with new file
152 my $overwrite = 0;
153
154 # overwrite conversion mode - conversion from input filename to output filename
155 my $overwriteconv = "";
156
157 # list of keywords which have "if" functionality
158 my %Ifwords = ('#if', '',
159 '#ifdef', '',
160 '#ifndef', '');
161
162 # list of keywords which have "else" functionality
163 my %Elsewords = ('#else', '',
164 '#elif', '');
165
166 # list of keywords which have "endif" functionality
167 my %Endifwords = ('#endif', '');
168
169 # current level of include files
170 my $include_level = -1;
171
172 # suppress blank lines in header files (indexed by include level)
173 my $blanksuppopt = 0;
174 my @blanksupp;
175 # try to keep same number lines in output file as input file
176 my $preserveblank = 0;
177
178 # counter of recursion level for detecting recursive macros
179 my $recurse_level = -1;
180
181 # debugging info, 1=on, 0=off
182 my $debug = 0;
183 # send debugging info to stdout rather than stderr
184 my $debugstdout = 0;
185 # debug prefix character or string
186 my $debugprefix = "";
187 # debug postfix character or string
188 my $debugpostfix = "\n";
189
190 # hash of macros defined - standard ones already included
191 my %Defines = (
192 '__BASE_FILE__' => "",
193 '__DATE__' => "",
194 '__FILEPP_INPUT__' => "Generated automatically from __BASE_FILE__ by filepp",
195 '__FILE__' => $file,
196 '__INCLUDE_LEVEL__' => $include_level,
197 '__ISO_DATE__' => "",
198 '__LINE__' => $line,
199 '__NEWLINE__' => "\n",
200 '__NULL__' => "",
201 '__TAB__' => "\t",
202 '__TIME__' => "",
203 '__VERSION__' => $VERSION
204 );
205 # hash of first chars in each macro
206 my %DefineLookup;
207 # length of longest and shortest define
208 my ($defmax, $defmin);
209 GenerateDefinesKeys();
210
211 # set default values for date and time
212 {
213 # conversions of month number into letters (0-11)
214 my @MonthChars = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
215 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
216 #prepare standard defines
217 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isbst) =
218 localtime(time());
219 $year += 1900;
220 $sec = sprintf("%02d", $sec);
221 $min = sprintf("%02d", $min);
222 $hour = sprintf("%02d", $hour);
223 $mday = sprintf("%02d", $mday);
224 $mon = sprintf("%02d", $mon);
225 Redefine("__TIME__", $hour.":".$min.":".$sec);
226 Redefine("__DATE__", $MonthChars[$mon]." ".$mday." ".$year);
227 $mon = sprintf("%02d", ++$mon);
228 Redefine("__ISO_DATE__", $year."-".$mon."-".$mday);
229 }
230
231 # hash table for arguments to macros which need them
232 my %DefinesArgs = ();
233
234 # hash table for functions which macros should call (if any)
235 my %DefinesFuncs = ();
236
237 # eat-trailing-whitespace flag for each macro
238 my %EatTrail = ();
239
240 # list of include paths
241 my @IncludePaths;
242
243 # help string
244 my $usage = "filepp: generic file preprocessor, version ".$VERSION."
245 usage: filepp [options] inputfile(s)
246 options:
247 -b\t\tsuppress blank lines from include files
248 -c\t\tread input from STDIN instead of file
249 -Dmacro[=defn]\tdefine macros (same as #define)
250 -d\t\tprint debugging information
251 -dd\t\tprint verbose debugging information
252 -dl\t\tprint some (light) debugging information
253 -dpre char\tprefix all debugging information with char
254 -dpost char\tpostfix all debugging information with char, defaults to newline
255 -ds\t\tsend debugging info to stdout rather than stderr
256 -e\t\tdefine all environment variables as macros
257 -ec char\tset environment variable prefix char to \"char\" (default \$)
258 -ecn\t\tset environment variable prefix char to nothing (default \$)
259 -h\t\tprint this help message
260 -Idir\t\tdirectory to search for include files
261 -imacros file\tread in macros from file, but discard rest of file
262 -k\t\tturn off parsing of all keywords, just macro expansion is done
263 -kc char\tset keyword prefix char to \"char\" (defaults to #)
264 -lc char\tset line continuation character to \"char\" (defaults to \\)
265 -lec char\tset optional keyword line end char to \"char\"
266 -lr char\tset line continuation replacement character to \"char\"
267 -lrn\t\tset line continuation replacement character to newline
268 -m module\tload module
269 -mp char\tprefix all macros with \"char\" (defaults to no prefix)
270 -mpnk\t\tdo not use macro prefix char in keywords
271 -Mdir\t\tdirectory to search for filepp modules
272 -o output\tname of output file (defaults to stdout)
273 -ov\t\toverwrite mode - output file will overwrite input file
274 -ovc IN=OUT\toutput file(s) will have be input file(s) with IN conveted to OUT
275 -pb\t\tpreseve blank lines in output that would normally be removed
276 -s\t\trun in safe mode (turns off pragma keyword)
277 -re\t\ttreat keyword and macro prefixes and line cont chars as reg exps
278 -u\t\tundefine all predefined macros
279 -v\t\tprint version and exit
280 -w\t\tturn on word boundaries when replacing macros
281 all other arguments are assumed to be input files
282 ";
283
284 # graph for dependency files
285 my $dependencyGraph;
286
287 # visited table
288 my %visitedTable = ();
289
290 #object directory
291 my $objDir ="";
292
293 # f90moduleList
294 my %parsedModList = ();
295
296 #
297 my %f90ModList = ();
298
299 # suffix of fortran object file
300 my $objExt = '.o';
301
302 # suffix of fortran 90 module
303 my $modSuffix = "mod";
304
305 # case of basename of fortran 90 module
306 my $modBasenameCase = "lower";
307 ##############################################################################
308 # SetDebug - controls debugging level
309 ##############################################################################
310 sub SetDebug
311 {
312 $debug = shift;
313 Debug("Debugging level set to $debug", 1);
314 }
315
316
317 ##############################################################################
318 # Debugging info
319 ##############################################################################
320 sub Debug
321 {
322 # print nothing if not debugging
323 if($debug == 0) { return; }
324 my $msg = shift;
325 my $level = 1;
326 # check if level has been provided
327 if($#_ > -1) { $level = shift; }
328 if($level <= $debug) {
329 # if currently parsing a file show filename and line number
330 if($file ne "" && $line > 0) {
331 $msg = $file.":".$line.": ".$msg;
332 }
333 # else show program name
334 else { $msg = "filepp: ".$msg; }
335 if($debugstdout) {
336 print(STDOUT $debugprefix.$msg.$debugpostfix);
337 }
338 else {
339 print(STDERR $debugprefix.$msg.$debugpostfix);
340 }
341 }
342 }
343
344
345 ##############################################################################
346 # Standard error handler.
347 # #error msg - print error message "msg" and exit
348 ##############################################################################
349 sub Error
350 {
351 my $msg = shift;
352 # close and delete output file if created
353 close(OUTPUT);
354 if($outputfile ne "-") { # output is not stdout
355 my $inputfile;
356 my $found = 0;
357 # do paranoid check to make sure we are not deleting an input file
358 foreach $inputfile (@Inputfiles) {
359 if($outputfile eq $inputfile) { $found = 1; last; }
360 }
361 # delete output file
362 if($found == 0) { unlink($outputfile); }
363 }
364 # print error message
365 $debug = 1;
366 Debug($msg, 0);
367 exit(1);
368 }
369
370
371 ##############################################################################
372 # SafeMode - turns safe mode on
373 ##############################################################################
374 sub SafeMode
375 {
376 $safe_mode = 1;
377 Debug("Filepp safe mode enabled", 2);
378 }
379
380
381 ##############################################################################
382 # CleanStart($sline) - strip leading whitespace from start of $sline.
383 ##############################################################################
384 sub CleanStart
385 {
386 my $sline = shift;
387 for($sline) {
388 # '^' = start of line, '\s+' means all whitespace, replace with nothing
389 s/^\s+//;
390 }
391 return $sline;
392 }
393
394
395 ##############################################################################
396 # Strip($sline, $char, $level) - strip $char's from start and end of $sline
397 # removes up to $level $char's from start and end of line, it is not an
398 # error if $level chars do not exist at the start or end of line
399 ##############################################################################
400 sub Strip
401 {
402 my $sline = shift;
403 my $char = shift;
404 my $level = shift;
405 # strip leading chars from line
406 $sline =~ s/\A([$char]{0,$level})//g;
407 # strip trailing chars from line
408 $sline =~ s/([$char]{0,$level})\Z//g;
409 return $sline;
410 }
411
412
413 ##############################################################################
414 # SetMacroPrefix $string - prefixs all macros with $string
415 ##############################################################################
416 sub SetMacroPrefix
417 {
418 $macroprefix = shift;
419 # make sure prefix will not be treated as a Perl regular expression
420 if(!$charperlre) { $macroprefix = "\Q$macroprefix\E"; }
421 Debug("Setting macro prefix to <".$macroprefix.">", 2);
422 }
423
424
425 ##############################################################################
426 # SetKeywordchar $string - sets the first char(s) of each keyword to
427 # something other than "#"
428 ##############################################################################
429 sub SetKeywordchar
430 {
431 $keywordchar = shift;
432 # make sure char will not be treated as a Perl regular expression
433 if(!$charperlre) { $keywordchar = "\Q$keywordchar\E"; }
434 Debug("Setting keyword prefix character to <".$keywordchar.">", 2);
435 }
436
437 ##############################################################################
438 # GetKeywordchar - returns the current keywordchar
439 ##############################################################################
440 sub GetKeywordchar
441 {
442 return $keywordchar;
443 }
444
445
446 ##############################################################################
447 # SetContchar $string - sets the line continuation char to something other
448 # than "\"
449 ##############################################################################
450 sub SetContchar
451 {
452 $contchar = shift;
453 # make sure char will not be treated as a Perl regular expression
454 if(!$charperlre) { $contchar = "\Q$contchar\E"; }
455 Debug("Setting line continuation character to <".$contchar.">", 2);
456 }
457
458
459 ##############################################################################
460 # SetContrepchar $string - sets the replace of the line continuation char to
461 # something other than ""
462 ##############################################################################
463 sub SetContrepchar
464 {
465 $contrepchar = shift;
466 Debug("Setting line continuation replacement character to <".$contrepchar.">", 2);
467 }
468
469
470 ##############################################################################
471 # SetOptLineEndchar $string - sets the optional line end char to something
472 # other than ""
473 ##############################################################################
474 sub SetOptLineEndchar
475 {
476 $optlineendchar = shift;
477 # make sure char will not be treated as a Perl regular expression
478 if(!$charperlre) { $optlineendchar = "\Q$optlineendchar\E"; }
479 Debug("Setting optional line end character to <".$optlineendchar.">", 2);
480 }
481
482
483 ##############################################################################
484 # SetEnvchar $string - sets the first char(s) of each defined environment
485 # variable to $string - NOTE: change only takes effect when DefineEnv run
486 ##############################################################################
487 sub SetEnvchar
488 {
489 $envchar = shift;
490 Debug("Setting environment variable prefix character to <".$envchar.">",2);
491 }
492
493 ##############################################################################
494 # RunProcessors $string, $calledfrom
495 # run the current processing chain on the string
496 # $string is the string to be processed and should be returned by the processor
497 # $calledfrom says where the processors are called from, the choice is:
498 #
499 # 0 or default: Part line (from within a keyword) - if called recursively
500 # runs all processors AFTER current processor, then continues with processing.
501 # This is used when a keyword want to run all remaining processors on a line
502 # before doing its keyword task.
503 #
504 # 1: Full line (from Parse function) - if called recursively runs all
505 # processors BEFORE current processor, then continues with processing
506 #
507 # 2: Part line (from within a keyword) - if called recursively runs all
508 # processors BEFORE current processor, then continues with processing.
509 # This is used when keywords are using text taken from somewhere other than
510 # the current line, this text needs to go through the same processors as
511 # the current line has been through so it can "catch up" (eg: regexp.pm).
512 #
513 ##############################################################################
514 my @Running;
515 my @Currentproc;
516 sub RunProcessors
517 {
518 my $string = shift;
519 my $calledfrom = 0;
520 if($#_ > -1) { $calledfrom = shift; }
521 my $i;
522
523 # turn off macoprefix if in a keyword
524 my $tmpprefix = "";
525 if($calledfrom != 1 && $macroprefixinkeywords == 0) {
526 $tmpprefix = $macroprefix;
527 $macroprefix = "";
528 }
529
530 # These tests are done to make RunProcessors recursion safe.
531 # If RunProcessors is called from with a function that was itself called
532 # by RunProcessors, then the second calling of RunProcessors will only
533 # execute the processors before the currently running processor in the
534 # chain.
535 my $recursing = 0;
536 my $firstproc = 0;
537 my $lastproc = $#Processors;
538 if($Running[$include_level]) {
539 if($calledfrom == 0) {
540 $firstproc = $Currentproc[$include_level] + 1;
541 }
542 else {
543 $lastproc = $Currentproc[$include_level] - 1;
544 }
545 $recursing = 1;
546 }
547 else { $Running[$include_level] = 1; }
548
549 for($i = $firstproc; $i <= $lastproc; $i++) {
550 if(!$recursing) { $Currentproc[$include_level] = $i; }
551 # called from anywhere (default)
552 if($ProcessorTypes{$Processors[$i]} == 0 ||
553 # called from keyword (part lines only - within keywords)
554 (($calledfrom == 0 || $calledfrom == 2) &&
555 $ProcessorTypes{$Processors[$i]} == 2) ||
556 # called from Parse function (whole lines only)
557 ($calledfrom == 1 && $ProcessorTypes{$Processors[$i]} == 1)) {
558 # run processor
559 # Debug("Running processor $Processors[$i] on \"$string\"", 2);
560 $string = $Processors[$i]->($string);
561 }
562 # check that no processors have been deleted (bigdef.pm)
563 if($lastproc > $#Processors) { $lastproc = $#Processors; }
564 }
565
566 if(!$recursing) { $Running[$include_level] = 0; }
567
568 # return macro prefix to its former glory
569 if($calledfrom != 1 && $macroprefixinkeywords == 0) {
570 $macroprefix = $tmpprefix;
571 }
572
573 return $string;
574 }
575
576 ##############################################################################
577 # PrintProcessors
578 # print the current processing chain
579 ##############################################################################
580 sub PrintProcessors
581 {
582 my $processor;
583 Debug("Current processing chain:", 3);
584 my $i = 0;
585 foreach $processor (@Processors) {
586 Debug($processor." type ".$ProcessorTypes{$Processors[$i]}, 3);
587 $i++;
588 }
589 }
590
591 ##############################################################################
592 # AddProcessor(function[, first[, type]])
593 # add a line processor to processing chain, defaults to end of chain
594 # if "first" is set to one adds processor to start of chain
595 ##############################################################################
596 sub AddProcessor
597 {
598 my $function = shift;
599 my $first = 0;
600 my $type = 0;
601 # check if flag to add processor to start of chain is set
602 if($#_ > -1) { $first = shift; }
603 # check if processor has a type
604 if($#_ > -1) { $type = shift; }
605 # adding processor to start of chasin
606 if($first) {
607 @Processors = reverse(@Processors);
608 }
609 push(@Processors, $function);
610 if($first) {
611 @Processors = reverse(@Processors);
612 }
613 $ProcessorTypes{$function} = $type;
614 Debug("Added processor ".$function." of type ".$type, 2);
615 if($debug > 1) { PrintProcessors(); }
616 }
617
618 ##############################################################################
619 # AddProcessorAfter(function, processor[, type])
620 # add a line processor to processing chain immediately after an existing
621 # processor, if existing processor not found, new processor is added to
622 # end of chain
623 ##############################################################################
624 sub AddProcessorAfter
625 {
626 my $function = shift;
627 my $existing = shift;
628 my $type = 0;
629 # check if processor has a type
630 if($#_ > -1) { $type = shift; }
631 my $i = 0;
632 my $found = 0;
633 my @CurrentProcessors = @Processors;
634 my $processor;
635 # reset processing chain
636 @Processors = ();
637 foreach $processor (@CurrentProcessors) {
638 push(@Processors, $processor);
639 if(!$found) {
640 # check done as regular expression for greater flexibility
641 if($processor =~ /$existing/) {
642 push(@Processors, $function);
643 $found = 1;
644 }
645 }
646 }
647 if(!$found) {
648 Warning("Did not find processor $existing in chain, processor $processor added to end of list");
649 AddProcessor($function, 0, $type);
650 return;
651 }
652 $ProcessorTypes{$function} = $type;
653 Debug("Added processor ".$function." of type ".$type, 2);
654 if($debug > 1) { PrintProcessors(); }
655 }
656
657 ##############################################################################
658 # AddProcessorBefore(function, processor[, type])
659 # add a line processor to processing chain immediately after an existing
660 # processor, if existing processor not found, new processor is added to
661 # end of chain
662 ##############################################################################
663 sub AddProcessorBefore
664 {
665 my $function = shift;
666 my $existing = shift;
667 my $type = 0;
668 # check if processor has a type
669 if($#_ > -1) { $type = shift; }
670 my $i = 0;
671 my $found = 0;
672 my @CurrentProcessors = @Processors;
673 my $processor;
674 # reset processing chain
675 @Processors = ();
676 foreach $processor (@CurrentProcessors) {
677 if(!$found) {
678 # check done as regular expression for greater flexibility
679 if($processor =~ /$existing/) {
680 push(@Processors,$function);
681 $found = 1;
682 }
683 }
684 push(@Processors, $processor);
685 }
686 if(!$found) {
687 Warning("Did not find processor $existing in chain, processor $processor added to start of list");
688 AddProcessor($function, 1, $type);
689 return;
690 }
691 $ProcessorTypes{$function} = $type;
692 Debug("Added processor ".$function." of type ".$type, 2);
693 if($debug > 1) { PrintProcessors(); }
694 }
695
696 ##############################################################################
697 # RemoveProcessor(function)
698 # remove a processor name "function" from list
699 ##############################################################################
700 sub RemoveProcessor
701 {
702 my $function = shift;
703 my $i = 0;
704 # find function
705 while($i <= $#Processors && $Processors[$i] ne $function) { $i++; }
706 # check function found
707 if($i > $#Processors) {
708 Warning("Attempt to remove function ".$function.
709 " which does not exist");
710 return;
711 }
712 # remove function
713 for(; $i<$#Processors; $i++) {
714 $Processors[$i] = $Processors[$i+1];
715 }
716 pop(@Processors);
717 delete($ProcessorTypes{$function});
718 Debug("Removed processor ".$function, 2);
719 PrintProcessors();
720 }
721
722
723 ##############################################################################
724 # Add a function to run each time a base file is opened
725 ##############################################################################
726 sub AddOpenInputFunc
727 {
728 my $func = shift;
729 push(@OpenInputFuncs, $func);
730 }
731
732 ##############################################################################
733 # Add a function to run each time a base file is closed
734 ##############################################################################
735 sub AddCloseInputFunc
736 {
737 my $func = shift;
738 push(@CloseInputFuncs, $func);
739 }
740
741 ##############################################################################
742 # Add a function to run each time a base file is opened
743 ##############################################################################
744 sub AddOpenOutputFunc
745 {
746 my $func = shift;
747 push(@OpenOutputFuncs, $func);
748 }
749
750 ##############################################################################
751 # Add a function to run each time a base file is closed
752 ##############################################################################
753 sub AddCloseOutputFunc
754 {
755 my $func = shift;
756 push(@CloseOutputFuncs, $func);
757 }
758
759
760 ##############################################################################
761 # AddKeyword(keyword, function)
762 # Define a new keyword, when keyword (preceded by keyword char) is found,
763 # function is run on the remainder of the line.
764 ##############################################################################
765 sub AddKeyword
766 {
767 my $keyword = shift;
768 my $function = shift;
769 $Keywords{$keyword} = $function;
770 Debug("Added keyword ".$keyword." which runs ".$function, 2);
771 }
772
773
774 ##############################################################################
775 # RemoveKeyword(keyword)
776 # Keyword is deleted from list, all occurrences of keyword found in
777 # document are ignored.
778 ##############################################################################
779 sub RemoveKeyword
780 {
781 my $keyword = shift;
782 delete $Keywords{$keyword};
783 # sort keywords index into reverse order, this ensures #if[n]def comes
784 # before #if when comparing input with keywords
785 Debug("Removed keyword ".$keyword, 2);
786 }
787
788
789 ##############################################################################
790 # RemoveAllKeywords - removes all current keywords.
791 ##############################################################################
792 sub RemoveAllKeywords
793 {
794 %Keywords = ();
795 Debug("Removed all current keywords", 2);
796 }
797
798
799 ##############################################################################
800 # AddIfword - adds a keyword to ifword hash
801 ##############################################################################
802 sub AddIfword
803 {
804 my $ifword = shift;
805 $Ifwords{$ifword} = '';
806 Debug("Added Ifword: ".$ifword, 2);
807 }
808
809 ##############################################################################
810 # RemoveIfword - removes a keyword from ifword hash
811 ##############################################################################
812 sub RemoveIfword
813 {
814 my $ifword = shift;
815 delete $Ifwords{$ifword};
816 Debug("Removed Ifword: ".$ifword, 2);
817 }
818
819 ##############################################################################
820 # AddElseword - adds a keyword to elseword hash
821 ##############################################################################
822 sub AddElseword
823 {
824 my $elseword = shift;
825 $Elsewords{$elseword} = '';
826 Debug("Added Elseword: ".$elseword, 2);
827 }
828
829 ##############################################################################
830 # RemoveElseword - removes a keyword from elseword hash
831 ##############################################################################
832 sub RemoveElseword
833 {
834 my $elseword = shift;
835 delete $Elsewords{$elseword};
836 Debug("Removed Elseword: ".$elseword, 2);
837 }
838
839 ##############################################################################
840 # AddEndifword - adds a keyword to endifword hash
841 ##############################################################################
842 sub AddEndifword
843 {
844 my $endifword = shift;
845 $Endifwords{$endifword} = '';
846 Debug("Added Endifword: ".$endifword, 2);
847 }
848
849 ##############################################################################
850 # RemoveEndifword - removes a keyword from endifword hash
851 ##############################################################################
852 sub RemoveEndifword
853 {
854 my $endifword = shift;
855 delete $Endifwords{$endifword};
856 Debug("Removed Endifword: ".$endifword, 2);
857 }
858
859
860 ##############################################################################
861 # AddIncludePath - adds another include path to the list
862 ##############################################################################
863 sub AddIncludePath
864 {
865 my $path = shift;
866 push(@IncludePaths, $path);
867 Debug("Added include path: \"".$path."\"", 2);
868 }
869
870
871 ##############################################################################
872 # AddModulePath - adds another module search path to the list
873 ##############################################################################
874 sub AddModulePath
875 {
876 my $path = shift;
877 push(@INC, $path);
878 Debug("Added module path: \"".$path."\"", 2);
879 }
880
881
882 # set if file being written to has same name as input file
883 my $same_file = "";
884
885 ##############################################################################
886 # OpenOutputFile - opens the output file
887 ##############################################################################
888 sub OpenOutputFile
889 {
890 $outputfile = shift;
891 Debug("Output file: ".$outputfile, 1);
892
893 # check for outputfile name, if not specified use STDOUT
894 if($outputfile eq "") { $outputfile = "-"; }
895
896 # output is not stdout and file with that name already exists
897 if($outputfile ne "-" && FileExists($outputfile) ) {
898 $same_file = $outputfile;
899 # paranoid: check file is writable and normal file
900 if(-w $outputfile && -f $outputfile) {
901 $outputfile = $outputfile.".fpp".$$;
902 my $i=0; # paranoid: check temp file does not exist
903 while(FileExists($outputfile)) {
904 $outputfile = $outputfile.$i;
905 $i++;
906 if($i >= 10) { Error("Cound not get temp filename"); }
907 }
908 }
909 else {
910 Error("Cannot read or write to ".$outputfile);
911 }
912 }
913 if(!open(OUTPUT, ">".$outputfile)) {
914 Error("Cannot open output file: ".$outputfile);
915 }
916 # run any open functions
917 my $func;
918 foreach $func (@OpenOutputFuncs) { $func->(); }
919 }
920
921
922 ##############################################################################
923 # CloseOutputFile - close the output file
924 ##############################################################################
925 sub CloseOutputFile
926 {
927 # run any close functions
928 my $func;
929 foreach $func (@CloseOutputFuncs) { $func->(); }
930 close(OUTPUT);
931
932 # if input and output have same name, rename output to input now
933 if($same_file ne "") {
934 if(rename($same_file, $same_file."~") == -1) {
935 Error("Could not rename ".$same_file." ".$same_file."~");
936 }
937 if(rename($outputfile, $same_file) == -1) {
938 Error("Could not rename ".$outputfile." ".$same_file);
939 }
940 }
941 # reset same_file
942 $same_file = "";
943 }
944
945
946 ##############################################################################
947 # ChangeOutputFile - change the output file
948 ##############################################################################
949 sub ChangeOutputFile
950 {
951 CloseOutputFile();
952 $outputfile = shift;
953 OpenOutputFile($outputfile);
954 }
955
956
957 ##############################################################################
958 # AddInputFile - adds another input file to the list
959 ##############################################################################
960 sub AddInputFile
961 {
962 my $file = shift;
963 push(@Inputfiles, $file);
964 Debug("Added input file: \"".$file."\"", 2);
965 }
966
967
968 ##############################################################################
969 # UseModule(module)
970 # Module "module.pm" is used, "module.pm" can be any perl module and can use
971 # or replace any of the functions in this package
972 ##############################################################################
973 sub UseModule
974 {
975 my $module = shift;
976 Debug("Loading module ".$module, 1);
977 require $module;
978 if($@) { Error($@); }
979 }
980
981
982 ##############################################################################
983 # find end of next word in $sline, assumes leading whitespace removed
984 ##############################################################################
985 sub GetNextWordEnd
986 {
987 my $sline = shift;
988 # check for whitespace in this string
989 if($sline =~ /\s/) {
990 # return length of everything up to first whitespace
991 return length($`);
992 }
993 # whitespace not found, return length of the whole string
994 return length($sline);
995 }
996
997
998 ##############################################################################
999 # Print current table of defines - used for debugging
1000 ##############################################################################
1001 sub PrintDefines
1002 {
1003 my $define;
1004 Debug("Current ".$keywordchar."define's:", 3);
1005 foreach $define (keys(%Defines)) {
1006 Debug(" macro:\"".$define."\", definition:\"".$Defines{$define}."\"",3);
1007 }
1008 }
1009
1010
1011 ##############################################################################
1012 # DefineEnv - define's all environment variables to macros, each prefixed
1013 # by $envchar
1014 ##############################################################################
1015 sub DefineEnv
1016 {
1017 my $macro;
1018 Debug("Defining environment variables as macros", 2);
1019 foreach $macro (keys(%ENV)) {
1020 Define($envchar.$macro." ".$ENV{$macro});
1021 }
1022 }
1023
1024
1025 ##############################################################################
1026 # Find out if arguments have been used with macro
1027 ##############################################################################
1028 sub DefineArgsUsed
1029 {
1030 my $string = shift;
1031 # check '(' is first non-whitespace char after macro
1032 if($string =~ /^\s*\(/) {
1033 return 1;
1034 }
1035 return 0;
1036 }
1037
1038
1039 ##############################################################################
1040 # ParseArgs($string) - find the arguments in a string of form
1041 # (arg1, arg2, arg3...) trailing chars
1042 # or
1043 # arg1, arg2, arg3...
1044 ##############################################################################
1045 sub ParseArgs
1046 {
1047 my $string = shift;
1048 $string = CleanStart($string);
1049 my @Chars;
1050 my $char;
1051 # split string into chars (can't use split coz it deletes \n at end)
1052 for($char=0; $char<length($string); $char++) {
1053 push(@Chars, substr($string, $char, 1));
1054 }
1055 my @Args; # list of Args
1056 my $arg = "";
1057 my @Endchar;
1058 # special characters - no processing is done between character pairs
1059 my %SpecialChars = ('(' => ')', '"' => '"', '\'' => '\'');
1060 my $s = -1; # start of chars
1061 my $backslash = 0;
1062 # number of special char pairs to allow
1063 my $pairs = 1;
1064
1065 # deal with first '(' if there (ie func(args) rather than func args)
1066 if($#Chars >= 0 && $Chars[0] eq '(') {
1067 push(@Endchar, ')');
1068 $Chars[0] = '';
1069 $s++;
1070 $pairs++; # ignore this pair of special char pairs
1071 }
1072
1073 # replace args with their values
1074 foreach $char (@Chars) {
1075 # deal with end of special chars, ),",' etc.
1076 if($#Endchar > -1 && $char eq $Endchar[$#Endchar]) {
1077 # if char before this was a backslash, ignore this char
1078 if($backslash) {
1079 chop($arg); # delete backslash from string
1080 }
1081 else {
1082 # pop end char of list and reduce pairs if its a bracket
1083 if(pop(@Endchar) eq ')') { $pairs--; }
1084 }
1085 }
1086 # deal with start of special chars
1087 elsif(exists($SpecialChars{$char})) {
1088 # if char before this was a backslash, ignore this char
1089 if($backslash) {
1090 chop($arg); # delete backslash from string
1091 }
1092 # only start new pair if not already in special char pair
1093 # (not including main args brackets of course)
1094 elsif($#Endchar < $pairs-1) {
1095 push(@Endchar, $SpecialChars{$char});
1096 # need to treat brackets differently for macros within
1097 # macros "this(that(tother)))", otherwise lose track of ()'s
1098 if($char eq '(') { $pairs++; }
1099 }
1100 }
1101 # deal with ',', add arg to list and start search for next one
1102 elsif($#Endchar == $s && $char eq ',') {
1103 # if char before this was a backslash, ignore this char
1104 if($backslash) {
1105 chop($arg); # delete backslash from string
1106 }
1107 else {
1108 push(@Args, CleanStart($arg));
1109 $char = '';
1110 $arg = "";
1111 next;
1112 }
1113 }
1114 # deal \\ with an escaping \ ie. \" or \, or \\
1115 if($char eq '\\') {
1116 if($backslash) { # found \\
1117 $backslash = 0; # second backslash ignored
1118 chop($arg); # delete backslash from string
1119 }
1120 else{$backslash = 1;}
1121 }
1122 elsif($backslash) { $backslash = 0; }
1123 # check for end of args string
1124 if($#Endchar < $s) {
1125 push(@Args, CleanStart($arg));
1126 $char = '';
1127 # put remainder of string back together
1128 $arg = join('', @Chars);
1129 last;
1130 }
1131 $arg = $arg.$char; # add char to current arg
1132 $char = ''; # set char to null
1133 }
1134
1135 # deal with last arg or string following args if it exists
1136 push(@Args, $arg);
1137
1138 return @Args;
1139 }
1140
1141
1142 ##############################################################################
1143 # Find the arguments in a macro and replace them
1144 ##############################################################################
1145 sub FindDefineArgs
1146 {
1147 my $substring = shift;
1148 my $macro = shift;
1149
1150 # get definition list for this macro
1151 my @Argnames = split(/\,/, $DefinesArgs{$macro});
1152
1153 # check to see if macro can have any number of arguments (last arg ...)
1154 my $anyargs = ($#Argnames >= 0 && $Argnames[$#Argnames] =~ /\.\.\.\Z/o);
1155
1156 # get arguments passed to this macro
1157 my @Argvals = ParseArgs($substring);
1158 # everything following macro args should be returned as tail
1159 my $tail = pop(@Argvals);
1160
1161 # check the right number of args have been passed, should be all args
1162 # present plus string at end of args (assuming macro cannot have any number
1163 # of arguments)
1164 if(!$anyargs && $#Argvals != $#Argnames) {
1165 # show warning if wrong args (unless macro should have zero args and
1166 # 1 arg provided which is blank space
1167 if(!($#Argnames == -1 && $#Argvals == 0 && $Argvals[0] =~ /\A\s*\Z/)) {
1168 Warning("Macro \'".$macro."\' used with ".$#Argvals.
1169 " args, expected ".($#Argnames+1));
1170 }
1171 # delete all excess args
1172 while($#Argvals > $#Argnames) { pop(@Argvals); }
1173 }
1174 # make all missing args blanks
1175 while($#Argvals < $#Argnames) { push(@Argvals, ""); }
1176
1177 return (@Argvals, $tail);
1178 }
1179
1180
1181 ##############################################################################
1182 # FunctionMacro: used with functions to inform a module which macro
1183 # was being replaced when the function was called - used in bigfunc.pm
1184 ##############################################################################
1185 my $functionmacro = "";
1186 sub FunctionMacro
1187 {
1188 return $functionmacro;
1189 }
1190
1191
1192 ##############################################################################
1193 # Replace all defined macro's arguments with their values
1194 # Inputs:
1195 # $macro = the macro to be replaces
1196 # $string = the string following the occurrence of macro
1197 ##############################################################################
1198 sub ReplaceDefineArgs
1199 {
1200 my ($string, $tail, %Used) = @_;
1201 # check if args used, if not do nothing
1202 if(DefineArgsUsed($tail)) {
1203 my $macro = $string;
1204 # get arguments following macro
1205 my @Argvals = FindDefineArgs($tail, $macro);
1206 $tail = pop(@Argvals); # tail returned as last element
1207
1208 my @Argnames = split(/\,/, $DefinesArgs{$macro});
1209 my ($i, $j);
1210
1211 # replace previous macro with defn + args
1212 $string = $Defines{$macro};
1213
1214 # check if macro should call a function
1215 if(exists($DefinesFuncs{$macro})) {
1216 # replace all macros in argument list
1217 for($i=0; $i<=$#Argvals; $i++) {
1218 $Argvals[$i] = ReplaceDefines($Argvals[$i]);
1219 }
1220 if($debug > 1) {
1221 my $argstring = "";
1222 if($#Argvals >= 0) { $argstring = join(", ", @Argvals); }
1223 Debug("Running function $DefinesFuncs{$macro} with args (".
1224 $argstring.")", 2);
1225 }
1226 # set name of macro which is being parse (needed in bigfunc.pm)
1227 $functionmacro = $macro;
1228 $string = $DefinesFuncs{$macro}->(@Argvals);
1229 # don't need do anything else, return now
1230 return $string, $tail;
1231 }
1232
1233 # check if last arg ends in ... (allows any number of args in macro)
1234 if($#Argnames >= 0 && $Argnames[$#Argnames] =~ s/\.\.\.\Z//o) {
1235 # concatanate all extra args into final arg
1236 while($#Argvals > $#Argnames) {
1237 my $arg1 = pop(@Argvals);
1238 my $arg2 = pop(@Argvals);
1239 push(@Argvals, $arg2.", ".$arg1);
1240 }
1241 # check for ## at start of macro name in args list
1242 if($string =~ /\#\#$Argnames[$#Argnames]/) {
1243 # if last argument is empty remove preciding ","
1244 if($#Argvals == $#Argnames && $Argvals[$#Argnames] eq "") {
1245 $string =~ s/\,\s*\#\#$Argnames[$#Argnames]//g;
1246 }
1247 else {
1248 $string =~
1249 s/\#\#$Argnames[$#Argnames]/$Argnames[$#Argnames]/g;
1250 }
1251 }
1252 }
1253
1254 # to get args passed to macro to same processed level as rest of
1255 # macro, they need to be checked for occurrences of all used macros,
1256 # this is a nasty hack to temporarily change defines list to %Used
1257 {
1258 my %RealDefines = %Defines;
1259 my $realdefmin = $defmin;
1260 my $realdefmax = $defmax;
1261 my %RealDefineLookup = %DefineLookup;
1262 %Defines = %Used;
1263 GenerateDefinesKeys();
1264
1265 for($i=0; $i<=$#Argvals; $i++) {
1266 $Argvals[$i] = ReplaceDefines($Argvals[$i]);
1267 }
1268
1269 # return defines to normal
1270 %Defines = %RealDefines;
1271 $defmin = $realdefmin;
1272 $defmax = $realdefmax;
1273 %DefineLookup = %RealDefineLookup;
1274 }
1275
1276 # The next step replaces argnames with argvals. Once a bit of string
1277 # has been replaced it is removed from further processing to avoid
1278 # unwanted recursive macro replacement.
1279 my @InString = ( $string ); # string to be replaced
1280 my @InDone = ( 0 ); # flag to say if string section replaced
1281 my @OutString; # output of string sections after each
1282 # macro has been replaced
1283 my @OutDone; # output flags
1284 my $k = 0;
1285 for($i=0; $i<=$#Argnames; $i++) {
1286 for($j=0; $j<=$#InString; $j++) {
1287 if($InDone[$j] == 0) {
1288 # replace macros and split up string so replaced part
1289 # is flagged as done and rest is left for further
1290 # processing
1291 while($InString[$j] =~ /$bound$Argnames[$i]$bound/) {
1292 $OutString[$k] = $`; $OutDone[$k] = 0;
1293 $k++;
1294 $OutString[$k] = $Argvals[$i]; $OutDone[$k] = 1;
1295 $k++;
1296 $InString[$j] = $'; # one more quote for emacs '
1297 }
1298 }
1299 $OutString[$k] = $InString[$j]; $OutDone[$k] = $InDone[$j];
1300 $k++;
1301 }
1302 @InString = @OutString; @InDone = @OutDone;
1303 $k = 0;
1304 }
1305 # rebuild string
1306 $string = join('', @InString);
1307
1308 Debug("Replaced \"".$macro."\" for \"".$string."\" [".$recurse_level."]", 2);
1309 }
1310 else {
1311 Debug("Macro \"".$string."\" found without args, ignored", 2);
1312 }
1313 return ($string, $tail);
1314 }
1315
1316
1317 ##############################################################################
1318 # When replacing macros with args, the macro and everything following the
1319 # macro (the tail) are passed to ReplaceDefineArgs. The function extracts
1320 # the args from the tail and then returns the replaced macro and the new
1321 # tail. This function extracts the remaining part of the real tail from
1322 # the current input string.
1323 ##############################################################################
1324 sub ReclaimTail
1325 {
1326 my ($input, $tail) = @_;
1327 # split strings into chars and compare each one until difference found
1328 my @Input = split(//, $input);
1329 my @Tail = split(//, $tail);
1330 $tail = $input = "";
1331 while($#Input >= 0 && $#Tail >= 0 && $Input[$#Input] eq $Tail[$#Tail]) {
1332 $tail = pop(@Tail).$tail;
1333 pop(@Input);
1334 }
1335 while($#Input >=0) { $input = pop(@Input).$input; }
1336 return ($input, $tail);
1337 }
1338
1339
1340 ##############################################################################
1341 # Replace all defined macro's in a line with their value. Recursively run
1342 # through macros as many times as needed (to find macros within macros).
1343 # Inputs:
1344 # $input = string to process
1345 # $tail = rest of line following $string (if any), this will only be used
1346 # if string contains a macro with args, the args will probably be
1347 # at the start of the tail
1348 # %Used = all macros found in $string so far, these will not be checked
1349 # again to avoid possible recursion
1350 # Initially just $input is passed in, other args are added for recursive calls
1351 ##############################################################################
1352 sub ReplaceDefines
1353 {
1354 my ($input, $tail, %Used) = @_;
1355 # check for recursive macro madness (set to same level as Perl warning)
1356 if(++$recurse_level > 97) {
1357 $recurse_level--;
1358 Warning("Recursive macro detected in \"".$input."\"");
1359 if($tail) { return ($input, $tail); }
1360 return $input;
1361 }
1362
1363 my $out = ""; # initialise output to empty string
1364 OUTER : while($input =~ /\S/o) {
1365 my ($macro, $string);
1366 my @Words;
1367
1368
1369 ######################################################################
1370 # if macros start with prefix, skip to next prefix
1371 ######################################################################
1372 if($macroprefix ne "") {
1373 my $found = 0;
1374 # find next potential macro in line if any
1375 while(!$found && $input =~ /$macroprefix\S/) {
1376 # everything before prefix
1377 $out = $out.$`;
1378 # reclaim first char in macro
1379 my $match = $&;
1380 # everything after prefix
1381 $input = chop($match).$'; # one more quote for emacs '
1382 # check if first chars are in macro
1383 if(exists($DefineLookup{substr($input, 0, $defmin)})) {
1384 $found = 1;
1385 }
1386 # put prefix back onto output and carry on searching
1387 else { $out = $out.$match; }
1388 }
1389 # no more macros
1390 if(!$found) { $out = $out.$input; $input = ""; last OUTER; }
1391 }
1392
1393
1394 ######################################################################
1395 # replacing macros which are "words" only - quick and easy
1396 ######################################################################
1397 if($bound eq '\b') {
1398 @Words = split(/(\w+)/, $input, 2);
1399 $out = $out.$Words[0];
1400 if($#Words == 2) { $macro = $Words[1]; $input = $Words[2]; }
1401 else { $input = ""; last OUTER; }
1402 }
1403
1404 ######################################################################
1405 # replacing all types of macro - slow and horrid
1406 ######################################################################
1407 else {
1408 # forward string to next non-whitespace char that starts a macro
1409 while(!exists($DefineLookup{substr($input, 0, $defmin)})) {
1410 if($input =~ /^\s/ ) { # remove preceding whitespace
1411 @Words = split(/^(\s+)/, $input, 2);
1412 $out = $out.$Words[1];
1413 $input = $Words[2];
1414 }
1415 else { # skip to next char
1416 $out = $out.substr($input, 0, 1);
1417 $input = substr($input, 1);
1418 }
1419 if($input eq "") { last OUTER; }
1420 }
1421 # remove the longest possible potential macro (containing no
1422 # whitespace) from the start of input
1423 @Words = split(/(\s+)/, $input, 2);
1424 $macro = $Words[0];
1425 if($#Words == 2) {$input = $Words[1].$Words[2]; }
1426 else {$input = ""; }
1427 # shorten macro if too long
1428 if(length($macro) > $defmax) {
1429 $input = substr($macro, $defmax).$input;
1430 $macro = substr($macro, 0, $defmax);
1431 }
1432 # see if a macro exists in "macro"
1433 while(length($macro) > $defmin &&
1434 !(exists($Defines{$macro}) && !exists($Used{$macro}))) {
1435 # chop a char off macro and try again
1436 $input = chop($macro).$input;
1437 }
1438 }
1439
1440 # check if macro is at start of string and has not been used yet
1441 if(exists($Defines{$macro}) && !exists($Used{$macro})) {
1442 # set macro as used
1443 $Used{$macro} = $Defines{$macro};
1444 # temporarily add tail to input
1445 if($tail) { $input = $input.$tail; }
1446 # replace macro with defn
1447 if(CheckDefineArgs($macro)) {
1448 ($string, $input) = ReplaceDefineArgs($macro, $input, %Used);
1449 }
1450 else {
1451 $string = $Defines{$macro};
1452 Debug("Replaced \"".$macro."\" for \"".$string."\" [".$recurse_level."]", 2);
1453 }
1454
1455 ($string=~ m/\#\#/) and ($string=~ s/\s*\#\#\s*//gm);
1456
1457 @Words = ReplaceDefines($string, $input, %Used);
1458 $out = $out.$Words[0];
1459 if($#Words == 0) { $input = ""; }
1460 else {
1461 # remove space up to start of next char
1462 if(CheckEatTrail($macro)) { $Words[1] =~ s/^[ \t]*//o; }
1463 $input = $Words[1];
1464 }
1465 delete($Used{$macro});
1466 # reclaim all unparsed tail
1467 if($tail && $tail ne "") {
1468 ($input, $tail) = ReclaimTail($input, $tail);
1469 }
1470 }
1471 # macro not matched, add to output and move swiftly on
1472 else {
1473 if($bound eq '\b') { $out = $out.$macro; }
1474 else {
1475 $out = $out.substr($macro, 0, 1);
1476 $input = substr($macro, 1).$input;
1477 }
1478 }
1479 }
1480 $recurse_level--;
1481 # append any whitespace left in string and return it
1482 if($tail) { return ($out.$input, $tail); }
1483 return $out.$input;
1484 }
1485
1486
1487 ##############################################################################
1488 # GenerateDefinesKey creates all keys and indices needed for %Defines
1489 ##############################################################################
1490 sub GenerateDefinesKeys
1491 {
1492 # find longest and shortest macro
1493 my ($define, $length) = each %Defines;
1494 $defmin = $defmax = length($define);
1495 %DefineLookup = ();
1496 foreach $define (keys(%Defines)) {
1497 $length = length($define);
1498 if($length > $defmax) { $defmax = $length; }
1499 if($length < $defmin) { $defmin = $length; }
1500 }
1501 # regenerate lookup table of first letters
1502 foreach $define (keys(%Defines)) {
1503 $DefineLookup{substr($define, 0, $defmin)} = 1;
1504 }
1505 }
1506
1507
1508 ##############################################################################
1509 # Set a define
1510 ##############################################################################
1511 sub SetDefine
1512 {
1513 my ($macro, $value) = @_;
1514 # add macro and value to hash table
1515 $Defines{$macro} = $value;
1516 # add define to keys
1517 my $length = length($macro);
1518 if($length < $defmin || $defmin == 0) { GenerateDefinesKeys(); }
1519 else {
1520 if($length > $defmax) { $defmax = $length; }
1521 $length = substr($macro, 0, $defmin);
1522 $DefineLookup{$length} = 1;
1523 }
1524 }
1525
1526
1527 ##############################################################################
1528 # Get a define without doing any macro replacement
1529 ##############################################################################
1530 sub GetDefine
1531 {
1532 my $macro = shift;
1533 return $Defines{$macro};
1534 }
1535
1536
1537 ##############################################################################
1538 # Replace a define, checks if macro defined and only redefine's if it is
1539 ##############################################################################
1540 sub Redefine
1541 {
1542 my $macro = shift;
1543 my $value = shift;
1544 # check if defined
1545 if(CheckDefine($macro)) { SetDefine($macro, $value); }
1546 }
1547
1548
1549 ##############################################################################
1550 # Set a define argument list
1551 ##############################################################################
1552 sub SetDefineArgs
1553 {
1554 my $macro = shift;
1555 my $args = shift;
1556 # add macro args to hash table
1557 $DefinesArgs{$macro} = $args;
1558 }
1559
1560
1561 ##############################################################################
1562 # Set a function which should be called when a macro is found
1563 ##############################################################################
1564 sub SetDefineFuncs
1565 {
1566 my $macro = shift;
1567 my $func = shift;
1568 # add macro function to hash table
1569 $DefinesFuncs{$macro} = $func;
1570 }
1571
1572
1573 ##############################################################################
1574 # Check if a macro is defined
1575 ##############################################################################
1576 sub CheckDefine
1577 {
1578 my $macro = shift;
1579 return exists($Defines{$macro});
1580 }
1581
1582
1583 ##############################################################################
1584 # Check if a macro is defined and has arguments
1585 ##############################################################################
1586 sub CheckDefineArgs
1587 {
1588 my $macro = shift;
1589 return exists($DefinesArgs{$macro});
1590 }
1591
1592
1593 ##############################################################################
1594 # Check if a macro is defined and calls a function
1595 ##############################################################################
1596 sub CheckDefineFuncs
1597 {
1598 my $macro = shift;
1599 return exists($DefinesFuncs{$macro});
1600 }
1601
1602
1603 ##############################################################################
1604 # Check if a macro is defined and eats trailing whitespace
1605 ##############################################################################
1606 sub CheckEatTrail
1607 {
1608 my $macro = shift;
1609 return exists($EatTrail{$macro});
1610 }
1611
1612
1613 ##############################################################################
1614 # Set eat-trailing-whitespace for a macro
1615 ##############################################################################
1616 sub SetEatTrail
1617 {
1618 my $macro = shift;
1619 $EatTrail{$macro} = 1;
1620 }
1621
1622
1623 ##############################################################################
1624 # Test if a file exists and is readable
1625 ##############################################################################
1626 sub FileExists
1627 {
1628 my $filename = shift;
1629 # test if file is readable and not a directory
1630 if( !(-r $filename) || -d $filename ) {
1631 Debug("Checking for file: ".$filename."...not found!", 2);
1632 return 0;
1633 }
1634 Debug("Checking for file: ".$filename."...found!", 2);
1635 return 1;
1636 }
1637
1638
1639 ##############################################################################
1640 # #comment - rest of line ignored as a comment
1641 ##############################################################################
1642 sub Comment
1643 {
1644 # nothing to be done here
1645 Debug("Commented line", 2);
1646 }
1647
1648
1649 ##############################################################################
1650 # Define a variable, accepted inputs:
1651 # $macrodefn = $macro $defn - $macro associated with $defn
1652 # ie: #define TEST test string
1653 # $macro = TEST, $defn = "test string"
1654 # Note: $defn = rest of line after $macro
1655 # $macrodefn = $macro - $macro defined without a defn, rest of line ignored
1656 # ie: #define TEST_DEFINE
1657 # $macro = TEST_DEFINE, $defn = "1"
1658 ##############################################################################
1659 sub Define
1660 {
1661 my $macrodefn = shift;
1662 my $macro;
1663 my $defn;
1664 my $i;
1665
1666 # check there is an argument
1667 if($macrodefn !~ /\S/o) {
1668 Filepp::Error("define keyword used without arguments");
1669 }
1670
1671 # find end of macroword - assume separated by space or tab
1672 $i = GetNextWordEnd($macrodefn);
1673
1674 # separate macro and defn (can't use split, doesn't work with '0')
1675 $macro = substr($macrodefn, 0, $i);
1676 $defn = substr($macrodefn, $i);
1677
1678 # strip leading whitespace from $defn
1679 if($defn) {
1680 $defn =~ s/^[ \t]*//;
1681 }
1682 else {
1683 $defn = "";
1684 }
1685
1686 # check if macro has arguments (will be a '(' in macro)
1687 if($macro =~ /\(/) {
1688 # split up macro, args and defn - delimiters = space, (, ), ','
1689 my @arglist = split(/([\s,\(,\),\,])/, $macro." ".$defn);
1690 my $macroargs = "";
1691 my $arg;
1692
1693 # macro is first element in list, remove it from list
1694 $macro = $arglist[0];
1695 $arglist[0] = "";
1696 # loop through list until ')' and find all args
1697 foreach $arg (@arglist) {
1698 if($arg) {
1699 # end of arg list, leave loop
1700 if($arg eq ")") {
1701 $arg = "";
1702 last;
1703 }
1704 # ignore space, ',' and '('
1705 elsif($arg =~ /([\s,\,,\(])/) {
1706 $arg = "";
1707 }
1708 # argument found, add to ',' separated list
1709 else {
1710 $macroargs = $macroargs.",".$arg;
1711 $arg = "";
1712 }
1713 }
1714 }
1715 $macroargs = Strip($macroargs, ",", 1);
1716 # store args
1717 SetDefineArgs($macro, $macroargs);
1718
1719 Debug("Define: macro ".$macro." has args (".$macroargs.")", 2);
1720 # put rest of defn back together
1721 $defn = join('',@arglist);
1722 $defn = CleanStart($defn);
1723 }
1724 # make sure macro is not being redefined and used to have args
1725 else {
1726 delete($DefinesArgs{$macro});
1727 delete($DefinesFuncs{$macro});
1728 }
1729
1730 # define the macro defn pair
1731 SetDefine($macro, $defn);
1732
1733 Debug("Defined \"".$macro."\" to be \"".$defn."\"", 2);
1734 if($debug > 2) { PrintDefines(); }
1735 }
1736
1737
1738
1739 ##############################################################################
1740 # Else, standard if[n][def]-else-endif
1741 # usage: #else somewhere between #if[n][def] key and #endif
1742 ##############################################################################
1743 sub Else
1744 {
1745 # else always true - only ran when all preceding 'if's have failed
1746 return 1;
1747 }
1748
1749
1750 ##############################################################################
1751 # Endif, standard ifdef-[else]-endif
1752 # usage: #endif somewhere after #ifdef key and optionally #else
1753 ##############################################################################
1754 sub Endif
1755 {
1756 # this always terminates an if block
1757 return 1;
1758 }
1759
1760
1761 ##############################################################################
1762 # If conditionally includes or ignores parts of a file based on expr
1763 # usage: #if expr
1764 # expr is evaluated to true(1) or false(0) and include usual ==, !=, > etc.
1765 # style comparisons. The "defined" keyword can also be used, ie:
1766 # #if defined MACRO || !defined(MACRO)
1767 ##############################################################################
1768 sub If
1769 {
1770 my $expr = shift;
1771 Debug("If: parsing: \"".$expr."\"", 2);
1772
1773 # check for any "defined MACRO" tests and evaluate them
1774 if($expr =~ /defined/) {
1775 my $indefined = 0;
1776
1777 # split expr up into its component parts, the split is done on the
1778 # following list of chars and strings: '!','(',')','&&','||', space
1779 my @Exprs = split(/([\s,\!,\(,\)]|\&\&|\|\|)/, $expr);
1780
1781 # search through parts for "defined" keyword and check if macros
1782 # are defined
1783 foreach $expr (@Exprs) {
1784 if($indefined == 1) {
1785 # previously found a defined keyword, check if next word
1786 # could be the macro to test for (not any of the listed chars)
1787 if($expr && $expr !~ /([\s,\!,\(,\)]|\&\&|\|\|)/) {
1788 # replace macro with 0 or 1 depending if it is defined
1789 Debug("If: testing if \"".$expr."\" defined...", 2);
1790 if(CheckDefine($expr)) {
1791 $expr = 1;
1792 Debug("If: defined", 2);
1793 }
1794 else {
1795 $expr = 0;
1796 Debug("If: NOT defined", 2);
1797 }
1798 $indefined = 0;
1799 }
1800 }
1801 elsif($expr eq "defined") {
1802 # get rid of defined keyword
1803 $expr = "";
1804 # search for next macro following "defined"
1805 $indefined = 1;
1806 }
1807 }
1808
1809 # put full expr string back together
1810 my $newexpr = join('',@Exprs);
1811 $expr = $newexpr;
1812 }
1813
1814 # pass parsed line though processors
1815 $expr = RunProcessors($expr);
1816
1817 # evaluate line and return result (1 = true)
1818 Debug("If: evaluating \"".$expr."\"", 2);
1819 my $result = eval($expr);
1820 # check if statement is valid
1821 if(!defined($result)) { Warning($@); }
1822 elsif($result) {
1823 Debug("If: \"".$expr."\" true", 1);
1824 return 1;
1825 }
1826 Debug("If: \"".$expr."\" false", 1);
1827 return 0;
1828 }
1829
1830
1831 ##############################################################################
1832 # Elif equivalent to "else if". Placed between #if[n][def] and #endif,
1833 # equivalent to nesting #if's
1834 ##############################################################################
1835 sub Elif
1836 {
1837 my $input = shift;
1838 return If($input);
1839 }
1840
1841
1842 ##############################################################################
1843 # Ifdef conditionally includes or ignores parts of a file based on macro,
1844 # usage: #ifdef MACRO
1845 # if macro has been previously #define'd everything following the
1846 # #ifdef will be included, else it will be ignored until #else or #endif
1847 ##############################################################################
1848 sub Ifdef
1849 {
1850 my $macro = shift;
1851
1852 # separate macro from any trailing garbage
1853 $macro = substr($macro, 0, GetNextWordEnd($macro));
1854
1855 # check if macro defined - if not set to be #ifdef'ed out
1856 if(CheckDefine($macro)) {
1857 Debug("Ifdef: ".$macro." defined", 1);
1858 return 1;
1859 }
1860 Debug("Ifdef: ".$macro." not defined", 1);
1861 return 0;
1862 }
1863
1864
1865 ##############################################################################
1866 # Ifndef conditionally includes or ignores parts of a file based on macro,
1867 # usage: #ifndef MACRO
1868 # if macro has been previously #define'd everything following the
1869 # #ifndef will be ignored, else it will be included until #else or #endif
1870 ##############################################################################
1871 sub Ifndef
1872 {
1873 my $macro = shift;
1874
1875 # separate macro from any trailing garbage
1876 $macro = substr($macro, 0, GetNextWordEnd($macro));
1877
1878 # check if macro defined - if not set to be #ifdef'ed out
1879 if(CheckDefine($macro)) {
1880 Debug("Ifndef: ".$macro." defined", 1);
1881 return 0;
1882 }
1883 Debug("Ifndef: ".$macro." not defined", 1);
1884 return 1;
1885 }
1886
1887
1888 ##############################################################################
1889 # Parses all macros from file, but discards all other output
1890 ##############################################################################
1891 sub IncludeMacros
1892 {
1893 my $file = shift;
1894 my $currentoutput = $output;
1895 SetOutput(0);
1896 Parse($file);
1897 SetOutput($currentoutput);
1898 }
1899
1900
1901 ##############################################################################
1902 # Include $filename in output file, format:
1903 # #include "filename" - local include file, ie. in same directory, try -Ipath
1904 # also if not not found in current directory
1905 # #include <filename> - system include file, use -Ipath
1906 ##############################################################################
1907 sub Include
1908 {
1909 my $input = shift;
1910 my $filename = $input;
1911 my $fullname;
1912 my $sysinclude = 0;
1913 my $found = 0;
1914 my $i;
1915
1916
1917 # check for recursive includes (level set to same as Perl recurse warn)
1918 if($include_level >= 98) {
1919 Warning("Include recursion too deep - skipping \"".$filename."\"\n");
1920 return;
1921 }
1922
1923 # replace any defined values in the include line
1924 $filename = RunProcessors($filename);
1925
1926 # check if it is a system include file (#include <filename>) or a local
1927 # include file (#include "filename")
1928 if(substr($filename, 0, 1) eq "<") {
1929 $sysinclude = 1;
1930 # remove <> from filename
1931 $filename = substr($filename, 1);
1932 ($filename) = split(/\>/, $filename, 2);
1933 }
1934 elsif(substr($filename, 0, 1) eq "\"") {
1935 # remove double quotes from filename
1936 $filename = substr($filename, 1);
1937 ($filename) = split(/\"/, $filename, 2);
1938 }
1939 # else assume filename given without "" or <>, naughty but allowed
1940
1941 # check for file in current directory
1942 if($sysinclude == 0) {
1943 # get name of directory base file is in
1944 my $dir = "";
1945 if($file =~ /\//) {
1946 my @Dirs = split(/(\/)/, $file);
1947 for($i=0; $i<$#Dirs; $i++) {
1948 $dir = $dir.$Dirs[$i];
1949 }
1950 }
1951 if(FileExists($dir.$filename)) {
1952 $fullname = $dir.$filename;
1953 $found = 1;
1954 }
1955 }
1956
1957 # search for file in include paths, first path on command line first
1958 $i = 0;
1959 while($found == 0 && $i <= $#IncludePaths) {
1960 $fullname = $IncludePaths[$i]."/".$filename;
1961 if(FileExists($fullname)) { $found = 1; }
1962 $i++;
1963 }
1964
1965 # include file if found, error if not
1966 if($found == 1) {
1967 Debug("Including file: \"".$fullname."\"", 1);
1968
1969 #if $filename is already visited, just return
1970 if (IsVisited($fullname)){
1971 return;
1972 } else {
1973 # recursively call Parse
1974 print " " . $fullname . " \\\n";
1975 Parse($fullname);
1976 }
1977 }
1978 else {
1979 Warning("Include file \"".$filename."\" not found", 1);
1980 }
1981 }
1982
1983
1984
1985 ##############################################################################
1986 # Pragma filepp Function Args
1987 # Pragma executes a filepp function, everything following the function name
1988 # is passed as arguments to the function.
1989 # The format is:
1990 # #pragma filepp function args...
1991 # If pragma is not followed by "filepp", it is ignored.
1992 ##############################################################################
1993 sub Pragma
1994 {
1995 my $input = shift;
1996
1997 # check for "filepp" in string
1998 if($input =~ /^filepp\b/) {
1999 my ($function, $args);
2000 ($input, $function, $args) = split(/\s/, $input, 3);
2001 if($function) {
2002 if(!$args) { $args = ""; }
2003 if($safe_mode) {
2004 Debug("Safe mode enabled, NOT running: ".$function."(".$args.")", 1);
2005 }
2006 else {
2007 my @Args = ParseArgs($args);
2008 Debug("Running function: ".$function."(".$args.")", 1);
2009 $function->(@Args);
2010 }
2011 }
2012 }
2013 }
2014
2015
2016 ##############################################################################
2017 # Turn normal output on/off (does not affect any output produced by keywords)
2018 # 1 = on, 0 = off
2019 ##############################################################################
2020 sub SetOutput
2021 {
2022 $output = shift;
2023 Debug("Output set to ".$output, 2);
2024 }
2025
2026
2027 ##############################################################################
2028 # Turn blank suppression on and off at this include level
2029 # 1 = on, 0 = off
2030 ##############################################################################
2031 sub SetBlankSupp
2032 {
2033 $blanksupp[$include_level] = shift;
2034 Debug("Blank suppression set to ".$blanksupp[$include_level], 2);
2035 }
2036
2037
2038 ##############################################################################
2039 # Reset blank suppression to command-line value (except at level 0)
2040 ##############################################################################
2041 sub ResetBlankSupp
2042 {
2043 if($include_level == 0) {
2044 $blanksupp[$include_level] = 0;
2045 } else {
2046 $blanksupp[$include_level] = $blanksuppopt;
2047 }
2048 Debug("Blank suppression reset to ".$blanksupp[$include_level], 2);
2049 }
2050
2051
2052 ##############################################################################
2053 # Set if macros are only replaced if the macro is a 'word'
2054 ##############################################################################
2055 sub SetWordBoundaries
2056 {
2057 my $on = shift;
2058 if($on) {
2059 $bound = '\b';
2060 Debug("Word Boundaries turned on", 2);
2061 }
2062 else {
2063 $bound = '';
2064 Debug("Word Boundaries turned off", 2);
2065 }
2066 }
2067
2068 ##############################################################################
2069 # DEPRECATED - this function will be removed in later versions, use Set
2070 # Toggle if macros are only replaced if the macro is a 'word'
2071 ##############################################################################
2072 sub ToggleWordBoundaries
2073 {
2074 if($bound eq '\b') { SetWordBoundaries(1); }
2075 else { SetWordBoundaries(0); }
2076 }
2077
2078
2079 ##############################################################################
2080 # Set treating keywordchar, contchar, macroprefix and optlineendchar as
2081 # Perl regexps
2082 ##############################################################################
2083 sub SetCharPerlre
2084 {
2085 $charperlre = shift;
2086 Debug("Characters treated as Perl regexp's : ".$charperlre, 2);
2087 }
2088
2089
2090 ##############################################################################
2091 # Undef a previously defined variable, usage:
2092 # #undef $macro
2093 ##############################################################################
2094 sub Undef
2095 {
2096 my $macro = shift;
2097 my $i;
2098
2099 # separate macro from any trailing garbage
2100 $macro = substr($macro, 0, GetNextWordEnd($macro));
2101
2102 # delete macro from table
2103 delete $Defines{$macro};
2104 delete $DefinesArgs{$macro};
2105 delete $DefinesFuncs{$macro};
2106
2107 # and remove its eat-trailing-whitespace flag
2108 if(CheckEatTrail($macro)) { delete $EatTrail{$macro}; }
2109
2110 # regenerate keys
2111 GenerateDefinesKeys();
2112
2113 Debug("Undefined macro \"".$macro."\"", 2);
2114 if($debug > 1) { PrintDefines(); }
2115 }
2116
2117
2118 ##############################################################################
2119 # UndefAll - undefines ALL macros
2120 ##############################################################################
2121 sub UndefAll
2122 {
2123 %Defines = ();
2124 %DefineLookup = ();
2125 %EatTrail = ();
2126 $defmin = $defmax = 0;
2127 Debug("Undefined ALL macros", 2);
2128 if($debug > 1) { PrintDefines(); }
2129 }
2130
2131
2132 ##############################################################################
2133 # #warning msg - print warning message "msg"
2134 ##############################################################################
2135 sub Warning
2136 {
2137 my $msg = shift;
2138 my $lastdebug = $debug;
2139 $debug = 1;
2140 Debug($msg, 1);
2141 $debug = $lastdebug;
2142 }
2143
2144
2145 ##############################################################################
2146 # ParseLineEnd - takes in line from input most recently read and checks
2147 # if line should be continued (ie. next line in input read and appended
2148 # to current line).
2149 # Returns two values:
2150 # $more - boolean, 1 = read another line from input to append to this one
2151 # 0 = no line continuation
2152 # $line - the line to be read. If any modification needs to be done to the
2153 # line for line contination, it is done here.
2154 # Example: if line is to be continued: set $more = 1, then
2155 # remove line continuation character and newline from end of
2156 # $line and replace with line continuation character.
2157 ##############################################################################
2158 sub ParseLineEnd
2159 {
2160 my $thisline = shift;
2161 my $more = 0;
2162 # check if end of line has a continuation char, if it has get next line
2163 if($thisline =~ /$contchar$/) {
2164 $more = 1;
2165 # remove backslash and newline
2166 $thisline =~ s/$contchar\n\Z//;
2167 # append line continuation character
2168 $thisline = $thisline.$contrepchar;
2169 }
2170 return ($more, $thisline);
2171 }
2172
2173
2174 ##############################################################################
2175 # Set name of function to take check if line shoule be continued
2176 ##############################################################################
2177 sub SetParseLineEnd
2178 {
2179 my $func = shift;
2180 $parselineend = $func;
2181 }
2182
2183 ##############################################################################
2184 # Get name of function to take check if line shoule be continued
2185 ##############################################################################
2186 sub GetParseLineEnd
2187 {
2188 return $parselineend;
2189 }
2190
2191
2192 ##############################################################################
2193 # GetNextLine - returns the next line of the current INPUT line,
2194 # line continuation is taken care of here.
2195 ##############################################################################
2196 sub GetNextLine
2197 {
2198 my $thisline = <INPUT>;
2199 if($thisline) {
2200 Redefine("__LINE__", ++$line);
2201 my $more = 0;
2202 ($more, $thisline) = $parselineend->($thisline);
2203 while($more) {
2204 Debug("Line continuation", 2);
2205 my $nextline = <INPUT>;
2206 if(!$nextline) { return $thisline; }
2207 # increment line count
2208 Redefine("__LINE__", ++$line);
2209 ($more, $thisline) = $parselineend->($thisline.$nextline);
2210 # maintain same number of lines in input as output
2211 if($preserveblank) { Filepp::Output("\n"); }
2212 }
2213 }
2214 return $thisline;
2215 }
2216
2217
2218 ##############################################################################
2219 # Write($string) - writes $string to OUTPUT file
2220 ##############################################################################
2221 sub Write
2222 {
2223 my $string = shift;
2224 #print(OUTPUT $string);
2225 }
2226
2227
2228 ##############################################################################
2229 # Output($string) - conditionally writes $string to OUTPUT file
2230 ##############################################################################
2231 sub Output
2232 {
2233 my $string = shift;
2234 if($output) { Write($string); }
2235 }
2236
2237 # counter for number of #if[n][def] loops currently in
2238 my $iflevel = 0;
2239 # flag to control when to write output
2240 my @Writing = (1); # initialise default to 'writing'
2241 # flag to show if current 'if' block has passed a 'true if'
2242 my @Ifdone = (0); # initialise first to 'not passed true if'
2243
2244 ##############################################################################
2245 # Keyword parsing routine
2246 ##############################################################################
2247 sub ParseKeywords
2248 {
2249 # input is next line in file
2250 my $inline = shift;
2251 my $outline = "";
2252
2253 my $thisline = $inline;
2254 my $keyword;
2255 my $found = 0;
2256 # remove whitespace from start of line
2257 $thisline = CleanStart($thisline);
2258 # check if first char on line is a #
2259
2260 #if($thisline && $thisline =~ /^$keywordchar/) {
2261 if($thisline) {
2262 # remove "#" and any following whitespace
2263 #$thisline =~ s/^$keywordchar\s*//g;
2264 # remove the optional end line char
2265 if($optlineendchar ne "") {
2266 $thisline =~ s/$optlineendchar\Z//g;
2267 }
2268 # check for keyword
2269 #if($thisline && $thisline =~ /^\w+\b/ && exists($Keywords{$&})) {
2270 if($thisline && $thisline =~ /^#*\w+\b/ && exists($Keywords{$&})) {
2271 $keyword = $&;
2272 $found = 1;
2273 # remove newline from line
2274 chomp($thisline);
2275 # remove leading whitespace and keyword from line
2276 my $inline = CleanStart(substr($thisline, length($keyword)));
2277
2278 # check for 'if' style keyword
2279 if(exists($Ifwords{$keyword})) {
2280 # increment ifblock level and set ifdone to same
2281 # value as previous block
2282 $iflevel++;
2283 $Ifdone[$iflevel] = 0;
2284 $Writing[$iflevel] = $Writing[$iflevel - 1];
2285 if(!$Writing[$iflevel]) { $Ifdone[$iflevel] = 1; }
2286 }
2287 # check for out of place 'else' or 'endif' style keyword
2288 elsif($iflevel <= 0 && (exists($Elsewords{$keyword}) ||
2289 exists($Endifwords{$keyword}) )) {
2290 Warning($keywordchar.$keyword." found without preceding ".
2291 $keywordchar."[else]ifword");
2292 }
2293
2294 # decide if to run 'if' or 'else' keyword
2295 if(exists($Ifwords{$keyword}) || exists($Elsewords{$keyword})){
2296 if(!($Ifdone[$iflevel])) {
2297 # check return value of 'if'
2298 if($Keywords{$keyword}->($inline)) {
2299 $Ifdone[$iflevel] = 1;
2300 $Writing[$iflevel] = 1;
2301 }
2302 else { $Writing[$iflevel] = 0; }
2303 }
2304 else { $Writing[$iflevel] = 0; }
2305 }
2306 # check for 'endif' style keyword
2307 elsif(exists($Endifwords{$keyword})) {
2308 # run endif keyword and decrement iflevel if true
2309 if($Keywords{$keyword}->($inline)) { $iflevel--; }
2310 }
2311 # run all other keywords
2312 elsif($Writing[$iflevel]) { $Keywords{$keyword}->($inline); }
2313
2314 # write a blank line if preserving blank lines
2315 # (assumes keywords have no output)
2316 if($preserveblank) { $outline = $outline."\n"; }
2317
2318 } # keyword if statement
2319 }
2320 # no keywords in line - write line to file if not #ifdef'ed out
2321 if(!$found && $Writing[$iflevel]) {
2322 $outline = $outline.$inline;
2323 }
2324 # keep same number of files in output and input
2325 elsif(!$found && $preserveblank) { $outline = $outline."\n"; }
2326
2327 return $outline;
2328 }
2329
2330 ##############################################################################
2331 # Main parsing routine
2332 ##############################################################################
2333 sub Parse
2334 {
2335 # change file being parsed to this file, remember last filename so
2336 # it can be returned at the end
2337 my $lastparse = $file;
2338 $file = shift;
2339
2340 Debug("Parsing ".$file."...", 1);
2341 Redefine("__FILE__", $file);
2342
2343 # reset line count, remembering previous count for future reference
2344 my $lastcount = $line;
2345 $line = 0;
2346 Redefine("__LINE__", $line);
2347
2348 # increment include level
2349 Redefine("__INCLUDE_LEVEL__", ++$include_level);
2350
2351 # set blank line suppression:
2352 # no suppression for top level files
2353 if($include_level == 0) {
2354 $blanksupp[$include_level] = 0;
2355 }
2356 # include level 1 - set suppression to command line given value
2357 elsif($include_level == 1) {
2358 # inherit root value if set
2359 if($blanksupp[0]) { $blanksupp[$include_level] = 1; }
2360 else {$blanksupp[$include_level] = $blanksuppopt; }
2361 }
2362 # all other include levels - keep suppression at existing value
2363 else {
2364 $blanksupp[$include_level] = $blanksupp[$include_level - 1];
2365 }
2366
2367 # reset RunProcessors function for this file
2368 $Running[$include_level] = 0;
2369 $Currentproc[$include_level] = 0;
2370
2371 # open file and set its handle to INPUT
2372 local *INPUT;
2373 if(!open(INPUT, $file)) {
2374 Error("Could not open file ".$file);
2375 }
2376
2377 # change the behavior of OpenInputFuncs
2378 # every time a file is open, the functions in @OpenInputFuncs
2379 # are called.
2380 # if a base file, run any initialisation functions
2381 # if($include_level == 0) {
2382 my $func;
2383 foreach $func (@OpenInputFuncs) { $func->(); }
2384 #}
2385
2386 # parse each line of file
2387 $_ = GetNextLine();
2388 # if in "shebang" mode, throw away first line (the #!/blah bit)
2389 if($shebang) {
2390 # check for "#!...perl ...filepp..."
2391 if($_ && $_ =~ /^\#\!.*perl.+filepp/) {
2392 Debug("Skipping first line (shebang): ".$_, 1);
2393 $_ = GetNextLine();
2394 }
2395 }
2396
2397 while($_) {
2398 # unless blank lines are suppressed at this include level
2399 unless($blanksupp[$include_level] && /^\s*$/) {
2400 # run processing chain (defaults to ReplaceDefines)
2401 $_ = RunProcessors($_, 1);
2402 # write output to file or STDOUT
2403 if($output) { Write($_); }
2404 }
2405 $_ = GetNextLine();
2406 }
2407
2408 # run any close functions
2409 #if($include_level == 0) {
2410 #my $func;
2411 foreach $func (@CloseInputFuncs) { $func->(); }
2412 #}
2413
2414 # check all #if blocks have been closed at end of parsing
2415 if($lastparse eq "" && $iflevel > 0) { Warning("Unterminated if block"); }
2416
2417 # close file
2418 close(INPUT);
2419 Debug("Parsing ".$file." done. (".$line." lines processed)", 1);
2420
2421 # reset $line
2422 $line = $lastcount;
2423 Redefine("__LINE__", $line);
2424
2425 # reset $file
2426 $file = $lastparse;
2427 Redefine("__FILE__", $file);
2428 if($file ne "") {
2429 Debug("Parsing returned to ".$file." at line ".$line, 1);
2430 }
2431
2432 # decrement include level
2433 Redefine("__INCLUDE_LEVEL__", --$include_level);
2434
2435 }
2436
2437 ##############################################################################
2438 # module keyword - declare a fortran90 module
2439 ##############################################################################
2440 sub Module{
2441 my $modulename = shift;
2442 my $modulefile;
2443 my $file;
2444 if ($modulename !~ /^procedure/){
2445
2446 $modulename =~ s/\s+$//;
2447 $parsedModList{GetModBasename($modulename) . "." . $modSuffix}
2448 = Filepp::GetDefine('__FILE__');
2449
2450 #$modulefile = Filepp::GetDefine('__BASE_FILE__');
2451 #print $modulefile;
2452 #$file = Filepp::GetDefine('__FILE__');
2453 #print $modulefile;
2454 }
2455 }
2456
2457 ##############################################################################
2458 # add use keyword
2459 ##############################################################################
2460 Filepp::AddKeyword("module", "Filepp::Module");
2461
2462 ##############################################################################
2463 # use keyword - use other fortran90 module
2464 ##############################################################################
2465 sub Use{
2466 my $line = shift;
2467 $line =~ /^(\w+).*/;
2468 my $f90module = $1;
2469 $f90module =~ s/\s+$//;
2470 $f90module = uc($f90module);
2471
2472 print " " . $objDir . GetModBasename($f90module) . "." . $modSuffix . "\\\n";
2473 }
2474
2475 ##############################################################################
2476 # add use keyword
2477 ##############################################################################
2478 Filepp::AddKeyword("use", "Filepp::Use");
2479
2480 ##############################################################################
2481 # add include keyword which is the same as c's #include
2482 ##############################################################################
2483 Filepp::AddKeyword("include", "Filepp::Include");
2484
2485 ##############################################################################
2486 # test whether a file is visited or not
2487 ##############################################################################
2488 sub IsVisited {
2489 my $fullfile = shift;
2490
2491 if (exists($visitedTable{$fullfile})){
2492 return 1;
2493 } else {
2494 $visitedTable{$fullfile} = 1;
2495 return 0;
2496 }
2497 }
2498
2499 sub AddModule {
2500 my $modulename = shift;
2501
2502 if (!exists($f90ModList{$modulename})){
2503 $f90ModList{$modulename} = 1;
2504 } else {
2505 $f90ModList{$modulename}++;
2506
2507 }
2508
2509 }
2510
2511 ##############################################################################
2512 # Generate rules for fortran 90 module
2513 ##############################################################################
2514 sub printModule {
2515 my $modname;
2516 my $objname;
2517 print "\n";
2518 foreach $modname (keys %parsedModList) {
2519 $objname = GetObjFile($parsedModList{$modname});
2520 print $objDir . $modname . " : " . $objDir . $objname . "\n";
2521 }
2522 }
2523
2524 ##############################################################################
2525 # Get the object file name
2526 ##############################################################################
2527 sub GetObjFile {
2528 use File::Basename;
2529 my $fullname = shift;
2530 my $filename;
2531 my $dir;
2532 my $suffix;
2533 ($filename, $dir, $suffix) = fileparse($fullname, '\.[^.]*');
2534 return $filename . $objExt;
2535 }
2536
2537 ##############################################################################
2538 # Get the base name of fortran 90 module
2539 ##############################################################################
2540 sub GetModBasename {
2541 my $modname = shift;
2542
2543 if ($modBasenameCase eq "lower") {
2544 $modname = lc($modname);
2545
2546 } elsif ($modBasenameCase eq "upper") {
2547 $modname = uc($modname);
2548 } elsif ($modBasenameCase eq "mixed") {
2549 $modname = ucfirst(lc($modname));
2550 }
2551
2552 return $modname;
2553 }
2554
2555 ##############################################################################
2556 # Main routine
2557 ##############################################################################
2558
2559 # parse command line
2560 my $i=0;
2561 my $argc=0;
2562 while($ARGV[$argc]) { $argc++; }
2563
2564 while($ARGV[$i]) {
2565
2566 # suppress blank lines in header files
2567 if($ARGV[$i] eq "-b") {
2568 $blanksuppopt = 1;
2569 }
2570
2571 # read from stdin instead of file
2572 elsif($ARGV[$i] eq "-c") {
2573 AddInputFile("-");
2574 }
2575
2576 # Defines: -Dmacro[=defn] or -D macro[=defn]
2577 elsif(substr($ARGV[$i], 0, 2) eq "-D") {
2578 my $macrodefn;
2579 # -D macro[=defn] format
2580 if(length($ARGV[$i]) == 2) {
2581 if($i+1 >= $argc) {
2582 Error("Argument to `-D' is missing");
2583 }
2584 $macrodefn = $ARGV[++$i];
2585 }
2586 # -Dmacro[=defn] format
2587 else {
2588 $macrodefn = substr($ARGV[$i], 2);
2589 }
2590 my $macro = $macrodefn;
2591 my $defn = "";
2592 my $j = index($macrodefn, "=");
2593 if($j > -1) {
2594 $defn = substr($macrodefn, $j+1);
2595 $macro = substr($macrodefn, 0, $j);
2596 }
2597 # add macro and defn to hash table
2598 Define($macro." ".$defn);
2599 }
2600
2601 # Debugging turned on: -d
2602 elsif($ARGV[$i] eq "-d") {
2603 SetDebug(2);
2604 }
2605
2606 # Full debugging turned on: -dd
2607 elsif($ARGV[$i] eq "-dd") {
2608 SetDebug(3);
2609 }
2610
2611 # Light debugging turned on: -dl
2612 elsif($ARGV[$i] eq "-dl") {
2613 SetDebug(1);
2614 }
2615
2616 # Send debugging info to stdout rather than stderr
2617 elsif($ARGV[$i] eq "-ds") {
2618 $debugstdout = 1;
2619 }
2620
2621 # prefix all debugging info with string
2622 elsif($ARGV[$i] eq "-dpre") {
2623 if($i+1 >= $argc) {
2624 Error("Argument to `-dpre' is missing");
2625 }
2626 $debugprefix = ReplaceDefines($ARGV[++$i]);
2627 }
2628
2629 # prefix all debugging info with string
2630 elsif($ARGV[$i] eq "-dpost") {
2631 if($i+1 >= $argc) {
2632 Error("Argument to `-dpost' is missing");
2633 }
2634 # replace defines is called here in case a newline is required,
2635 # this allows it to be added as __NEWLINE__
2636 $debugpostfix = ReplaceDefines($ARGV[++$i]);
2637 }
2638
2639 # define environment variables as macros: -e
2640 elsif($ARGV[$i] eq "-e") {
2641 DefineEnv();
2642 }
2643
2644 # set environment variable prefix char
2645 elsif($ARGV[$i] eq "-ec") {
2646 if($i+1 >= $argc) {
2647 Error("Argument to `-ec' is missing");
2648 }
2649 SetEnvchar($ARGV[++$i]);
2650 }
2651
2652 # set environment variable prefix char to nothing
2653 elsif($ARGV[$i] eq "-ecn") {
2654 SetEnvchar("");
2655 }
2656
2657 # show help
2658 elsif($ARGV[$i] eq "-h") {
2659 print(STDERR $usage);
2660 exit(0);
2661 }
2662
2663 # Include paths: -Iinclude or -I include
2664 elsif(substr($ARGV[$i], 0, 2) eq "-I") {
2665 # -I include format
2666 if(length($ARGV[$i]) == 2) {
2667 if($i+1 >= $argc) {
2668 Error("Argument to `-I' is missing");
2669 }
2670 AddIncludePath($ARGV[++$i]);
2671 }
2672 # -Iinclude format
2673 else {
2674 AddIncludePath(substr($ARGV[$i], 2));
2675 }
2676 }
2677
2678 # Include macros from file: -imacros file
2679 elsif($ARGV[$i] eq "-imacros") {
2680 if($i+1 >= $argc) {
2681 Error("Argument to `-imacros' is missing");
2682 }
2683 push(@Imacrofiles, $ARGV[++$i]);
2684 }
2685
2686 # turn off keywords
2687 elsif($ARGV[$i] eq "-k") {
2688 RemoveAllKeywords();
2689 }
2690
2691 # set keyword prefix char
2692 elsif($ARGV[$i] eq "-kc") {
2693 if($i+1 >= $argc) {
2694 Error("Argument to `-kc' is missing");
2695 }
2696 SetKeywordchar($ARGV[++$i]);
2697 }
2698
2699 # set line continuation character
2700 elsif($ARGV[$i] eq "-lc") {
2701 if($i+1 >= $argc) {
2702 Error("Argument to `-lc' is missing");
2703 }
2704 SetContchar($ARGV[++$i]);
2705 }
2706
2707 # set optional line end character
2708 elsif($ARGV[$i] eq "-lec") {
2709 if($i+1 >= $argc) {
2710 Error("Argument to `-lec' is missing");
2711 }
2712 SetOptLineEndchar($ARGV[++$i]);
2713 }
2714
2715 # set line continuation replacement char to newline
2716 elsif($ARGV[$i] eq "-lrn") {
2717 SetContrepchar("\n");
2718 }
2719
2720 # set line continuation replacement character
2721 elsif($ARGV[$i] eq "-lr") {
2722 if($i+1 >= $argc) {
2723 Error("Argument to `-lr' is missing");
2724 }
2725 SetContrepchar($ARGV[++$i]);
2726 }
2727
2728 # Module paths: -Minclude or -M include
2729 elsif(substr($ARGV[$i], 0, 2) eq "-M") {
2730 # -M include format
2731 if(length($ARGV[$i]) == 2) {
2732 if($i+1 >= $argc) {
2733 Error("Argument to `-M' is missing");
2734 }
2735 AddModulePath($ARGV[++$i]);
2736 }
2737 # -Minclude format
2738 else {
2739 AddModulePath(substr($ARGV[$i], 2));
2740 }
2741 }
2742
2743 # use module
2744 elsif($ARGV[$i] eq "-m") {
2745 if($i+1 >= $argc) {
2746 Error("Argument to `-m' is missing");
2747 }
2748 UseModule($ARGV[++$i]);
2749 }
2750
2751 #case of basename of fortran module
2752 elsif($ARGV[$i] eq "-mc") {
2753 my $tempVar = lc($ARGV[++$i]);
2754 if ($modBasenameCase ne 'lower' && $modBasenameCase ne 'upper'
2755 && $modBasenameCase ne 'mixed'){
2756 Error("Valid argument for `-om' are lower, upper or mixed");
2757 }
2758 $modBasenameCase = $tempVar;
2759 }
2760
2761 #the suffix of fortran module
2762 elsif($ARGV[$i] eq "-ms") {
2763 $modSuffix = $ARGV[++$i];
2764 }
2765
2766 # set macro prefix
2767 elsif($ARGV[$i] eq "-mp") {
2768 if($i+1 >= $argc) {
2769 Error("Argument to `-mp' is missing");
2770 }
2771 SetMacroPrefix($ARGV[++$i]);
2772 }
2773
2774 # turn off macro prefix within keywords
2775 elsif($ARGV[$i] eq "-mpnk") {
2776 $macroprefixinkeywords = 0;
2777 }
2778
2779 # tells filepp that the object and
2780 # module files will be built in a separate directory from the sources.
2781 elsif($ARGV[$i] eq "-od") {
2782 $objDir = $ARGV[++$i];
2783 }
2784
2785 # turn on overwrite mode
2786 elsif($ARGV[$i] eq "-ov") {
2787 $overwrite = 1;
2788 }
2789
2790 # turn on overwrite conversion mode
2791 elsif($ARGV[$i] eq "-ovc") {
2792 if($i+1 >= $argc) {
2793 Error("Argument to `-ovc' is missing");
2794 }
2795 $overwriteconv = $ARGV[++$i];
2796 if($overwriteconv !~ /=/) {
2797 Error("-ovc argument is of form IN=OUT");
2798 }
2799 $overwrite = 1;
2800 }
2801
2802 # Output filename: -o filename or -ofilename
2803 elsif(substr($ARGV[$i], 0, 2) eq "-o") {
2804 # -o filename
2805 if(length($ARGV[$i]) == 2) {
2806 if($i+1 >= $argc) {
2807 Error("Argument to `-o' is missing");
2808 }
2809 $outputfile = $ARGV[++$i];
2810 }
2811 # -ofilename
2812 else {
2813 $outputfile = substr($ARGV[$i], 2);
2814 }
2815 }
2816
2817 # preserve blank lines in output file
2818 elsif($ARGV[$i] eq "-pb") {
2819 $preserveblank = 1;
2820 }
2821
2822 # treat $keywordchar, $contchar and $optlineendchar as regular expressions
2823 elsif($ARGV[$i] eq "-re") {
2824 if($charperlre) { SetCharPerlre(0); }
2825 else { SetCharPerlre(1); }
2826 }
2827
2828 # Safe mode - turns off #pragma
2829 elsif($ARGV[$i] eq "-s") {
2830 SafeMode();
2831 }
2832
2833 # Undefine all macros
2834 elsif($ARGV[$i] eq "-u") {
2835 UndefAll();
2836 }
2837
2838 # print version number and exit
2839 elsif($ARGV[$i] eq "-v") {
2840 print(STDERR "filepp version ".$VERSION."\n");
2841 exit(0);
2842 }
2843
2844 # only replace macros if they appear as 'words'
2845 elsif($ARGV[$i] eq "-w") {
2846 if($bound eq '') { SetWordBoundaries(1); }
2847 else { SetWordBoundaries(0); }
2848 }
2849
2850 # default - an input file name
2851 else {
2852 if(!FileExists($ARGV[$i])) {
2853 Error("Input file \"".$ARGV[$i]."\" not readable");
2854 }
2855 AddInputFile($ARGV[$i]);
2856 }
2857
2858 $i++;
2859 }
2860
2861 # check input files have been specified
2862 if($#Inputfiles == -1) {
2863 Error("No input files given");
2864 }
2865
2866 # import macros from file if any
2867 if($#Imacrofiles >= 0) {
2868 my $file;
2869 foreach $file (@Imacrofiles) { IncludeMacros($file); }
2870 }
2871
2872 # print initial defines if debugging
2873 if($debug > 1) { PrintDefines(); }
2874
2875 # open the output file
2876 if(!$overwrite) { OpenOutputFile($outputfile); }
2877
2878 # parse all input files in order given on command line
2879 my $base_file = "";
2880 foreach $base_file (@Inputfiles) {
2881 Redefine("__BASE_FILE__", $base_file);
2882 # set open output file if in overwrite mode
2883 if($overwrite) {
2884 if($overwriteconv ne "") { # convert output filename if needed
2885 my ($in,$out) = split(/=/, $overwriteconv, 2);
2886 my $outfile = $base_file;
2887 $outfile =~ s/\Q$in\E/$out/;
2888 OpenOutputFile($outfile);
2889 }
2890 else { OpenOutputFile($base_file); }
2891 }
2892
2893 #clean visitedTable
2894 %visitedTable = ();
2895 print "\n";
2896 print $objDir . GetObjFile($base_file) . " : ";
2897 Parse($base_file);
2898 # close output file if in overwrite mode
2899 if($overwrite) { CloseOutputFile(); }
2900 }
2901
2902 printModule();
2903
2904 # close output file
2905 if(!$overwrite) { CloseOutputFile(); }
2906
2907 exit(0);
2908
2909 # Hey emacs !!
2910 # Local Variables:
2911 # mode: perl
2912 # End:
2913
2914 ########################################################################
2915 # End of file
2916 ########################################################################

Properties

Name Value
svn:executable *