unit multfile; (* DPL 2004-03-06, 2015-01-16 (* Support for including files into an input stream. (* Intended for an application that does not require Pascal formatting, (* but reads complete lines one at a time. (* You never actually work with any files, except by supplying the ( filename when the file is opened. (* At any stage, you can switch the input to a new file. (* When the new file is at EOF, and a "read" is issued, the file is (* closed and the previous one resumed transparently. This inclusion (* can be nested to any level, memory permitting. (* --- Normal mode of operation, replacing the usual Pascal style --- Instead of: assign(textfile,filename); reset(textfile) use: pushFile(filename) When another file should be included before the current file is done, use: pushFile(newfilename) Instead of: readln(textfile,line) use: line:=readLine Instead of: eof(textfilen) or: eofAll; {Are all files at EOF?} (* --- Abnormal mode of operation --- To abort a file before EOF is reached: use: popFile; To abort all files: use: closeAll; To test whether only the current file is at EOF: use: eofCurrent; (* Additional features: fileError: boolean function, was there an error during file open or read? currentFilename: string function, name of current file currentLineNo: integer function, number of line just read from current file isEmpty(var s: string): boolean function, is s empty? readData: string function, like readLine, but continue reading until a non-blank line is found, return blank only at EOF skipBlanks: skip blank lines in input: next call to readLine will be non-blank unless EOF is encountered report(items): procedure to control which messages are printed, "items" is the sum of the following options (constants with the appropriate values are defined in the interface) 1: reportnewfile - file is opened 2: reportoldfile - file is resumed 4: reportclose - file is closed 8: reporterror - a file error is encountered 16: reportrecursive - there is a recursive include The default value is items=27 (all the above except reportclose) At present you cannot turn reportrecursive off. *) interface procedure pushFile(filename: string); procedure popFile; procedure closeAll; procedure report(items: integer); function currentFilename: string; function eofAll: boolean; function eofCurrent: boolean; function fileError: boolean; function readLine: string; function readData: string; function isEmpty(var s: string): boolean; function currentLineNo: integer; procedure skipBlanks; const nextData: string = ''; const reportnewfile = 1; reportoldfile = 2; reportclose = 4; reporterror = 8; reportrecursive = 16; implementation type pfilenode = ^filenode; filenode = record name: string; actualfile: text; prev: pfilenode; lineno: integer; end; const current: pfilenode = NIL; last_valid_line_no: integer = 0; inputerror: boolean = false; reportitem: integer = reportnewfile + reportoldfile + reporterror + reportrecursive; procedure report(items: integer); begin reportitem := items end; function recursive (filename: string): boolean; var previous: pfilenode; begin if current=NIL then begin recursive:=false; exit; end; previous := current; recursive:=true; while previous <> NIL do begin if filename=previous^.name then exit; previous := previous^.prev; end; recursive:=false end; procedure pushFile(filename: string); var newnode: pfilenode; begin if recursive(filename) then begin writeln('===! Ignoring recursive include of file ',filename); exit; end; new(newnode); newnode^.name := filename; newnode^.prev := current; newnode^.lineno := 0; {$I-} assign(newnode^.actualfile,filename); reset(newnode^.actualfile); {$I+} inputerror := ioresult<>0; if inputerror then dispose(newnode) else current := newnode; if not inputerror and ((reportitem and reportnewfile)>0) then writeln ('==>> Input from file ',currentFilename); if inputerror and ((reportitem and reporterror)>0) then writeln ('==!! Could not open file ',filename); end; procedure popFile; var previous: pfilenode; begin if current=NIL then exit; if (reportitem and reportclose)>0 then writeln ('==>> Closing file ',currentFilename,' at line number ', currentLineNo:1); close(current^.actualfile); previous := current^.prev; dispose(current); current := previous; if (current<>NIL) and ((reportitem and reportoldfile)>0) then writeln ('==>> Resuming input from file ',currentFilename,' at line number ', currentLineNo:1); end; procedure closeAll; begin repeat popFile until current=NIL; end; function eofCurrent: boolean; begin eofCurrent := eof(current^.actualfile); end; function readLine: string; var s: string; begin if nextData<>'' then begin readLine:=nextData; nextData:=''; exit end; if eofAll then begin readLine:=''; exit end; {$I-} readln(current^.actualfile,s); readLine:=s; {$I+} inputerror := ioresult<>0; if not inputerror then begin inc(current^.lineno); last_valid_line_no := current^.lineno end; if inputerror and ((reportitem and reporterror)>0) then writeln ('==!! Could not read from file ',currentFilename); end; function isEmpty(var s: string): boolean; var i: integer; begin if length(s)=0 then begin isEmpty:=true; exit; end; for i:=1 to length(s) do if s[i]<>' ' then begin isEmpty:=false; exit; end; isEmpty:=true end; function readData: string; var s: string; begin if not isEmpty(nextData) then begin readData:=nextData; nextData:=''; exit end; while not eofAll do begin s:=readLine; if not isEmpty(s) then begin readData:=s; exit end; end; readData:=''; end; procedure skipBlanks; begin while nextData='' do begin nextData:=readData; if eofAll then exit end end; function eofAll: boolean; begin eofAll := true; if current=NIL then exit else if eofCurrent then begin popFile; eofAll:=eofAll; exit end; eofAll:=false end; function currentLineNo: integer; begin currentLineNo := last_valid_line_no end; function currentFilename: string; begin if current = NIL then currentFilename := 'No file open yet' else currentFilename := current^.name; end; function fileError: boolean; begin fileError := inputerror; end; end.