{ EXTRACT--Extracts labeled blocks of text from a file or group of files and 
  writes them to one or more output files. 

  John Fritz 
  MCV Academic Computing
  Medical College of Virignia
  Box 16, MCV Station
  Richmond, VA   23298
  (804) 786-9843
  }

{@+ .cld
module extractTable
define verb extract
   routine cli_abort      ! abort if cli$dispatch is called
   parameter P1           label=FROM value(required, list)
   parameter P2           label=TO value(list)
   qualifier BEGIN_BLOCK  default nonnegatable value(default="{@+")
   qualifier END_BLOCK    default nonnegatable value(default="{@-")
   qualifier CHECK_DIFFERENCES placement=positional
   qualifier KEEP_PLACE	  placement=positional
   qualifier OUTPUT       value
   qualifier COMMENT      default value(default="}")
   qualifier LOG
{@- .cld}

{@+ .msg
.FACILITY EXTRACT, EXTRACT/prefix=EXTRACT__
.SEVERITY INFORMATIONAL
created/FAO_COUNT=1	"Created file !AS"
noCreate/FAO_COUNT=1	"Did not create file !AS"
equivalent 	 	"File was equivalent to previous version"
noBlocksBegun		"No blocks were begun for this file"
.SEVERITY WARNING
canopefil/FAO_COUNT=1	"Can't open file !AS"
.SEVERITY FATAL
nofile			"No files found"
noOutput/FAO_COUNT=1	"Can't use output specification !AS"
.END
{@- .msg}

{@+ .pas}
[inherit('message', 'sys$library:starlet', 'mcv:rtl', 'mcv:mcvlib'),
 check(nobounds)]

program extract;

type
   string = varying[255] of char;

[external(lib$find_file)] function find_file(
   %descr    file_spec: [readonly] string;
   %descr  result_spec:            string;
   var         context:            unsigned;
   %descr default_spec: [readonly] string := %immed 0;
   %descr related_spec: [readonly] string := %immed 0;
   var        stv_addr:            integer := %immed 0;
            user_flags:            unsigned
                     ):            integer;
   extern;

[external(lib$signal)] procedure signal(
   %immed signal: integer;
   %immed   numP: integer := %immed 1;
               a: [readonly, class_s] packed array[al..ah: integer] of char;
   %immed   more: [list] integer);
   extern;

[external(lib$stop)] procedure stop(
   %immed signal: integer;
   %immed   numP: integer := %immed 1;
               a: [readonly, class_s] packed array[al..ah: integer] of char;
   %immed   more: [list] integer);
   extern;

[external(lib$find_file_end)] function find_file_end(
   var context: unsigned
             ): integer;
   extern;

const
   recordLength = min(ord(' ')*256-2, 1000);
type
   longString = varying[recordLength+1] of char;
      {Note that there is no longString s such that s[0] (i.e. the most
       significant byte of s.length) is equal to ' '}
   atFil = @fil;
   fil = record
      name:       string;
      txt, old:   text;
      printed:    integer;
      printing:   boolean;
      headerFound: boolean;
      equal:      boolean;
      holdPlace:  boolean;
      next:       atFil;
      end;
   atTag = @tagRec;
   tagRec = record
      fil:  atFil;
      name: string;
      next: atTag;
      end;
var
   tagStart, tagSentinel: atTag;
   filStart, filSentinel: atFil;
   default: string;               

function findBlock(
   var tag: [readonly] string;
   var t: atTag;
   var stat2: integer
   ): integer;

{Modifies tagStart, tagSentinel
          filStart, filSentinel
 Reads default}

var
   f: atFil;
   stat1: integer;
   context: unsigned;
   full: string;
begin
   {look for tag}
      tagSentinel^.name := tag; t := tagStart;
      while t^.name <> tag do t := t^.next;
   if t <> tagSentinel then {tag found} findBlock := ss$_normal
   else {tag not found} begin
      {add the tag to the tag list}
         new(t); t^.next := tagStart; tagStart := t;
         t^.name := tag;
      {set full to the expanded file specification for tag}
         context := 0;
         stat1 := find_file(tag, full, context, default,, stat2, 1);
         find_file_end(context);
      if (stat1 <> rms$_fnf) and not odd(stat1) then 
         begin f := filSentinel; t^.fil := f; findBlock := stat1 end
      else begin {search for full in the file list}
         full.length := index(full, ';')-1;
         filSentinel^.name := full;
         f := filStart;
         while f^.name <> full do f := f^.next;
         f^.name := full;
         t^.fil := f;
         findBlock := ss$_normal;
         end;
      end;
   end;

procedure newFile(
   var f: atFil;
       nam: string;
       check: boolean);                                       

{Modifies filstart}

begin
   new(f); f^.next := filStart; filStart := f;
   with f^ do begin
      name := nam; printed := 0; 
      equal := check;
      if check then begin
         open(old, name, history:=readonly, 
                   record_length:=recordLength, error:=continue);
         if status(old) <> 0 then equal := false
         else reset(old);
         end;
      open(txt, name, history:=new, record_length:=recordLength,
           disposition:=delete);
      rewrite(txt);
      end;
   end;

var
   comment: char;
   keepPlace: boolean;
   checkDifferences: boolean;
   copyAll: boolean;

procedure blocks(
   var lin: [readonly] longString;
     print:            boolean);

{Reads default; comment, keepPlace, checkDifferences, copyAll
 Modifies tagStart, tagSentinel, filStart, filSentinel} 

{For each tag t in lin do 
   setBlock(t, copyAll, print, checkDifferences, keepPlace)}

var
   a, z, lim: integer;
   line: longString;
   t: atTag;
   stat1,stat2: integer;
   tag: string;
begin
   str$upcase(%descr line, %descr lin);
   lim := index(line, comment);
   if lim = 0 then lim := line.length+1;
   a := 1;
   line[lim] := comment;
   while line[a] <= ' ' do a := a+1;
   while a <> lim do begin
      line[lim] := ' ';
      z := a+1; while line[z] > ' ' do z := z+1;
      tag := substr(line, a, min(z-a,size(string)-2));
      stat1 := findBlock(tag, t, stat2);
      if copyAll then begin
         if not odd(stat1) then stop(EXTRACT__canopefil,, tag, stat1, stat2)
         else with t^ do begin
            if fil = filSentinel then begin
               newFile(fil, filSentinel^.name, checkDifferences);
               fil^.holdPlace := keepPlace;
               end;
            end;
         end;
      with t^.fil^ do begin 
         printing := print; 
         if print then headerFound := true;
         end;
      line[lim] := comment;
      a := z; while line[a] <= ' ' do a := a+1;
      end;
   end;

var
   context: unsigned;
   infileName, fullName: string;
   infile: text;

function openInfile: integer;

{Reads infileName
 Modifies context
 Opens infile}

{Opens infile using infileName and context;
 Returns an odd status code and puts the resultant name in fullName 
 if successful.
 If the file cannot be opened, returns rms$_nmf if there are no more
 files to be found; otherwise signals and returns EXTRACT__canopefil}

var
   stat1, stat2: integer;
begin
   stat1 := find_file(infileName, fullName, context,,, stat2, 2);
   if not odd(stat1) then begin
      if stat1 <> rms$_nmf then begin
         signal(EXTRACT__canopefil,, infileName, stat1, stat2);
         stat1 := EXTRACT__canopefil
         end;
      end
   else begin
      open(infile, fullName, history:=readonly, record_length:=recordLength,
           error:=continue);
      if status(infile) <= 0 then reset(infile)
      else begin
         signal(EXTRACT__canopefil,, fullName);
         stat1 := EXTRACT__canopefil;
         end;
      end;
   openInfile := stat1;
   end;

procedure findFirstInputFile;

{Reads infileName
 Writes context
 Opens infile}

{Tries to open each input file specified on the command line, in order,
 until it successfully opens a file or runs out of specifications to try
 (in which case it aborts with an error message)}

var
   stat0: integer;
begin
   context := 0;
   repeat
      stat0 := cli$get_value('from', %descr infileName);
      if not odd(stat0) then lib$stop(EXTRACT__nofile);
      until odd(openInfile);
   end;

procedure setOutputFileDefault;

{Writes default}

{Sets the default output file specification as described in the help}

var
   stat1, stat2: integer;
   outputName: string;
   defaultContext: unsigned;
begin
   if odd(cli$present('output')) then 
      cli$get_value('output', %descr outputName)
   else outputName := 'SYS$DISK:[]';
   defaultContext := 0;
   stat1 := find_file(outputName, 
                      default, defaultContext, fullName,, stat2, 1);
   find_file_end(defaultContext);
   if not odd(stat1) and (stat1 <> rms$_fnf) then 
      stop(EXTRACT__noOutput,, default, stat1, stat2);
   end;

procedure initializeFileList;

{Reads default
 Writes tagSentinel, tagStart, filSentinel, filStart,
        checkDifferences, keepPlace, comment, copyAll}

{Sets the file list to the empty list, if the TO parameter was not
 specified on the command line, or to the list of files specified by
 TO (expanded to full file specifications using default) if TO was
 specified.

 Sets copyAll false if TO was specified and true if TO was not specified.

 Sets checkDifferences, keepPlace, and comment from the command line.} 

var
   stat0, stat1, stat2: integer;
   t: atTag;
   outfileName: string;
begin
   {initialize tag list}
      new(tagSentinel); tagStart := tagSentinel;
   {initialize file list}
      new(filSentinel); filStart := filSentinel;
   {Set global parameters}
      checkDifferences := odd(cli$present('check_differences'));
      keepPlace := odd(cli$present('keep_place'));
      stat0 := cli$get_value('comment', %descr comment);
      if (stat0 = cli$_absent) or (comment <= ' ') then comment := chr(255);
   if odd(cli$present('TO')) {user specified labels} then begin
      copyAll := false; {since we only copy blocks with the specified labels}
      {open all files corresponding to specified labels}
         stat0 := cli$get_value('TO', %descr outfileName);
         str$upcase(%descr outfileName, %descr outfileName);
         while odd(stat0) do begin
            stat1 := findBlock(outfileName, t, stat2);
            if not odd(stat1) then 
               stop(EXTRACT__canopefil,, outfileName, stat1, stat2)
            else with t^ do begin
               if fil = filSentinel then begin
                  newFile(fil, filSentinel^.name,
                     check:=odd(cli$present('check_differences')));
                  with fil^ do begin
                     holdPlace := odd(cli$present('keep_place'));
                     headerFound := false;
                     printing := false;
                     end;
                  end;
               end;
            stat0 := cli$get_value('TO', %descr outfileName);
            end;
      end
   else copyAll := true; {no labels specified, so copy all we find}
   end;

procedure writeInfilesToOutfiles;
var
   beginBlock, endBlock: string;       {flags for beginBlock and endBlock lines}
   bbl, ebl: integer;		       {length of beginBlock and endBlock}
   line: longString;		       {current line}
   ll: integer;			       {length of line (with blanks trimmed)}
   f: atFil;
   compareLine: longString;	       {line from previous version of file}
   cl: integer;			       {length of trimmed compareLine}
   linesProcessed: integer;
   j: integer;
label
   loop;
begin
   {set beginBlock and endBlock}
      cli$get_value('begin_block', %descr beginBlock);
      str$trim(%descr beginBlock, %descr beginBlock);
      bbl := beginBlock.length; 
      cli$get_value('end_block', %descr endBlock);
      str$trim(%descr endBlock, %descr endBlock);
      ebl := endBlock.length;
   linesProcessed := 0;
   repeat repeat {for each input file infile} 
      while not eof(infile) do begin {for each line in infile}
         readln(infile, line);
         {set ll to index of last non-blank character in line}
            ll := line.length; while line[ll] = ' ' do ll := ll-1;
         {if this is a block trailer, turn off printing for its blocks}
            if substr(line, 1, min(ebl, ll)) = endBlock then
               blocks(substr(line, ebl+1, ll-ebl), print:=false);
         {Print line to all files with printing turned on}
            f := filStart;
            while f <> filSentinel do begin
               with f^ do if printing then begin
                  {If requested, write dummy lines to keep place}
                     if holdPlace and (printed <> linesProcessed) then 
                        for j := 1 to linesProcessed-printed do 
                           writeln(txt, '');
                  {Set equal := equal and 
                  {(trim(line) = '' or trim(line) = trim(next_nonblank(old))}
                     if equal then if line <> ' ' then begin
                        {Set compareLine to next non-blank line in old; 
                        {if none left, make compareLine blank}
                           loop:
                              if eof(old) then compareLine.length := 0
                              else begin
                                 readln(old, compareLine);
                                 if compareLine = ' ' then goto loop;
                                 end;
                        {Set cl to index of last non-blank character in
                        {compareLine}
                           cl := compareLine.length;
                           while compareLine[cl] = ' ' do cl := cl-1;
                        if substr(line, 1, ll) <> substr(compareLine, 1, cl) 
                           then begin equal := false; close(old); end;
                        end;
                  writeln(txt, line);
                  printed := linesProcessed+1;
                  end;
               f := f^.next;
               end;
         {if this is a block header, turn on printing for its blocks}
            if substr(line, 1, min(bbl, ll)) = beginBlock then
               blocks(substr(line, bbl+1, ll-bbl), print:=true);
         linesProcessed := linesProcessed+1;
         end;
      close(infile,error:=continue);
      until not odd(openInfile) 
      until not odd(cli$get_value('from', %descr infileName));
   end;

procedure closeFiles;
var
   f: atFil;
   compareLine: longString;	       {line from previous version of file}
   log: boolean;
   noCreateWarn: integer;
begin
   log := odd(cli$present('log'));
   f := filStart;
   while f <> filSentinel do begin {for all files}
      with f^ do begin
         if not headerFound then begin
            close(txt, disposition:=delete);
            noCreateWarn := EXTRACT__noCreate;
            noCreateWarn::sts$type.STS$V_SEVERITY := STS$K_WARNING;
            signal(noCreateWarn,, name, EXTRACT__noBlocksBegun);
            end
         else begin
            if equal then begin
               while not eof(old) and equal do begin
                  readln(old,compareLine);
                  if compareLine <> ' ' then equal := false;
                  end;
               end;
            if equal then begin
               close(txt, disposition:=delete);
               if log then 
                  signal(EXTRACT__noCreate,, name, EXTRACT__equivalent);
               end
            else begin
               close(txt, disposition:=save);
               if log then signal(EXTRACT__created,, name);
               end;
            end;
         end;
      f := f^.next;
      end;
   end;

var
   extractTable: [external] cli_tableType;
begin
   cli_parse_foreign(extractTable, 'extract');
   findFirstInputFile;
   setOutputFileDefault;
   initializeFileList;
   writeInfilesToOutfiles;
   closeFiles;
   end.
{@- .pas}
