home *** CD-ROM | disk | FTP | other *** search
/ The CIA World Factbook 1992 / k3bimage.iso / sel / 02 / 0019 / escrub.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-12-02  |  14.3 KB  |  530 lines
  1. {$C-,V-,K-,R-,U-}
  2. {$G512,P512,D-}
  3. (****************************************************************************)
  4. (*                                                                          *)
  5. (*                         P & M  Software Company                          *)
  6. (*                         3104 E. Camelback Rd. #503                       *)
  7. (*                         Phoenix, Arizona 85016                           *)
  8. (*                                                                          *)
  9. (*                         November 15, 1989                                *)
  10. (*                                                                          *)
  11. (****************************************************************************)
  12. (*                                                                          *)
  13. (*                        USES MAX HEAP OF $2000                            *)
  14. (*                                                                          *)
  15. (****************************************************************************)
  16.  
  17. PROGRAM
  18.    escrub;
  19. TYPE
  20.    KEYTYPE              = STRING[7];
  21.    CHARACTERS           = STRING[255];
  22.    STRING80             = STRING[80];
  23.    STRING20             = STRING[20];
  24.    BYTEptr              = ^BYTE;
  25.    double               = ARRAY[1..4] OF BYTE;
  26.    ParmBlk              = RECORD
  27.                              SegAds  : INTEGER;
  28.                              CmdPtr  : BYTEptr;
  29.                              Fcb1Ptr : BYTEptr;
  30.                              Fcb2Ptr : BYTEptr
  31.                           END;
  32.    registerset          = RECORD
  33.                              AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : INTEGER;
  34.                           END;
  35. VAR
  36.    inpath               : CHARACTERS;
  37.    infile_name          : CHARACTERS;
  38.    file_mask            : STRING80;
  39.    file_name            : STRING20;
  40.    gerr                 : INTEGER;
  41.    outfile_name         : CHARACTERS;
  42.    infile               : text[$2000];
  43.    outfile              : text[$2000];
  44.    tempfile             : text[$2000];
  45.    infile_rec           : CHARACTERS;
  46.    line_count           : INTEGER;
  47.    regs                 : registerset;
  48.    gmask                : ARRAY[1..64] OF CHAR;
  49.    dtaseg, dtaofs       : INTEGER;
  50.    dta                  : RECORD
  51.                              dta_dos      : ARRAY[1..21] OF BYTE;
  52.                              dta_attrib   : BYTE;
  53.                              dta_time     : INTEGER;
  54.                              dta_date     : INTEGER;
  55.                              dta_size     : double;
  56.                              dta_fname    : ARRAY[1..13] OF CHAR;
  57.                              dta_fill     : ARRAY[1..32] OF CHAR;
  58.                           END;
  59.    Fcb1                 : ARRAY[0..63] OF CHAR;
  60.    Fcb2                 : ARRAY[0..63] OF CHAR;
  61.    PathZ                : ARRAY[0..80] OF CHAR;
  62.    CmdLineZ             : ARRAY[0..127] OF CHAR;
  63.    BlockValue           : ParmBlk;
  64.    netseq               : ARRAY[1..999] OF INTEGER;
  65.  
  66.    PROCEDURE
  67.       move_dta(VAR error : INTEGER);
  68.    BEGIN
  69.       WITH regs DO BEGIN
  70.          AX := $1A00;
  71.          DS := seg(dta);
  72.          DX := ofs(dta);
  73.          msdos(regs);
  74.          error := lo(AX);
  75.       END;
  76.    END;
  77.  
  78.    PROCEDURE
  79.       restore_dta(VAR error : INTEGER);
  80.    BEGIN
  81.       WITH regs DO BEGIN
  82.          AX := $1A00;
  83.          DS := dtaseg;
  84.          DX := dtaofs;
  85.          msdos(regs);
  86.          error := lo(AX);
  87.       END;
  88.    END;
  89.  
  90.    PROCEDURE
  91.       save_dta(VAR error : INTEGER);
  92.    BEGIN
  93.       WITH regs DO BEGIN
  94.          AX := $2F00;
  95.          msdos(regs);
  96.          dtaseg := ES;
  97.          dtaofs := BX;
  98.          error  := lo(AX);
  99.       END;
  100.    END;
  101.  
  102.    PROCEDURE
  103.       getfirst(     buffer : STRING80;
  104.                 VAR namr   : STRING20;
  105.                 VAR error  : INTEGER    );
  106.    VAR
  107.       i    :  INTEGER;
  108.    BEGIN
  109.       FOR i:=1 TO 64 DO
  110.          gmask[i] := #00;
  111.       save_dta(error);
  112.       IF (error <> 0) THEN BEGIN
  113.          WriteLn('Unable to get current DTA address.');
  114.          flush(output);
  115.          halt(1);
  116.       END;
  117.       move_dta(error);
  118.       IF (error <> 0) THEN BEGIN
  119.          WriteLn('Cannot reset DTA address.');
  120.          flush(output);
  121.          halt(1);
  122.       END;
  123.       FOR i := 1 TO Length(buffer) DO
  124.          gmask[i] := buffer[i];
  125.       WITH regs DO BEGIN
  126.          AX := $4E00;
  127.          DS := Seg(gmask);
  128.          DX := Ofs(gmask);
  129.          CX := 0;
  130.          msdos(regs);
  131.          error:=lo(AX);
  132.       END;
  133.       IF (error = 0) THEN BEGIN
  134.           WITH dta DO BEGIN
  135.               i := 1;
  136.               REPEAT
  137.                   namr[i] := dta_fname[i];
  138.                   i := succ(i);
  139.               UNTIL (dta_fname[i] = #00);
  140.               namr[0] := CHR(pred(i));
  141.           END;
  142.       END
  143.       ELSE
  144.           restore_dta(i);
  145.    END;
  146.  
  147.    PROCEDURE
  148.       getnext( VAR namr   : STRING20;
  149.                VAR error  : INTEGER );
  150.    VAR
  151.       i    : INTEGER;
  152.    BEGIN
  153.       WITH regs DO BEGIN
  154.          AX := $4F00;
  155.          CX := 16;
  156.          msdos(regs);
  157.          error := lo(AX);
  158.       END;
  159.       IF (error = 0) THEN BEGIN
  160.           i := 1;
  161.           WITH dta DO BEGIN
  162.               REPEAT
  163.                   namr[i] := dta_fname[i];
  164.                   i := succ(i);
  165.               UNTIL (dta_fname[i] = #00);
  166.               namr[0] := CHR(pred(i));
  167.           END;
  168.       END
  169.       ELSE
  170.           restore_dta(i);
  171.    END;
  172.  
  173.    FUNCTION
  174.       DOS : INTEGER;
  175.    BEGIN
  176.       regs.AX:=$3000;
  177.       msdos(regs);
  178.       DOS:=Lo(regs.AX);
  179.    END;
  180.  
  181.    FUNCTION
  182.       PSPaddr : BYTEptr;
  183.    BEGIN
  184.       IF (DOS < 3) THEN
  185.          PSPaddr:=Ptr(Cseg,0)
  186.       ELSE BEGIN
  187.          WITH regs DO BEGIN
  188.             AX:=$6200;
  189.             msdos(regs);
  190.             PSPaddr:=Ptr(BX,0)
  191.          END;
  192.       END;
  193.    END;
  194.  
  195.    PROCEDURE
  196.       DosPgm(VAR regis : registerset); external 'DOSPGM.COM';
  197.  
  198.    PROCEDURE
  199.       ExecPgm(    PathName   : STRING80;
  200.               VAR CmdLine    : CHARACTERS;
  201.               VAR ErrorCode  : INTEGER;
  202.               VAR ReturnCode : INTEGER );
  203.    VAR
  204.       TempPtr    : BYTEptr;
  205.       PSPSeg     : INTEGER;
  206.       PathLen    : INTEGER;
  207.       CmdLen     : INTEGER;
  208.    BEGIN
  209.       TempPtr:=PSPaddr;
  210.       PSPSeg:=Seg(TempPtr^);
  211.       BlockValue.SegAds:=MemW[PSPSeg:$2C];
  212.  
  213.       BlockValue.CmdPtr := Addr(CmdLine);
  214.       CmdLen := Length(CmdLine);
  215.       Move(CmdLine[1],CmdLineZ,CmdLen);
  216.       CmdLineZ[CmdLen] := #00;
  217.       CmdLen := Succ(CmdLen);
  218.       CmdLine[CmdLen] := ^M;
  219.  
  220.       WITH regs DO BEGIN
  221.          AX:=$2901;
  222.          DS:=Seg(CmdLineZ);
  223.          SI:=Ofs(CmdLineZ);
  224.          ES:=Seg(Fcb1);
  225.          DI:=Ofs(Fcb1);
  226.          msdos(regs);
  227.          AX:=$2901;
  228.          ES:=Seg(Fcb2);
  229.          DI:=Ofs(Fcb2);
  230.          msdos(regs);
  231.  
  232.          BlockValue.Fcb1Ptr:=Addr(Fcb1);
  233.          BlockValue.Fcb2Ptr:=Addr(Fcb2);
  234.          AX:=$4B00;
  235.          ES:=Seg(BlockValue);
  236.          BX:=Ofs(BlockValue);
  237.          PathLen:=Length(PathName);
  238.          Move(PathName[1],PathZ,PathLen);
  239.          PathZ[PathLen]:=#00;
  240.          DS:=Seg(PathZ);
  241.          DX:=Ofs(PathZ);
  242.          DosPgm(regs);
  243.          IF ((Flags AND 1) <> 0) THEN BEGIN
  244.             ErrorCode:=AX;
  245.             ReturnCode:= -1;
  246.          END
  247.          ELSE BEGIN
  248.             ErrorCode:=0;
  249.             AX:=$4D00;
  250.             msdos(regs);
  251.             ReturnCode:=(AX AND $00FF);
  252.          END;
  253.       END;
  254.    END;
  255.  
  256.    FUNCTION
  257.       GetEnUtl(EnVar : CHARACTERS) : CHARACTERS;
  258.  
  259.       FUNCTION
  260.          RetEnUtl(VAR EnvPos : INTEGER) : CHARACTERS;
  261.       TYPE
  262.          Environment = ARRAY[1..32767] of CHAR;
  263.       VAR
  264.          EnvPtr  : ^Environment;
  265.          StrLen  : INTEGER;
  266.          I       : INTEGER;
  267.          Ch      : CHAR;
  268.          Str     : CHARACTERS;
  269.          TempPtr : BYTEptr;
  270.       BEGIN
  271.          TempPtr:=PSPaddr;
  272.          EnvPtr:=Ptr(MemW[Seg(TempPtr^):$2C],0);
  273.          StrLen:=0;
  274.          I:=EnvPos;
  275.          Ch:=EnvPtr^[I];
  276.          WHILE (Ch <> #00) DO BEGIN
  277.             StrLen:=Succ(StrLen);
  278.             Str[StrLen]:=Ch;
  279.             I:=Succ(I);
  280.             Ch:=EnvPtr^[I]
  281.          END;
  282.          Str[0]:=CHR(StrLen);
  283.          IF (StrLen <> 0) THEN
  284.             EnvPos:=Succ(I);
  285.          RetEnUtl:=Str
  286.       END;
  287.  
  288.    VAR
  289.       EnvPos   : INTEGER;
  290.       EnvStr   : CHARACTERS;
  291.       EqualPos : INTEGER;
  292.       Found    : BOOLEAN;
  293.    BEGIN
  294.       Found :=FALSE;
  295.       EnvPos:=1;
  296.       EnvStr:=RetEnUtl(EnvPos);
  297.       WHILE ((NOT Found) AND (ORD(EnvStr[0]) <> 0)) DO BEGIN
  298.          EqualPos:=Pos('=',EnvStr);
  299.          IF (EnVar = Copy(EnvStr,1,Pred(EqualPos))) THEN
  300.             Found:=TRUE
  301.          ELSE
  302.             EnvStr:=RetEnUtl(EnvPos);
  303.       END;
  304.       IF (Found) THEN
  305.          GetEnUtl:=Copy(EnvStr,Succ(EqualPos),66)
  306.       ELSE
  307.          GetEnUtl[0]:=#00;
  308.    END;
  309.  
  310.    PROCEDURE
  311.       shell(p : CHARACTERS);
  312.    LABEL
  313.       Shex;
  314.    VAR
  315.       ComSpec    : STRING80;
  316.       CmdLine    : CHARACTERS;
  317.       ddir       : STRING80;
  318.       ecode      : INTEGER;
  319.       rcode      : INTEGER;
  320.    BEGIN
  321.       ComSpec:=GetEnUtl('COMSPEC');
  322.       CmdLine:=' /C ' + p + ' ';
  323.       IF (Length(ComSpec) = 0) THEN
  324.          ecode:=98
  325.       ELSE
  326.          ExecPgm(ComSpec,CmdLine,ecode,rcode);
  327.       CASE ecode OF
  328.           0  : exit;
  329.           8  : WriteLn('Not enough memory to load COMMAND.COM.');
  330.           98 : WriteLn('The COMSPEC environment parameter is not set.');
  331.       ELSE
  332.          WriteLn('Cannot find COMMAND.COM.');
  333.       END;
  334.       flush(output);
  335.       halt(1);
  336.    END;
  337.  
  338.    PROCEDURE
  339.       UpString(VAR s    : CHARACTERS);
  340.    VAR
  341.       i                 : INTEGER;
  342.    BEGIN
  343.       FOR i:=1 TO Length(s) DO
  344.          s[i] := upcase(s[i]);
  345.    END;
  346.  
  347.    PROCEDURE
  348.       badfilename(VAR fn  : CHARACTERS);
  349.    BEGIN
  350.       writeln('ERROR: cannot open ',fn,' for input');
  351.       flush(output);
  352.    END;
  353.  
  354.    FUNCTION
  355.       echolist(VAR s  : CHARACTERS) : BOOLEAN;
  356.    LABEL
  357.       N1false, N1true;
  358.    VAR
  359.       k  : INTEGER;
  360.    BEGIN
  361.       IF (s[1] <> 'E') THEN
  362.          goto N1false;
  363.       FOR k:=2 TO 3 DO BEGIN
  364.          IF ((s[k] < '0') OR (s[k] > '9')) THEN
  365.             goto N1false;
  366.       END;
  367.       FOR k:=5 TO 7 DO BEGIN
  368.          IF ((s[k] < '0') OR (s[k] > '9')) THEN
  369.             goto N1false;
  370.       END;
  371.       IF (s[4] <> '/') THEN
  372.          goto N1false;
  373.       CASE s[8] OF
  374.          ' ' : ;
  375.          'p' : ;
  376.          'a' : ;
  377.          'g' : ;
  378.          's' : ;
  379.       ELSE
  380.          goto N1false;
  381.       END;
  382.       IF (s[9] <> ' ') THEN
  383.          goto N1false;
  384.       IF (s[56] <> ' ') THEN
  385.          goto N1false;
  386.       FOR k:=57 TO 59 DO BEGIN
  387.          IF ((s[k] < '0') OR (s[k] > '9')) THEN
  388.             goto N1false;
  389.       END;
  390.       FOR k:=61 TO 63 DO BEGIN
  391.          IF ((s[k] < '0') OR (s[k] > '9')) THEN
  392.             goto N1false;
  393.       END;
  394.       IF (s[60] <> '/') THEN
  395.          goto N1false;
  396.       IF (s[64] <> ' ') THEN
  397.          goto N1false;
  398. N1true:
  399.       echolist := TRUE;
  400.       exit;
  401. N1false:
  402.       echolist := FALSE;
  403.    END;
  404.  
  405.    PROCEDURE
  406.       process_outfile(VAR s  : CHARACTERS);
  407.    VAR
  408.       cnet    : INTEGER;
  409.       verr    : INTEGER;
  410.       k       : INTEGER;
  411.       seqst   : STRING[10];
  412.    BEGIN
  413.       val(copy(s,57,3),cnet,verr);
  414.       netseq[cnet] := Succ(netseq[cnet]);
  415.       str(netseq[cnet]:5,seqst);
  416.       FOR k:=1 TO 5 DO BEGIN
  417.          IF (seqst[k] = ' ') THEN
  418.             seqst[k]:='0';
  419.       END;
  420.       writeln(outfile,copy(s,1,7),' ',seqst,' ',copy(s,8,241));
  421.       line_count:=Succ(line_count);
  422.    END;
  423.  
  424.    PROCEDURE
  425.       process_temp;
  426.    VAR
  427.       infilekey : KEYTYPE;
  428.       tempkey   : KEYTYPE;
  429.       hold_rec  : CHARACTERS;
  430.    BEGIN
  431.       assign(outfile,outfile_name);
  432.       {$I-}
  433.       rewrite(outfile);
  434.       {$I+}
  435.       IF (IOresult <> 0) THEN BEGIN
  436.          writeln('ERROR: cannot open ',outfile_name,' for output');
  437.          flush(output);
  438.          halt(1);
  439.       END;
  440.       assign(tempfile,'$$TEMP');
  441.       {$I-}
  442.       reset(tempfile);
  443.       {$I+}
  444.       tempkey := #00#00#00#00#00#00#00;
  445.       WHILE (NOT eof(tempfile)) DO BEGIN
  446.          readln(tempfile,infile_rec);
  447.          IF (tempkey[1] = #00) THEN BEGIN
  448.             hold_rec:=infile_rec;
  449.             infilekey:=copy(infile_rec,1,7);
  450.          END;
  451.          tempkey:=copy(infile_rec,1,7);
  452.          IF (tempkey <> infilekey) THEN
  453.             writeln(outfile,infilekey,copy(hold_rec,15,241));
  454.          hold_rec:=infile_rec;
  455.          infilekey:=copy(infile_rec,1,7);
  456.       END;
  457.       IF (tempkey[1] <> #00) THEN
  458.          writeln(outfile,tempkey,copy(hold_rec,15,241));
  459.       close(tempfile);
  460.       close(outfile);
  461.    END;
  462.  
  463. LABEL
  464.    S1loop;
  465. VAR
  466.    k    : INTEGER;
  467. BEGIN
  468.    lowvideo;
  469.    writeln('ESCRUB Version 001');
  470.    writeln;
  471.    flush(output);
  472.    IF (ParamCount < 2) THEN BEGIN
  473.       writeln('ERROR: too few command line arguments');
  474.       writeln('       The correct syntax is: ESCRUB msgpath outfile');
  475.       flush(output);
  476.       halt(1);
  477.    END;
  478.    inpath := ParamStr(1) + '\GTMSGS\';
  479.    UpString(inpath);
  480.    outfile_name := ParamStr(2);
  481.    UpString(outfile_name);
  482.    assign(outfile,outfile_name);
  483.    {$I-}
  484.    rewrite(outfile);
  485.    {$I+}
  486.    IF (IOresult <> 0) THEN BEGIN
  487.       writeln('ERROR: cannot open ',outfile_name,' for output');
  488.       flush(output);
  489.       halt(1);
  490.    END;
  491.    FOR k:=1 TO 999 DO
  492.       netseq[k]:=0;
  493.    line_count:=0;
  494.    file_mask := inpath + '?????.MSG';
  495.    getfirst(file_mask,file_name,gerr);
  496.    WHILE (gerr = 0) DO BEGIN
  497.       restore_dta(gerr);
  498. (*** PROCESS ***)
  499.       infile_name := inpath + file_name;
  500.       writeln('Processing: ',infile_name);
  501.       flush(output);
  502.       assign(infile,infile_name);
  503.       {$I-}
  504.       reset(infile);
  505.       {$I+}
  506.       IF (IOresult <> 0) THEN BEGIN
  507.          badfilename(infile_name);
  508.          goto S1loop;
  509.       END;
  510.       WHILE (NOT eof(infile)) DO BEGIN
  511.          fillchar(infile_rec,100,0);
  512.          readln(infile,infile_rec);
  513.          IF (echolist(infile_rec)) THEN
  514.             process_outfile(infile_rec);
  515.       END;
  516. (***************)
  517.       close(infile);
  518. S1loop:
  519.       save_dta(gerr);
  520.       move_dta(gerr);
  521.       getnext(file_name,gerr);
  522.    END;
  523.    close(outfile);
  524.    IF (line_count > 0) THEN BEGIN
  525.        shell('sort <'+outfile_name+' >$$TEMP');
  526.        process_temp;
  527.        shell('del  $$TEMP');
  528.    END;
  529. END.
  530.