home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / msdos / filedocs / simraz13.arc / SIMRAZOR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1989-12-18  |  14.5 KB  |  354 lines
  1. Program simrazor;
  2. { Shortens a MailMerge export of a SimIBM database index file by removing    }
  3. { unwanted fields, or parts thereof.                                         }
  4. { Optionally, merges multiple input files.                                   }
  5. { Specify parameters on command line; call without parameters for help.      }
  6. { FreeWare by TapirSoft Gisbert W.Selke, Dec 89                              }
  7. { This programme comes as is; no guarantees whatsoever!                      }
  8.  
  9. { Compiled under MS DOS 3.3, using TurboPascal 5.5                           }
  10.  
  11. { DEFINE DEBUG }            { $DEFINE while debugging }
  12.  
  13. {$A+,B-,D+,E+,F-,I-,L+,N-,O-,V-}
  14. {$IFDEF DEBUG }
  15. {$R+,S+ }
  16. {$ELSE }
  17. {$R-,S- }
  18. {$ENDIF }
  19.  
  20. {$M 65520,0,400000 }
  21.  
  22.   Const progname     = 'SIMRAZOR';
  23.         version      = '1.3';
  24.         copyright    = 'FreeWare (c) TapirSoft Gisbert W.Selke, Dec 89';
  25.         bufsize      = 64000;
  26.         maxlength    = 50;          { maximum field length in input files }
  27.         maxinfields  = 10;          { number of fields in input files     }
  28.         maxinfiles   = 5;           { maximum number of input files       }
  29.         maxoutfields = 15;          { max number of output fields         }
  30.         fieldnum : Array [1..maxinfields] Of boolean =
  31.                     (False,False,False,True,True,True,True,False,False,False);
  32.                     { False = ASCII; True = numeric }
  33.  
  34.   Type buffer = Array [1..bufsize] Of byte;      { i/o buffer   }
  35.        bufptr = ^buffer;
  36.        name   = string[80];                      { file name    }
  37.        tentry = string[maxlength];               { single field }
  38.        entry  = Array [1..maxinfields] Of tentry;{ input record }
  39.        extry  = Array [1..maxoutfields] Of tentry;{ output record }
  40.  
  41.   Var fout     : text;                           { output file                 }
  42.       outname  : name;                           { name of output file         }
  43.       outbufptr: bufptr;                         { output buffer               }
  44.       fin      : Array [1..maxinfiles] Of text;  { input files                 }
  45.       inname   : Array [1..maxinfiles] Of name;  { names of input files        }
  46.       inbufptr : Array [1..maxinfiles] Of bufptr;{ input buffers               }
  47.       e        : Array [1..maxinfiles] Of extry; { current input records       }
  48.       eoff     : Array [1..maxinfiles] Of boolean;{ input eof flags            }
  49.       ctout    : longint;                        { count of output records     }
  50.       ctin     : Array [1..maxinfiles] Of longint;{ counts of input records    }
  51.       outfld   : Array [1..maxoutfields] Of byte;{ pointers to output fields   }
  52.       outlen   : Array [1..maxoutfields] Of integer;{ lengths of output fields }
  53.       ninfiles : byte;                           { number of input files       }
  54.       noutfields : byte;                         { number of output fields     }
  55.       choose   : byte;                           { pointer to record for output}
  56.       nopen    : byte;                           { number of open input files  }
  57.       i : byte;
  58.  
  59.   Function ReadKey : Char;
  60.   { read a char from StdIn without echoing; don't need CRT unit for this!    }
  61.   Inline($B4/$07/               {Mov ah, 7}
  62.          $CD/$21);              {Int $21}
  63.  
  64.   Function yesnoq : boolean;
  65.   { get a yes-or-no answer                                                   }
  66.     Var ch : char;
  67.   Begin                                                             { yesnoq }
  68.     Repeat
  69.       ch := UpCase(ReadKey);
  70.     Until ch In ['Y','J','1','N','0'];
  71.     writeln(ch);
  72.     yesnoq := ch In ['Y','J','1'];
  73.   End;                                                              { yesnoq }
  74.  
  75.   Procedure abort(errmsg : string; code : byte);
  76.   { abort with error message                                                 }
  77.   Begin                                                              { abort }
  78.     writeln;
  79.     writeln(errmsg);
  80.     Halt(code);
  81.   End;                                                               { abort }
  82.  
  83.   Procedure usage;
  84.   { show usage info and die                                                  }
  85.   Begin                                                              { usage }
  86.     writeln('Shorten a SimIBM index file by removing unwanted fields.');
  87.     writeln('Optionally merge sorted files.');
  88.     writeln;
  89.     writeln('This programme may be used and copied freely,');
  90.     writeln('but it comes with no guarantees whatsoever.');
  91.     writeln;
  92.     writeln('Usage:  SIMRAZOR  /F<field>... /I<inname>...  /O<outname>');
  93.     writeln('        where <field> is one of A..J, optionally followed by');
  94.     writeln('        a maximum field length (negative length to start from');
  95.     writeln('        the right) (up to ',maxoutfields,' /F options allowed),');
  96.     writeln('        <inname> is an input file name (up to ',maxinfiles,
  97.             ' allowed),');
  98.     writeln('        and <outname> is the output file name.');
  99.     writeln('        (Default extension for files: IDX)');
  100.     writeln('        A = disk; B = directory; C = file name; D = version;');
  101.     writeln('        E = size; F = type;      G = date;      H = description;');
  102.     writeln('        I = first part of dir;   J = second part of directory.');
  103.     writeln;
  104.     writeln('Example:');
  105.     writeln('SIMRAZOR /FI-1 /FJ11 /FC /FE6 /FG /FH /ISIMIBM.IDX ',
  106.             '/OSIMSHORT.IDX');
  107.     Halt(1);
  108.   End;                                                               { usage }
  109.  
  110.   Procedure getoneline(Var f : text; Var fieldout : extry);
  111.   { get one line and clean it up                                             }
  112.  
  113.     Var i, k, nf, len : byte;
  114.         exquote : boolean;
  115.         lin : string;
  116.         fields : entry;
  117.  
  118.     Procedure cleanse;
  119.     { perform the cleaning                                                   }
  120.       Var i, k, l : byte;
  121.           isquote  : boolean;
  122.     Begin                                                          { cleanse }
  123.       For i := 1 To noutfields Do
  124.       Begin { check all fields to be output }
  125.         k := outfld[i];
  126.         fieldout[i] := fields[k];
  127.         If k = 9 Then
  128.         Begin { special check for part 1 of dir field: maybe add a blank }
  129.           If fieldout[i] = 'MSDOS' Then fieldout[i] := 'MSDOS ';
  130.         End;
  131.         l := Length(fieldout[i]);
  132.         If l >= 2 Then
  133.         Begin { quoted field }
  134.           isquote := (fieldout[i][1] = '"') And (fieldout[i][l] = '"');
  135.           If isquote Then
  136.           Begin
  137.             fieldout[i] := Copy(fieldout[i],2,l-2);
  138.             l := l - 2;
  139.           End;
  140.         End
  141.           Else isquote := False;
  142.         If l > Abs(outlen[i]) Then
  143.         Begin { input field too long }
  144.           If fieldnum[k] Then
  145.           Begin { numeric field }
  146.             fieldout[i] := '';
  147.             For l := 1 To outlen[i] Do fieldout[i] := fieldout[i] + '9';
  148.           End
  149.           Else
  150.           Begin { ASCII field }
  151.             If outlen[i] >= 0 Then Delete(fieldout[i],Succ(outlen[i]),255)
  152.                               Else Delete(fieldout[i],1,l+outlen[i]);
  153.           End;
  154.         End;
  155.         If isquote Then fieldout[i] := '"' + fieldout[i] + '"';
  156.       End;
  157.     End;                                                           { cleanse }
  158.  
  159.   Begin                                                         { getoneline }
  160.     readln(f,lin);
  161.     len := Length(lin);
  162.     For i := 1 To maxinfields Do fields[i] := '';
  163.     nf := 0;
  164.     i  := 1;
  165.     exquote := True;
  166.     While (nf < maxinfields) And (i < len) Do
  167.     Begin
  168.       k := i;
  169.       Repeat
  170.         If lin[i] = '"' Then exquote := Not exquote;
  171.         Inc(i);
  172.       Until (i > len) Or ((lin[i] = ',') And exquote);
  173.       Inc(nf);
  174.       fields[nf] := Copy(lin,k,i-k);
  175.       Inc(i);
  176.     End;
  177.     i := Pos('.',fields[2]);
  178.     fields[Pred(maxinfields)] := Copy(fields[2],2,i-2);   { part 1 of dir }
  179.     If (fields[2] <> '') And (fields[2][1] = '"') Then
  180.          Delete(fields[Pred(maxinfields)],1,1);
  181.     fields[maxinfields] := Copy(fields[2],Succ(i),Length(fields[2])-i-1);
  182.     If (fields[2] <> '') And                          { part 2 of dir }
  183.        (fields[2][Length(fields[2])] = '"') Then
  184.          Delete(fields[maxinfields],Length(fields[maxinfields]),1);
  185.     cleanse;
  186.   End;                                                          { getoneline }
  187.  
  188.   Procedure getnextline;
  189.   { get next line from input file(s)                                         }
  190.     Var i, k : byte;
  191.   Begin                                                        { getnextline }
  192.     For i := 1 To ninfiles Do
  193.     Begin { read input lines, where necessary and possible }
  194.       If (e[i,1] = '') And (Not eoff[i]) Then
  195.       Begin
  196.         getoneline(fin[i],e[i]);
  197.         If IOResult <> 0 Then abort('Error reading from ' + inname[i] +
  198.                                     ' - abort!',31);
  199.         Inc(ctin[i]);
  200.         eoff[i] := EoF(fin[i]);
  201.         If eoff[i] Then Dec(nopen);
  202.       End;
  203.     End;
  204.     choose := 1;
  205.     For i := 2 To ninfiles Do
  206.     Begin { find out which of the input record to take next }
  207.       If e[i,1] <> '' Then
  208.       Begin { non-empty record }
  209.         k := 0;
  210.         While k < noutfields Do
  211.         Begin { scan fields in output order }
  212.           Inc(k);
  213.           If e[choose,k] < e[i,k] Then k := noutfields { old guess was better }
  214.           Else
  215.           Begin
  216.             If e[choose,k] > e[i,k] Then
  217.             Begin { new candidate is better }
  218.               choose := i;
  219.               k := noutfields;
  220.             End;
  221.           End;
  222.         End;
  223.       End;
  224.     End;
  225.   End;                                                         { getnextline }
  226.  
  227.   Procedure init;
  228.   { scan command line parameters                                             }
  229.     Var temp : string;
  230.         ival : longint;
  231.         icod : integer;
  232.         i : byte;
  233.   Begin                                                               { init }
  234.     ninfiles := 0;
  235.     noutfields := 0;
  236.     outname := '';
  237.     For i := 1 To ParamCount Do
  238.     Begin { scan all parameters }
  239.       temp := ParamStr(i);
  240.       If temp = '?' Then usage;
  241.       If (Length(temp) <= 2) Or ((temp[1] <> '/') And (temp[1] <> '-')) Then
  242.             abort('Unknown command line switch ' + temp,2);
  243.       For icod := 1 To Length(temp) Do temp[icod] := UpCase(temp[icod]);
  244.       Case temp[2] Of
  245.         'F' : Begin { output field spec }
  246.                 If noutfields >= maxoutfields Then
  247.                           abort('Too many output fields specified',5);
  248.                 If (temp[3] < 'A') Or (temp[3] > 'J') Then
  249.                           abort('Unknown output field spec in '+ temp,3);
  250.                 Inc(noutfields);
  251.                 outfld[noutfields] := Ord(temp[3]) - 64;
  252.                 If Length(temp) > 3 Then
  253.                 Begin { get output field length }
  254.                   {$R- } Val(Copy(temp,4,255),ival,icod);
  255.                   {$IFDEF DEBUG } {$R+ } {$ENDIF }
  256.                   If (icod <> 0) Or (Abs(ival) > 255) Then
  257.                           abort('Illegal output field width in ' + temp,4);
  258.                   outlen[noutfields] := ival;
  259.                 End
  260.                   Else outlen[noutfields] := 255;
  261.               End;
  262.         'I' : Begin { input file name }
  263.                 If ninfiles >= maxinfiles Then
  264.                           abort('Too many input files',6);
  265.                 Inc(ninfiles);
  266.                 If Pos('.',temp) = 0 Then temp := temp + '.IDX';
  267.                 inname[ninfiles] := Copy(temp,3,255);
  268.               End;
  269.         'O' : Begin { output file name }
  270.                 If outname <> '' Then
  271.                           abort('More than one output file',7);
  272.                 If Pos('.',temp) = 0 Then temp := temp + '.IDX';
  273.                 outname := Copy(temp,3,255);
  274.               End;
  275.         '?', 'H' : usage; { help screen }
  276.         Else  abort('Unknown command line switch ' + temp,2);
  277.       End;
  278.     End;
  279.     If noutfields = 0 Then abort('No output fields specified',8);
  280.     If ninfiles = 0 Then abort('No input files specified',9);
  281.     If outname = '' Then abort('No output file specified',10);
  282.   End;                                                                { init }
  283.  
  284.   Procedure openfiles;
  285.   { open all files, initialize buffers and records                           }
  286.     Var savfm, i : byte;
  287.   Begin { openfiles }
  288.     nopen := 0;
  289.     savfm := FileMode;
  290.     FileMode := 0;
  291.     For i := 1 To ninfiles Do
  292.     Begin { open all input files }
  293.       Assign(fin[i],inname[i]);
  294.       If MaxAvail > bufsize Then
  295.       Begin { set aside input buffer, if room available }
  296.         New(inbufptr[i]);
  297.         SetTextBuf(fin[i],inbufptr[i]^);
  298.       End;
  299.       Reset(fin[i]);
  300.       If IOResult <> 0 Then abort('Cannot open ' +inname[i]+ ' for input.',21);
  301.       ctin[i] := 0;                { number of records read from this file }
  302.       e[i,1] := '';                { 'no current record from file i' }
  303.       eoff[i] := EoF(fin[i]);      { eof status }
  304.       If Not eoff[i] Then Inc(nopen);
  305.     End;
  306.     FileMode := savfm;
  307.     Assign(fout,outname);
  308.     If MaxAvail > bufsize Then
  309.     Begin { set aside output buffer, if room available }
  310.       New(outbufptr);
  311.       SetTextBuf(fout,outbufptr^);
  312.     End;
  313.     Reset(fout);
  314.     If IOResult = 0 Then
  315.     Begin
  316.       write('Output file ',outname,' already exists. Continue? (y/n) ');
  317.       If Not yesnoq Then abort('Existing output file not overwritten.',23);
  318.       Close(fout);
  319.     End;
  320.     Rewrite(fout);
  321.     If IOResult <> 0 Then abort('Cannot open ' + outname + ' for output.',22);
  322.     ctout := 0;
  323.   End;                                                           { openfiles }
  324.  
  325. Begin                                                                 { main }
  326.   writeln(progname,' ',version,' - ',copyright);
  327.   writeln;
  328.   writeln('Entia non sunt multiplicanda praeter necessitatem.');
  329.   writeln;
  330.   If ParamCount = 0 Then usage;
  331.   init;
  332.   openfiles;
  333.   While nopen > 0 Do
  334.   Begin { while there are records left, process them }
  335.     getnextline;
  336.     Inc(ctout);
  337.     If Lo(ctout) = 0 Then
  338.     Begin { consolate user }
  339.       write(#13,ctout);
  340.       For i := 1 To ninfiles Do write('/',ctin[i]);
  341.     End;
  342.     For i := 1 To Pred(noutfields) Do write(fout,e[choose,i],',');
  343.     writeln(fout,e[choose,noutfields]); { that did the trick }
  344.     If IOResult <> 0 Then abort('Error writing to ' + outname + ' - abort!',32);
  345.     e[choose,1] := ''; { mark this record 'done' }
  346.   End;
  347.   For i := 1 To ninfiles Do Close(fin[i]);
  348.   Close(fout);
  349.   write(#13,ctout);
  350.   For i := 1 To ninfiles Do write('/',ctin[i]);
  351.   writeln(' records processed.');
  352.   { let DOS deallocate buffers }
  353. End.
  354.