Stars of Shareware: Programmierung/SOURCE.mdf/programm/msdos/pascal/pxl214a/pxlmenu.pas

Pascal/Delphi Source File | 1993-02-14 | 23.7 KB | 700 lines

{$R-}    {Range checking off}                                         {.CP14}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}

Unit PXLMENU;

Interface

Uses
  Crt,
  Dos,
  PXLINIT;


procedure Menu;
procedure SetStyle;
procedure LoadReserv;    {See comments in Implementation}
procedure Initialize;

{===========================================================================}

Implementation

procedure Menu;                                                        {.CP7}
var
   Answer: char;
   Ext,NameFirm,
   Instructed,
   NameInComLine,
   GotFile:        boolean;

   procedure EnterName;                                               {.CP10}
   begin
      Blank(10,17);
      CenterCRT('What File do you want to list?',10,Bright,0);
      GotoXY(34,12); Filename := EditTrm(40);  {instead of read for neat Esc}
      if (FileName[1]=#27) or (FileName[1]=#3) then
         GetOutOfHere;
      FixupFileName(FileName);
      Command := #0;
   end; {EnterName}

   procedure GetInstructions(Ans: CMD);                               {.CP18}
   var
      B:   byte;

   begin
      Instructed := False;
      Ans := InCapitals(Ans);
      if (pos('F',Ans)<>0) and (Inst.Bt[FF]=12) then
         FFeed := True else FFeed := False;
      If (pos('V',Ans)<>0) then begin
         Vanilla := True;
         Plain := True;
         XRef := False;
         XRefOnly := False;
         NumberLines := False;
         Mrk := False;
         Instructed := True;
      end {if Vanilla}
      else begin                                                      {.CP24}
         Vanilla := False;
         if pos('X',Ans)<>0 then XRef := True else XRef := False;
         if pos('P',Ans)<>0 then begin
            Plain := True;
            Ans := 'P'  { P blanks L and M }
         end {if P}
         else {not plain}
            Plain := False;
         if pos('L',Ans)<>0
            then NumberLines := True
            else Numberlines := False;
         if pos('M',Ans)<>0 then Mrk  := True else Mrk  := False;
         if XRef and not (Plain or NumberLines or Mrk)
            then XRefOnly := True
            else XRefOnly := False;
         if Plain or NumberLines or XRef or Mrk then
            Instructed := True;
         if InABatch and (not Instructed) then begin
            Plain := True;
            Instructed := True
         end {if InABatch &c}
      end; {else not Vanilla}
   end; {GetInstructions}

   procedure ReadComLine;                                             {.CP21}
   var
      B:      byte;

      function OutputPeeled(C: CMD): string;
      var
         B,Len:   byte;
         S:       Str40;
      begin
         B := pos('"',C);
         S := '';
         delete(C,B,1);         {remove 1st "}
         while (C[B]<>'"') and (B<=length(C)) do begin
            S := S + C[B];
            delete(C,B,1);
         end; {while not "}
         if C[B]='"' then delete(C,B,1);
         if S<>'' then
            OutputDevice := S;
         OutputPeeled := C
      end; {OutputPeeled}

   begin  {ReadComLine}                                               {.CP19}
      Command := '';
      Instructed := False;
      if ParamCount=0 then
         FileName := ''
      else begin
         FileName := InCapitals(ParamStr(1));
         if pos('"',FileName)<>0 then FileName := OutputPeeled(FileName);
         if length(FileName)>0 then FixupFileName(FileName);
         if ParamCount>1 then begin
            for B := 2 to ParamCount do
               Command := Command + InCapitals(ParamStr(B));
            if pos('"',Command)<>0 then Command := OutputPeeled(Command);
            if pos('BAT',Command)<>0 then InABatch := True;
            if Escape then GetOutOfHere;
            GetInstructions(Command);
         end {else if got more params}
      end {else got params}
    end; {ReadComLine}

   function LongDate(Day,Month,Year: word): Str20;                     {.CP9}
   const
      Months: array[1..12] of Str5 = (
              'Jan.','Feb.','March','April','May','June',
              'July','Aug.','Sept.','Oct.','Nov.','Dec.');
   begin {LongDate}
      LongDate := Months[Month] + ' ' + StrgI(Day,1) + ', '
                + StrgI(Year,1);
   end; {LongDate}

   function ShortDate(Day,Month,Year: word): Str9;                     {.CP5}
   begin {ShortDate}
      ShortDate := StrgI(Month,1) + '/' + StrgI(Day,1) + '/'
                + StrgI(Year-1900,1);
   end; {ShortDate}

   function LongTime(Hour,Min,Sec: word): Str20;                      {.CP23}
   var
      Temp: Str20;
   begin
      if Sec>=30 then inc(Min);
      if Min>59 then begin
         inc(Hour);
         Min := 0;
      end; {if Min}
      Temp := ' pm';
      case hour of
         0:      begin
                    Hour := 12;
                    Temp := ' am'
                 end; {midnight-1 am}
         13..24: Hour := Hour - 12;
         else    Temp := ' am'
      end; {case hour}
      Temp := StrgI(Min,1) + Temp;
      if Min<10
         then LongTime := StrgI(Hour,1) + ':0' + Temp
         else LongTime := StrgI(Hour,1) + ':' + Temp
   end; {LongTime}

   function MilTime(Hour,Min,Sec: word): Str10;
   begin
      if Sec>29 then inc(Min);
      if Min>59 then begin
         inc(Hour);
         Min := 0;
      end; {if Min}
      if Hour>23 then Hour := 0;
      if Min<10
         then MilTime := StrgI(Hour,1) + ':0' + StrgI(Min,1)
         else MilTime := StrgI(Hour,1) + ':'  + StrgI(Min,1)
   end; {MilTime}

   procedure MakeFileDateAndTime(FilName: string);
   {Returns Date of file}
   var
      DTInt:          longint;
      DT:             DateTime;
      Fil:            file;
      GotFile:        boolean;

   begin {MakeFileDateAndTime}
      assign(Fil,FilName);
      {$I-}
      reset(Fil);
      {$I+}
      GetFTime(Fil,DTint);
      close(Fil);
      UnpackTime(DTint,DT);
      FileDate := LongDate(DT.Day,DT.Month,DT.Year);
      FileTime := LongTime(DT.Hour,DT.Min,DT.Sec);
   end; {FileDateAndTime}

   function PresentDate: string;                                     {.CP7}
   var
      Mon,Day,Year,DayOWeek:word;
   begin
      GetDate(Year,Mon,Day,DayOWeek);
      PresentDate := ShortDate(Day,Mon,Year);
   end; {PresentDate}

   function PresentTime: string;                                     {.CP8}
   var
      Hr,Min,Sec,Sec100: word;
   begin
      GetTime(Hr,Min,Sec,Sec100);
      if Sec100>49 then inc(Sec);
      PresentTime := MilTime(Hr,Min,Sec);
   end; {PresentTime}

   procedure GetFileAndDate;                                          {.CP17}
   var
      Local:  string;
   begin
      GotFile := FindFile(FileName);     {returns FALSE or openable filename}
      if GotFile then begin
         MakeFileDateandTime(FileName);
         Local := FileName;
         PathSign := '';
         while (pos(':',Local)<>0) or (pos('\',Local)<>0) do begin
            PathSign := PathSign + Local[1];
            delete(Local,1,1)
        end {while}
     end {if GotFile}
     else
        if InABatch then GetOutOfHere;
   end; {GetFileAndDate}

   procedure PostFile;                                                 {.CP7}
   begin
      CenterCRT(FileName + ', Created ' + FileTime + ', ' + FileDate,
         7,Bright,Inside);
      if not InABatch then
         CenterCRT('Output will go to '+OutputDevice,BoxT+3,bright,inside);
   end; {PostFile}

   function OptionsOK: boolean;                                        {.CP6}
   const
      Yes: set of char = [#13,'Y','y'];
   var
      Yep: char;
      Row: byte;

      procedure CheckBill;                                             {.CP9}
      var
         Col:       byte;
         S:         string;
         ShortName: string;
      begin
         ShortName := Shortened(FileName);
         Blank(9,17);
         Row := 10;
         if Vanilla then begin                                        {.CP15}
            S := 'You want to print ' + ShortName + ' as plain text,';
            Col := 40 - length(S) div 2;
            WriteCRT(S,Row,Col,Bright);
            inc(Row);
               WriteCRT('with no inclusions or cross-ref, & nothing',Row,Col,bright);
            inc(Row);
            if FFeed  then begin
               WriteCRT('numbered or counted, but',Row,Col,bright);
               inc(Row)
            end {if FFeed}
            else
               WriteCRT('marked, numbered or counted.',Row,Col,bright);
            Col := 27;
         end {if Vanilla}
         else if XRefOnly then begin                                   {.CP8}
            CenterCRT('You want to cross-reference '+ ShortName,Row,Bright,0);
            inc(Row);
            if FFeed then
               CenterCRT('without printing the source code and',Row,Bright,0)
            else
               CenterCRT('without printing the source code',Row,Bright,0);
         end {else if XRefOnly}
         else begin                                                    {.CP9}
            Col := 27;
            WriteCRT('You want to list '+ShortName+' and',Row,24,Bright);
            inc(Row);
            if Mrk then
               WriteCRT('M  Mark the key words',Row,Col,Bright)
            else
               WriteCRT('P  Leave the key words plain',Row,Col,Bright);
            inc(Row);
            if NumberLines then begin                                 {.CP21}
               WriteCRT('L  Number the lines',Row,Col,Bright);
               if Mrk then begin
                  inc(Row);
                  WriteCRT('   & count B/E pairs',Row,Col,Bright);
               end{if Mrk}
            end {if NumberLines}
            else
               WriteCRT('   NOT numbering the lines',Row,Col,Bright);
            if XRef then begin
               inc(Row);
               WriteCRT('X  Cross-Reference the Identifiers  ',
                          Row,Col,Bright);
            end; {if XRef}
         end; {else --not XRefOnly & not Vanilla}
         if FFeed then begin
            inc(Row);
            WriteCRT('F  Feed out a blank page first      ',
                      Row,Col,Bright);
         end; {if FFeed}
      end; {CheckBill}

   begin {OptionsOK}                                                  {.CP19}
      if InABatch then
         OptionsOK := True
      else begin
         CheckBill;
         inc(Row);
         if Row<17 then inc(Row);
         WriteCRT('Is that correct? ',Row,24,Bright);
         GotoXY(41,Row);
         CursorOn;
         Yep := KBin(Ext);
         CursorOff;
         if Yep in Triggers
            then GetOutOfHere
            else write(Yep);
         Blank(16,Row);
         OptionsOK := Yep in Yes
      end {else not InABatch}
   end; {OptionsOK}

   procedure Options;                                                 {.CP22}
   var
      Ans: CMD;
      R:   byte;

      procedure OptionsBillboard;
      begin
         R := 10;
         WriteCRT('Options: L for Line Numbering              '
                  ,R,23,Bright);
         inc(R);
         WriteCRT('   M for Mark KeyWords               ',R,29,Bright);
         inc(R);
         WriteCRT('   X for X-Ref (Cross-reference)     ',R,29,Bright);
         if Inst.Bt[FF]=12 then begin
            inc(R);
            WriteCRT('   F for Feed out a blank page       ',R,29,Bright)
         end; {if Inst}
         inc(R);
         WriteCRT('   V for Vanilla (plain text)        ',R,29,Bright);
         inc(R);
      end; {OptionsBillboard}

   begin {Options}                                                    {.CP12}
      Blank(9,16);
      OptionsBillboard;
      inc(R);
      GotoXY(37,R); Ans := EditTrm(5);
      if Ans='' then
         Ans := 'P'
      else if Ans[1] in triggers then
         GetOutOfHere;
      delay(200);
      GetInstructions(Ans);
   end; {Options}

   function NameOK: boolean;                                          {.CP20}
   begin
      Blank(7,16);
      CenterCRT('Listing: ' + Filename + ', OK? ',11,Bright,0);
      GotoXY(39,13);
      CursorOn;
      Answer := KBin(Ext);
      CursorOff;
      if Answer in Triggers then
         GetOutOfHere
      else if Answer=#13 then
         Answer := 'Y';
      write(Answer);
      if Answer in [#13,'Y','y'] then begin
         NameOK := True;
         PostFile
      end {if Y}
      else
         NameOK := False;
   end; {NameOK}

   procedure NoSuchFile;                                               {.CP9}
   begin
      Beep;
      Blank(8,12);
      CenterCRT('Can''t find ' + Filename,7,Bright,0);
      Bop;
      if InABatch
         then GetOutOfHere
   end; {NoSuchFile}

   procedure GetID;                                                   {.CP16}
   var
      IDFile:      text;
      FilNam:      string;
   begin
      FilNam := 'PXL.ID';
      if FindFile(FilNam) then begin
         assign(IDFile,FilNam);
         reset(IDFile);
         read(IDFile,UserID);
         close(IDFile);
      end {if no error}
      else
         UserID := ''
   end; {GetID}

   procedure FirmUpName;                                              {.CP12}
   begin
      repeat
         repeat
            EnterName;
            GetFileAndDate;              {Get creation date & set GotFile}
            if not GotFile then NoSuchFile;            {Execute EnterName}
         until GotFile;
         NameFirm := NameOK=True;
      until NameFirm;
      PostFile
   end; {FirmUpName}

   procedure FirmUpInstructions;                                       {.CP10}
   var
      Firm: boolean;
   begin
      Firm := False;
      while not Firm do begin
         Options;
         if OptionsOK then Firm := True
      end {while}
   end; {FirmUpInstructions}

   procedure InitMenu;                                                {.CP14}
   begin
      Mrk := False;
      NumberLines := False;
      Enough := False;
      XRef := False;
      XRefOnly := False;
      InABatch := False;
      NameInComLine := False;
      NameFirm := False;
      GotFile := False;
      GotPrnData := False
   end; {InitMenu}

begin  {Menu}
   InitMenu;                                                          {.CP15}
   GetPrinterData;                           {Get printer specs from PXL.PRN}
   ReadComLine;                      {Seek FileName, InABatch & Instructions}
   if (FileName='') then
      FirmUpName
   else begin                      {Name in ComLine, maybe Instructions, too}
      NameInComLine := True;
      GetFileAndDate;                     {Exits on InABatch and Not GotFile}
      if GotFile then
         PostFile
      else begin
         NoSuchFile;
         FirmUpName;
      end; {else not GotFile}
   end; {else FileName}
   if Instructed then                   {instructed by ComLine}       {.CP19}
      if not OptionsOK then begin
         Instructed := False;
         if not NameFirm then
              if not NameOK then FirmUpName;
         FirmUpInstructions
      end; {if not OptionsOK}
   if not Instructed then begin
      Options;
      if not OptionsOK then begin
         if NameInComLine and not NameFirm then
            if not NameOK then FirmUpName;
         FirmUpInstructions;
      end; {if not OptionsOK}
      Instructed := True
   end; {if not Instructed}
   GetID;
   PrintTime := PresentTime;
   PrintDate := PresentDate
end;  {Menu}

procedure SetStyle;                                                   {.CP20}
var
   I:              integer;
   T:              TpFace;
begin
   if Inst.Bt[FF]<>12 then  {can't FF w/o #12 -dunno where on 1st page we are}
      FFeed := False;
   if Mrk then begin
      Opening := Istring[MrkB];                           {Start underlining}
      Closing := Istring[MrkE]                             {Stop underlining}
   end {if Mrk}
   else begin
      Opening := '';
      Closing := ''
   end; {else --not Mrk}
   QuitStrg := Istring[PostP];
end; {SetStyle}

(*
PROCEDURE TESTRESERV;                                            {.CP17}
VAR C: CHAR;                {A debugging tool.  Not needed in actual run}
    T: TEXT;
    P: ResWPtrType;
BEGIN
   ASSIGN(T,'C:RESWDS');
   REWRITE(T);
   FOR C := 'A' TO 'Z' do begin
      P := Rsv[C];
      while P<>nil do begin
         writeln(T,P^.R);
         P := P^.Next;
      end; {while not nil}
   end; {for C}
   close(T);
END; {TESTRESERV}   *)

procedure LoadReserv;                                                 {.CP10}
   {If constant DataFiles is set = True, this procedure will load the list  }
   {of reserved words from file PXL.WDS (if it's on the path) and switches  }
   {NRes (number of reserved words) and Turbo3 (which version of TP) will be}
   {set automatically, below.  If you're adapting this to some other Pascal }
   {than Turbo 3, 4, or 5, put your list of reserved words in file, PXL.WDS,}
   {make sure Type ResWType is as long as your longest reserved word & Type }
   {ResArr has room enough, and set DataFiles=True.  If you want to use the }
   {internal data below, set DataFiles=False & set Turbo3 (in PXL.PAS, pro- }
   {cedure Setup) true or false to fit the version you need.                }
var
   K: byte;
   C: char;
   Reserv: array[1..MaxResWords] of ResWType;

procedure ReadWds; {from PXL.WDS}                                     {.CP25}
   var
      Fil:            text;
      FilNam:         string;
      Res:            ResWType;
      K,J:            integer;
   begin
      FilNam := 'PXL.WDS';
      if FindFile(FilNam) then begin
         assign(Fil,FilNam);
         reset(Fil);
         K := 0;
         while not Eof(Fil) do begin
            inc(K);
            readln(Fil,Res);
            for J := 1 to length(Res) do
               Res[J] := UpCase(Res[J]);
            Reserv[K] := Res
         end; {while}
         NRes := K;
         close(Fil);
         Turbo3 := NRes<45; {Note this overrides default setting in PXL.PAS }
      end {if no error}     {User can adjust version by controlling the PATH}
      else CantCont('PXL.WDS','Can''t find it on path.')
   end; {ReadWds}

   procedure IntWds4; {This version for TP 4 & higher}
   {This word list fits TP7, including the "Borland Pascal Directives" as  }
   {well as the "Borland Pascal Reserved Words" --BPWO Language Guide, p 16}
   begin
      {if DataFiles = False, reserved words will be set thus:}
      NRes := 65;
      Reserv[1]  := 'ABSOLUTE';        Reserv[2]  := 'AND';
      Reserv[3]  := 'ARRAY';           Reserv[4]  := 'ASM';
      Reserv[5]  := 'ASSEMBLER';       Reserv[6]  := 'BEGIN';
      Reserv[7]  := 'CASE';            Reserv[8]  := 'CONST';
      Reserv[9]  := 'CONSTRUCTOR';     Reserv[10] := 'DESTRUCTOR';
      Reserv[11] := 'DIV';             Reserv[12] := 'DO';
      Reserv[13] := 'DOWNTO';          Reserv[14] := 'ELSE';
      Reserv[15] := 'END';             Reserv[16] := 'EXPORT';
      Reserv[17] := 'EXPORTS';         Reserv[18] := 'EXTERNAL';
      Reserv[19] := 'FAR';             Reserv[20] := 'FILE';
      Reserv[21] := 'FOR';             Reserv[22] := 'FORWARD';
      Reserv[23] := 'FUNCTION';        Reserv[24] := 'GOTO';
      Reserv[25] := 'IF';              Reserv[26] := 'IMPLEMENTATION';
      Reserv[27] := 'IN';              Reserv[28] := 'INDEX';
      Reserv[29] := 'INHERITED';       Reserv[30] := 'INLINE';
      Reserv[31] := 'INTERFACE';       Reserv[32] := 'INTERRUPT';
      Reserv[33] := 'LABEL';           Reserv[34] := 'LIBRARY';
      Reserv[35] := 'MOD';             Reserv[36] := 'NAME';
      Reserv[37] := 'NEAR';            Reserv[38] := 'NIL';
      Reserv[39] := 'NOT';             Reserv[40] := 'OBJECT';
      Reserv[41] := 'OF';              Reserv[42] := 'OR';
      Reserv[43] := 'PACKED';          Reserv[44] := 'PRIVATE';
      Reserv[45] := 'PROCEDURE';       Reserv[46] := 'PROGRAM';
      Reserv[47] := 'PUBLIC';          Reserv[48] := 'RECORD';
      Reserv[49] := 'REPEAT';          Reserv[50] := 'RESIDENT';
      Reserv[51] := 'SET';             Reserv[52] := 'SHL';
      Reserv[53] := 'SHR';             Reserv[54] := 'STRING';
      Reserv[55] := 'THEN';            Reserv[56] := 'TO';
      Reserv[57] := 'TYPE';            Reserv[58] := 'UNIT';
      Reserv[59] := 'UNTIL';           Reserv[60] := 'USES';
      Reserv[61] := 'VAR';             Reserv[62] := 'VIRTUAL';
      Reserv[63] := 'WHILE';           Reserv[64] := 'WITH';
      Reserv[65] := 'XOR';
   end; {IntWds4}

   procedure IntWds3; {This version for Turbo 3}                      {.CP27}
   begin
      {if DataFiles = False, reserved words will be set thus:}
      NRes := 44;
      Reserv[1]  := 'ABSOLUTE';        Reserv[2]  := 'AND';
      Reserv[3]  := 'ARRAY';           Reserv[4]  := 'BEGIN';
      Reserv[5]  := 'CASE';            Reserv[6]  := 'CONST';
      Reserv[7]  := 'DIV';             Reserv[8]  := 'DO';
      Reserv[9]  := 'DOWNTO';          Reserv[10] := 'ELSE';
      Reserv[11] := 'END';             Reserv[12] := 'EXTERNAL';
      Reserv[13] := 'FILE';            Reserv[14] := 'FOR';
      Reserv[15] := 'FORWARD';         Reserv[16] := 'FUNCTION';
      Reserv[17] := 'GOTO';            Reserv[18] := 'IF';
      Reserv[19] := 'IN';              Reserv[20] := 'INLINE';
      Reserv[21] := 'LABEL';           Reserv[22] := 'MOD';
      Reserv[23] := 'NIL';             Reserv[24] := 'NOT';
      Reserv[25] := 'OF';              Reserv[26] := 'OR';
      Reserv[27] := 'OVERLAY';         Reserv[28] := 'PACKED';
      Reserv[29] := 'PROCEDURE';       Reserv[30] := 'PROGRAM';
      Reserv[31] := 'RECORD';          Reserv[32] := 'REPEAT';
      Reserv[33] := 'SET';             Reserv[34] := 'SHL';
      Reserv[35] := 'SHR';             Reserv[36] := 'STRING';
      Reserv[37] := 'THEN';            Reserv[38] := 'TO';
      Reserv[39] := 'TYPE';            Reserv[40] := 'UNTIL';
      Reserv[41] := 'VAR';             Reserv[42] := 'WHILE';
      Reserv[43] := 'WITH';            Reserv[44] := 'XOR';
   end; {IntWds3}

   procedure InsertResWord(Wd: ResWType);                             {.CP18}
   var
      P: ResWPtrType;
   begin
     if Rsv[Wd[1]]=nil then begin    {no reswords in this list yet}
        new(Rsv[Wd[1]]);
        Rsv[Wd[1]]^.Next := nil;
        Rsv[Wd[1]]^.R := Wd;
     end {if nil}
     else begin
        P := Rsv[Wd[1]];
        while P^.Next<>nil do P := P^.Next;
        new(P^.Next);
        P := P^.Next;
        P^.Next := nil;
        P^.R := Wd;
     end;                            {else list not empty}
   end; {InsertResWord}

begin {LoadReserv}                                                    {.CP15}
   if DataFiles then
      ReadWds
   else if Turbo3 then
      IntWds3
   else
      IntWds4;
   for C := 'A' to 'Z' do Rsv[C] := nil;
   MaxResLen := 0;
   for K := 1 to NRes do begin
      InsertResWord(Reserv[K]);
      if length(Reserv[K])>MaxResLen then MaxResLen := length(Reserv[K]);
  end; {for each res wd}
(* TESTRESERV;  {debuggery} *)
end; {LoadReserv}

procedure Initialize;                                                {.CP23}
var C: char;
begin
   CheckBreak := True;
   FileName := '';
   if Monitor=MDA then begin
      ScrSeg := $B000;
      Normalcolor := 15;
      FrameColor := 7;
      BackGround := 0;
   end {if MDA}
   else begin
      ScrSeg := $B800;
      NormalColor := ForegroundOf(NormalColor);      {in case of user dumbth}
      FrameColor  := ForegroundOf(FrameColor);
      Background  := Background and 7;
   end; {else color board}
   Bright := CombinedAttributeOf(NormalColor,Background);
   Dim := CombinedAttributeOf(FrameColor,Background);
   TextColor(NormalColor); TextBackground(Background);
   BlnkLn[0] := char(Inside);
   PXLRectangle;
end; {Initialize}

End.