ViewVC Help
View File | Revision Log | Show Annotations | View Changeset | Root Listing
root/group/trunk/OOPSE-4/scripts/filepp
Revision: 1551
Committed: Mon Oct 11 14:51:57 2004 UTC (19 years, 9 months ago) by tim
File size: 89711 byte(s)
Log Message:
remove "use bytes" which causes problem in sgi machine

File Contents

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

Properties

Name Value
svn:executable *