home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / progm / tptools.zip / ALLINST.ZIP / EDITOOLS.PAS next >
Pascal/Delphi Source File  |  1987-12-21  |  12KB  |  412 lines
  1. {                          EDITOOLS.INC
  2.                         Editor Toolbox 4.0
  3.              Copyright (c) 1985, 87 by Borland International, Inc.            }
  4.  
  5. {$I-}
  6. {$S-}
  7. {$R-}
  8.  
  9. unit EDItools;
  10.  
  11. interface
  12.  
  13. uses
  14.   Crt,                        {standard screen routines}
  15.   Dos,                        {dos calls - standard unit}
  16.   SInst,                      {fast screen routines}
  17.   EscSeq;                     {returns name for extended keystroke sequence}
  18.  
  19. const
  20.   KeyLength = 6;              {maximum bytes in keystroke sequence}
  21.   Escape = #27;
  22. type
  23.   VarString = string[DefNoCols];
  24.   KeyString = string[KeyLength];
  25.  
  26.   KeyRec =
  27.   record
  28.     Modified,
  29.     Conflict : Boolean;
  30.     Keys : KeyString;
  31.     MinCol, MaxCol : Byte;
  32.   end;
  33.  
  34. var
  35.   BlankLine : VarString;
  36.  
  37.   function FileExists(Name : VarString; var F : file) : Boolean;
  38.     {-return true and an open file if file exists}
  39.  
  40.   procedure StUpcase(var S : VarString);
  41.     {-uppercase the string}
  42.  
  43.   function GetCursorCommand : Char;
  44.     {-return cursor equivalent keys}
  45.  
  46.   function Getkey(Prompt, Choices : VarString) : Char;
  47.     {-return a legal menu choice}
  48.  
  49.   function YesNo(Prompt : VarString; Default : Char) : Boolean;
  50.     {-return True for yes, False for no}
  51.  
  52.   procedure ClrEol(Col, Row, Attr : Integer);
  53.     {-clear to end of line}
  54.  
  55.   procedure Center(Row, Attr : Byte; Prompt : varstring);
  56.     {-write the prompt centered on row with attribute attr}
  57.  
  58.   function CenterPad(S : VarString; PadCh : Char; Width : Byte) : varstring;
  59.     {-pad s on both sides with padch to total size width}
  60.  
  61.   function Pad(S : VarString; w : Byte) : VarString;
  62.     {-return a string right padded with blanks to width w}
  63.  
  64.   function TextRepresentation(var K) : VarString;
  65.     {-return a text representation of the keys}
  66.  
  67.   procedure HaltError(msg : varstring);
  68.     {-display an error message and halt}
  69.  
  70.   function FindString(IdString : String; var Deft; Size : Word) : LongInt;
  71.     {-return the location of IdString in ProgramFile and read Size bytes into
  72.      Deft.}
  73.  
  74.   function ModifyDefaults(FileOfst : LongInt; var B; Size : Word) : Boolean;
  75.     {-Write modified default settings back to disk, returning a success flag}
  76.  
  77.   procedure Initialize(Name, Version : String);
  78.     {-Set up for installation}
  79.  
  80.   procedure CleanUp;
  81.     {-Clean up at end of program}
  82.  
  83.   {==========================================================================}
  84.  
  85. implementation
  86.  
  87. const
  88.   SBSize = 65518;
  89. type
  90.   SearchBuffer = array[0..SBSize] of Char; {Used to search for ID strings}
  91.  
  92. var
  93.   Regs : Registers;
  94.   ProgramFile : file;
  95.   ProgramName : string[64];
  96.   BufPtr : ^SearchBuffer;
  97.   BytesRead : Word;
  98.   FilePtr : LongInt;
  99.   BufferFull : Boolean;
  100.  
  101.   function FileExists(Name : VarString; var F : file) : Boolean;
  102.     {-return true and an open file if file exists}
  103.   begin
  104.     Assign(F, Name);
  105.     Reset(F, 1);
  106.     FileExists := (IOResult = 0);
  107.   end;                        {fileexists}
  108.  
  109.   procedure StUpcase(var S : VarString);
  110.     {-uppercase the string}
  111.   var
  112.     I : Byte;
  113.     Len : Byte absolute S;
  114.   begin
  115.     for I := 1 to Len do
  116.       S[I] := UpCase(S[I]);
  117.   end;                        {Stupcase}
  118.  
  119.   function GetCursorCommand : Char;
  120.     {-return cursor equivalent keys. Also allows Esc, 'C', and 'R'.}
  121.   const
  122.     CursorSet : set of Char =
  123.       [^H, ^R, ^C, ^E, ^X, ^W, ^Z, ^A, ^S, ^D, ^F, ^M, 'C', 'R', ^T, ^B, #27];
  124.   var
  125.     Ch : Char;
  126.   begin
  127.     repeat
  128.       Ch := ReadKey;
  129.       if (Ch = #0) then begin
  130.         Ch := ReadKey;
  131.         case Ch of
  132.           #75 : Ch := ^S;
  133.           #77 : Ch := ^D;
  134.           #72 : Ch := ^E;
  135.           #80 : Ch := ^X;
  136.           #71 : Ch := ^T;
  137.           #73 : Ch := ^R;
  138.           #81 : Ch := ^C;
  139.           #79 : Ch := ^B;
  140.         end;
  141.       end
  142.       else
  143.         Ch := UpCase(Ch);
  144.     until (Ch in CursorSet);
  145.     GetCursorCommand := Ch;
  146.   end;                        {GetCursorCommand}
  147.  
  148.   function Getkey(Prompt, Choices : VarString) : Char;
  149.     {-return a legal menu choice}
  150.   var
  151.     Ch : Char;
  152.   begin
  153.     Write(prompt);
  154.     repeat
  155.       Ch := UpCase(ReadKey);
  156.     until Pos(Ch, choices) <> 0;
  157.     Getkey := Ch;
  158.   end;                        {GetKey}
  159.  
  160.   function YesNo(Prompt : VarString; Default : Char) : Boolean;
  161.     {-return True for yes, False for no}
  162.   var
  163.     Ch : Char;
  164.   begin
  165.     Write(Prompt, ' (Y/N/<Enter> for ', Default, ') ');
  166.     repeat
  167.       Ch := ReadKey;
  168.       if Ch = ^M then
  169.         Ch := Default;
  170.       Ch := UpCase(Ch);
  171.     until (Ch = 'Y') or (Ch = 'N');
  172.     WriteLn(Ch);
  173.     YesNo := (Ch = 'Y');
  174.   end;                        {YesNo}
  175.  
  176.   procedure ClrEol(Col, Row, Attr : Integer);
  177.     {-clear to end of line}
  178.   begin
  179.     BlankLine[0] := Chr(81-Col);
  180.     EdFastWrite(BlankLine, Row, Col, Attr);
  181.   end;
  182.  
  183.   procedure Center(Row, Attr : Byte; Prompt : VarString);
  184.     {-write the prompt centered on row with attribute attr}
  185.   begin
  186.     ClrEol(1, Row, Attr);
  187.     EdFastWrite(Prompt, Row, 41-(Length(Prompt) shr 1), Attr);
  188.   end;                        {Center}
  189.  
  190.   function CenterPad(S : VarString; PadCh : Char; Width : Byte) : VarString;
  191.     {-pad s on both sides with padch to total size width}
  192.   var
  193.     T : VarString;
  194.   begin
  195.     if Length(S) >= Width then
  196.       CenterPad := S
  197.     else begin
  198.       FillChar(T[1], Width, PadCh);
  199.       T[0] := Chr(Width);
  200.       Move(S[1], T[1+((Width-Length(S)) shr 1)], Length(S));
  201.       CenterPad := T;
  202.     end;
  203.   end;                        {CenterPad}
  204.  
  205.   function Pad(S : VarString; W : Byte) : VarString;
  206.     {-return a string right padded with blanks to width w}
  207.   begin
  208.     while Length(S) < W do
  209.       S := S+' ';
  210.     Pad := S;
  211.   end;                        {pad}
  212.  
  213.   function TextRepresentation(var K) : VarString;
  214.     {-return a text representation of the keys}
  215.   var
  216.     KR : KeyRec absolute K;
  217.     P, Len : Byte;
  218.     Ch : Char;
  219.     Dis : VarString;
  220.   begin                       {TextRepresentation}
  221.     with KR do begin
  222.       P := 1;
  223.       Len := Length(Keys);
  224.       Dis := '';
  225.       while P <= Len do begin
  226.         Ch := Keys[P];
  227.         case Ch of
  228.           #0 : if (P = Len) then
  229.                   {a lone null, where did it come from?}
  230.                   Dis := Dis+'<Null>'
  231.                 else begin
  232.                   {an escape sequence}
  233.                   P := Succ(P);
  234.                   Dis := Dis + EscapeSequence(Keys[P]);
  235.                 end;
  236.            #27 :              {escape key}
  237.              Dis := Dis + '<Esc>';
  238.            #1..#31 :          {control char}
  239.              Dis := Dis + '<Ctrl' + Chr(Ord(Ch)+64) + '>';
  240.            #127 :             {ctrl-backspace = ASCII DEL}
  241.              Dis := Dis + '<CtrlBks>';
  242.         else               {normal char - shouldn't be any used as commands}
  243.           Dis := Dis + Ch;
  244.         end; {case}
  245.         P := Succ(P);
  246.       end; {while}
  247.     end; {with}
  248.     TextRepresentation := Dis;
  249.   end;                        {TextRepresentation}
  250.  
  251.   procedure HaltError(Msg : Varstring);
  252.     {-Display an error message and halt}
  253.   begin                       {HaltError}
  254.     RestoreScreen;
  255.     WriteLn;
  256.     WriteLn(Msg);
  257.     Halt(1);
  258.   end;                        {HaltError}
  259.  
  260.   {$L SEARCH}
  261.   {$F+}
  262.   function Search(var Buffer; BufLength : Word; St : String) : Word; external;
  263.     {-Search through Buffer for St. BufLength is length of range to search.
  264.       Returns 0 if not found. Otherwise, the result is the index into an
  265.       array whose lower bound is 1. Subtract 1 for 0-based arrays.}
  266.   {$F-}
  267.  
  268.   function FindString(IdString : String; var Deft; Size : Word) : LongInt;
  269.     {-return the location of IdString in ProgramFile and read Size bytes into
  270.      Deft.}
  271.   const
  272.     SeekErrorMsg : string[30] = 'Seek error while reading from ';
  273.     ReadErrorMsg : string[22] = 'I/O error reading from ';
  274.   var
  275.     I, BufPos,
  276.     IdSize, BufSize : Word;
  277.     FSTemp : LongInt;
  278.   label
  279.     FoundIdString;
  280.  
  281.   begin
  282.     IdSize := Succ(Length(IdString));
  283.     BufSize := SizeOf(SearchBuffer);
  284.  
  285.     {if we have a full buffer, see if it contains the ID string}
  286.     if BufferFull then begin
  287.       BufPos := Search(BufPtr^, BytesRead, IdString);
  288.       if BufPos <> 0 then
  289.         goto FoundIdString;
  290.     end;
  291.  
  292.     {point at start of file}
  293.     Seek(ProgramFile, 0);
  294.     if (IOResult <> 0) then
  295.       HaltError(SeekErrorMsg + ProgramName);
  296.  
  297.     {Read the first bufferful}
  298.     BlockRead(ProgramFile, BufPtr^, BufSize, BytesRead);
  299.     if (IOResult <> 0) then
  300.       HaltError(ReadErrorMsg + ProgramName);
  301.  
  302.     {set flag to indicate the buffer is full}
  303.     BufferFull := True;
  304.  
  305.     {keep track of file pointer}
  306.     FilePtr := BytesRead;
  307.  
  308.     {scan the first buffer}
  309.     BufPos := Search(BufPtr^, BytesRead, IdString);
  310.  
  311.     {loop until IdString found or end of file reached}
  312.     while (BufPos = 0) and (BytesRead >= IdSize) do begin
  313.  
  314.       {Move the tail end of the buffer to the front of the buffer}
  315.       Move(BufPtr^[BytesRead-IdSize], BufPtr^, IdSize);
  316.  
  317.       {Read the next bufferful}
  318.       BlockRead(ProgramFile, BufPtr^[IdSize], BufSize-IdSize, BytesRead);
  319.  
  320.       {keep track of where we are in the file}
  321.       FilePtr := FilePtr + BytesRead;
  322.  
  323.       {adjust BytesRead to indicate the actual number of bytes in the buffer}
  324.       BytesRead := BytesRead + IdSize;
  325.  
  326.       {search the buffer for the IdString}
  327.       BufPos := Search(BufPtr^, BytesRead, IdString);
  328.     end;
  329.  
  330. FoundIdString:
  331.     if (BufPos = 0) then
  332.       FSTemp := 0
  333.     else begin
  334.       {account for fact that BufPtr^ is a 0-based array}
  335.       Dec(BufPos);
  336.  
  337.       {calculate the actual position in the file}
  338.       FSTemp := (FilePtr - BytesRead) + BufPos + IdSize;
  339.  
  340.       {get the existing default parameter area into Deft}
  341.  
  342.       {Use contents of existing buffer if possible}
  343.       if (BytesRead - BufPos) > Size then
  344.         Move(BufPtr^[BufPos + IdSize], Deft, Size)
  345.       else begin
  346.  
  347.         {seek to the right location}
  348.         Seek(ProgramFile, FSTemp);
  349.         if (IOResult <> 0) then
  350.           HaltError(SeekErrorMsg + ProgramName);
  351.  
  352.         {read directly into Deft from ProgramFile}
  353.         BlockRead(ProgramFile, Deft, Size, I);
  354.         if I <> Size then
  355.            HaltError(ReadErrorMsg + ProgramName);
  356.       end;
  357.     end;
  358.  
  359.     FindString := FSTemp;
  360.   end;                      {findstring}
  361.  
  362.   function ModifyDefaults(FileOfst : LongInt; var B; Size : Word) : Boolean;
  363.     {-Write modified default settings back to disk, returning a success flag}
  364.   var
  365.     BytesWritten : Word;
  366.   begin                       {ModifyDefaults}
  367.     {seek into file}
  368.     Seek(ProgramFile, FileOfst);
  369.     if (IOResult <> 0) then
  370.       HaltError('Seek error while writing to '+ ProgramName);
  371.  
  372.     {write modified defaults}
  373.     BlockWrite(ProgramFile, B, Size, BytesWritten);
  374.  
  375.     {return success/failure flag}
  376.     ModifyDefaults := (BytesWritten = Size);
  377.   end;                        {ModifyDefaults}
  378.  
  379.   procedure Initialize(Name, Version : String);
  380.     {-Set up for installation}
  381.   begin                       {Initialize}
  382.     {setup screen}
  383.     SetColor(TiColor);
  384.     ClrScr;
  385.  
  386.     {save the name of the program for other routines}
  387.     ProgramName := Name;
  388.  
  389.     {signon message}
  390.     WriteLn(^M^J, ProgramName, ' Installation Program Version ', Version, ^M^J);
  391.  
  392.     {Make sure executable file is found}
  393.     if not(FileExists(ProgramName, ProgramFile)) then
  394.       HaltError('Executable file '+ProgramName+' not found');
  395.  
  396.     {get a work area}
  397.     New(BufPtr);
  398.     BufferFull := False;
  399.  
  400.     {anything else}
  401.     FillChar(BlankLine[1], 80, #32);
  402.   end;                        {Initialize}
  403.  
  404.   procedure CleanUp;
  405.     {-Clean up at end of program}
  406.   begin                       {CleanUp}
  407.     Close(ProgramFile);
  408.     RestoreScreen;
  409.   end;                        {CleanUp}
  410.  
  411. end.
  412.