Power-Programmierung/CD1.mdf/pascal/utility/crossref/pxl/pxlmenu.pas

Pascal/Delphi Source File | 1988-05-04 | 19KB | 551 lines

{$R-}    {Range checking off}                                         {.CP13}
{$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(var Reserv: ResArr);    {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);                               {.CP16}
   var
      B:   byte;
   begin
      Instructed := False;
      Ans := InCapitals(Ans);
      if pos('X',Ans)<>0 then XRef := True else XRef := False;
      if pos('W',Ans)<>0 then Wide := True else Wide := False;
      if (pos('F',Ans)<>0) and (Inst[FF,1]=12) then
         FFeed := True else FFeed := 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                                              {.CP14}
         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 or Wide then
         Instructed := True;
      if InABatch and (not Instructed) then begin
         Plain := True;
         Instructed := True
      end {if InABatch &c}
   end; {GetInstructions}

   procedure ReadComLine;                                             {.CP20}
   var
      B:      byte;
   begin  {ReadComLine}
      Command := '';
      Instructed := False;
      if ParamCount=0 then
         FileName := ''
      else begin
         FileName := InCapitals(ParamStr(1));
         FixupFileName(FileName);
         if ParamCount>1 then begin
            for B := 2 to ParamCount do
               Command := Command + InCapitals(ParamStr(B));
            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 {FileDate}
      LongDate := Months[Month] + ' ' + StrgI(Day,1) + ', '
                + StrgI(Year,1);
   end; {LongDate}

   function ShortDate(Day,Month,Year: word): Str9;                     {.CP5}
   begin {FileDate}
      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: LineType);
   {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: LineType;                                     {.CP7}
   var
      Mon,Day,Year,DayOWeek:word;
   begin
      GetDate(Year,Mon,Day,DayOWeek);
      PresentDate := ShortDate(Day,Mon,Year);
   end; {PresentDate}

   function PresentTime: LineType;                                     {.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:  LineType;
   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;                                                 {.CP4}
   begin
      CenterCRT(FileName + ', Created ' + FileTime + ', ' + FileDate, 7,Bright,Inside);
   end; {PostFile}

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

      procedure CheckBill;
      const
         Col = 29;
      var
         ShortName: LineType;
      begin
         ShortName := Shortened(FileName);
         Blank(8,16);
         if XRefOnly then begin
            CenterCRT('You want to cross-reference '+ShortName,11,Bright,0);
            if Wide or FFeed then
               CenterCRT('without printing the source code and',12,Bright,0)
            else
               CenterCRT('without printing the source code',12,Bright,0);
            Row := 13;
         end {if XRefOnly}
         else begin                                                    {.CP9}
            Row := 10;
            WriteCRT('You want to print '+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                                 {.CP15}
               WriteCRT('L  Number the lines',Row,Col,Bright);
               inc(Row);
               if Mrk
                  then WriteCRT('   & count B/E pairs',Row,Col,Bright)
                  else dec(Row);
            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}
         if Wide then begin                                           {.CP11}
            inc(Row);
            WriteCRT('W  Print the text very small        ',
                      Row,Col,Bright);
         end; {if Wide}
         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;                                                 {.CP16}
   var
      Ans: CMD;

      procedure OptionsBillboard;
      begin
         GotoXY(23,10);
         WriteCRT('Options: L for Line Numbering              '
                  ,10,23,Bright);
         WriteCRT('   M for Mark KeyWords               ',11,29,Bright);
         WriteCRT('   X for X-Ref (Cross-reference)     ', 12,29,Bright);
         WriteCRT('   W for Wide text (>79 columns)     ', 13,29,Bright);
         if Inst[FF,1]=12 then begin
            WriteCRT('   F for Feed out a blank page       ', 14,29,Bright)
         end; {if Inst}
      end; {OptionsBillboard}

   begin {Options}                                                    {.CP11}
      Blank(8,16);
      OptionsBillboard;
      GotoXY(37,15); 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:      LineType;
   begin
      FilNam := 'PXL.ID';
      if FindFile(FilNam) then begin
         assign(IDFile,FilNam);
         reset(IDFile);
         read(IDFile,UserID);
         close(IDFile);
         (* if Length(UserID)<24 then UserID := '[' + UserID + ']'*)
      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}

begin  {Menu}                                                         {.CP18}
   Mrk := False; NumberLines := False; Wide := False; Enough := False;
   XRef := False; XRefOnly := False; NRes := 48; InABatch := False;
   NameInComLine := False; NameFirm := False; GotFile := False;
   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
   for T := MrkB to CondE do begin               {if nothing in Inst[T] then}
      Istring[T] := '';                                  {Istring[T] is null}
      for I := 1 to Inst[T,0] do Istring[T] := Istring[T] + Chr(Inst[T,I])
   end; {for T}
   if Inst[FF,1]<>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}
end; {SetStyle}

procedure LoadReserv(var Reserv: ResArr);                              {.CP9}
   {If constant DataFiles is set = True, this procedure will load the list  }
   {of reserved words from file PXL.WDS, which must be on the default       }
   {drive, and NRes (number of reserved words) will be set automatically    }
   {below.  If you're adapting this to a Pascal other than Turbo 2 or 3, put}
   {your list of reserved words in file, PXL.WDS, make sure Type Str10 is   }
   {as long as your longest reserved word and Type ResArr has room enough,  }
   {and set DataFiles = True.  If you want to load internally, set Data-    }
   {Files = False, and (in Menu Procedure) make NRes = number of words.     }

procedure ReadWds; {from PXL.WDS}                                     {.CP24}
   var
      Fil:            text;
      FilNam:         LineType;
      Res:            Str10;
      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
            K := succ(K);
            readln(Fil,Res);
            for J := 1 to ord(Res[0]) do
               Res[J] := UpCase(Res[J]);
            Reserv[K] := Res
         end; {while}
         NRes := K;
         close(Fil)
      end {if no error}
      else CantCont('PXL.WDS','Can''t find it on path.')
   end; {ReadWds}

   procedure IntWds; {Set here for Turbo 2 or 3}                      {.CP28}
   begin
      {if DataFiles = False (& NRes = 48), reserved words will be set thus:}
      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] := 'IMPLEMENTATION'; Reserv[20] := 'IN';
      Reserv[21] := 'INLINE';         Reserv[22] := 'INTERFACE';
      Reserv[23] := 'INTERRUPT';      Reserv[24] := 'LABEL';
      Reserv[25] := 'MOD';            Reserv[26] := 'NIL';
      Reserv[27] := 'NOT';            Reserv[28] := 'OF';
      Reserv[29] := 'OR';             Reserv[30] := 'PACKED';
      Reserv[31] := 'PROCEDURE';      Reserv[32] := 'PROGRAM';
      Reserv[33] := 'RECORD';         Reserv[34] := 'REPEAT';
      Reserv[35] := 'SET';            Reserv[36] := 'SHL';
      Reserv[37] := 'SHR';            Reserv[38] := 'STRING';
      Reserv[39] := 'THEN';           Reserv[40] := 'TO';
      Reserv[41] := 'TYPE';           Reserv[42] := 'UNIT';
      Reserv[43] := 'UNTIL';          Reserv[44] := 'USES';
      Reserv[45] := 'VAR';            Reserv[46] := 'WHILE';
      Reserv[47] := 'WITH';           Reserv[48] := 'XOR';
   end; {IntWds}

begin {LoadReserv}                                                     {.CP6}
   if DataFiles then
      ReadWds
   else
      IntWds
end; {LoadReserv}

procedure Initialize;                                                {.CP24}
var C: char;
begin
(*   CursorOff; *)
   CheckBreak := True;
(*   if Escape then begin end; {dummy to clear keyboard buffer} *)
   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.