[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]

    {
    > I am writing a small replacement for the DOS command TYPE and one
    > of the things I would like to add is a scroll back buffer...
    > Q: How do I intercept the lines that are scrolling off page?
    > Is there a interupt that I may hook in to or ...

    Doesn't have a filesize check. Parts of it could be improved.

    From: R.A.M.vGeel@kub.nl  (GEEL R.A.M.VAN)
    }

    program show;

    uses dos, crt;

    const
      NoMSG = 0;
      msgNoPar = 1;
      msgNoFile = 2;
      msgNoDrive = 152;
      msgNoClose = 10;
      msgWrongKey = 100;

    type
      FileNameString = string[80];

      PNewLine = ^NewLine;
      NewLine = Record
                  Line : string[79];
                  Next, Prev : PNewLine;
                end;

      TFiler = object
                 FileName : string[80];
                 InFile : text;
                 MSGStatus : byte;

                 constructor Init;
                 procedure DoMsg(MsgNr : byte); virtual;
                 function GetFileName : FileNameString; virtual;
                 function OpenIt : byte; virtual;
                 function CloseIt : byte; virtual;
                 destructor Done; virtual;
               end;

      TShower = object(TFiler)
                  Screen : array[1..2000] of word;
                  Xcor, Ycor : byte;
                  CurSize : word;
                  Text : PNewLine;
                  ScrolFac : integer;
                  Tmp : PNewLine;

                  constructor Init;
                  procedure DoMsg(MsgNr : byte); virtual;
                  procedure Cursor; virtual;
                  procedure NoCursor; virtual;
                  procedure SaveScreen; virtual;
                  procedure RestoreScreen; virtual;
                  procedure ReadIn; virtual;
                  procedure ShowText; virtual;
                  function UpdatePointer: boolean; virtual;
                  procedure Go; virtual;
                  destructor Done; virtual;
                end;

    var
      AShower : TShower;

    constructor TFiler.Init;
    begin
      FileName := GetFileName;
        if MSGStatus <> NoMsg then DoMsg(MSGStatus);
      MSGSTatus := OpenIt;
        if MSGStatus <> NoMSG then DoMSG(MSGStatus);
    end;

    procedure TFiler.DoMsg(MSGNr : byte);
    begin
      case MSGNr of
        msgNoPar :
          begin
            writeln('* * SHOW (c) 1994 Robert van Geel * *');
            writeln;
            writeln('Usage: SHOW <filename>');
            halt(1);
          end;
        msgNoFile :
          begin
            writeln('File not found');
            halt(1);
          end;
        msgNoClose :
           begin
             writeln('Could not close file');
             MSGStatus := NoMsg;
           end;
        msgNoDrive :
           begin
             writeln('Drive not ready');
             halt(1);
           end;
      end;
    end;

    function TFiler.GetFileName : FileNameString;
    begin
      If ParamCount > 0 then
        GetFileName := ParamStr(1)
      else MsgStatus := MSGNoPar;
    end;

    function TFiler.OpenIt : byte;
    var
      nr : byte;
    begin
      {$I-}
        assign(InFile, FileName);
        reset(InFile);
        nr := IOResult;
        OpenIt := nr;
      {$I+}
    end;

    function TFiler.CloseIt : byte;
    begin
    {$I-}
      close(InFile);
      CloseIt := IOResult;
    {$I+}
    end;

    destructor TFiler.Done;
    begin
      MsgStatus := CloseIt;
      if MSGStatus <> NoMSG
        then DoMsg(MSGStatus);
    end;

    { ********************************************************************** }

    constructor TShower.Init;
    begin
      inherited init;
      SaveScreen;
      ReadIn;
      NoCursor;
      SaveScreen;
    {  textcolor(yellow);
      textbackground(blue);
    }  clrscr;
    end;

    procedure TShower.DoMsg(MSGNr : byte);
    begin
      inherited DoMsg(MsgNr);
      case MSGNr of
          msgWrongKey :
            begin
              gotoxy(1, 24);
              writeln('KEY HAS NO FUNCTION HERE');
              MsgNr := NoMsg;
            end;
        end;
    end;

    procedure TShower.NoCursor;
    var s : word;
    begin
     asm
        mov ah,03h
        mov bh,0
        int 10h
        mov s,cx

        mov ah,01h
        mov bh,0
        mov cx,2000h
        int 10h
      end;
      cursize := s;
    end;

    procedure TShower.Cursor;
    var s:word;
    begin
    s:=CurSize;
      asm
        mov ah,01h
        mov bh,0
        mov cx,s
        int 10h
      end;
    end;

    procedure TShower.SaveScreen;
    begin
      move(memw[$B800:$0], Screen, 4000);
      XCor := wherex;
      YCor := wherey;
    end;

    procedure TShower.RestoreScreen;
    begin
      move(Screen, memw[$B800:$0], 4000);
      gotoxy(XCor, YCor);
    end;

    function TShower.UpdatePointer: boolean;
    var
      k : integer;
      changed : boolean;
    begin
      changed := false;
      while (ScrolFac > 0) and (Text^.Next <> nil) do
        begin
          changed := true;
          Text := Text^.Next;
          dec(ScrolFac);
        end;
      while (ScrolFac < 0) and (Text^.Prev <> nil) do
        begin
          changed := true;
          Text := Text^.Prev;
          inc(ScrolFac);
        end;
      Tmp := Text;
      UpdatePointer := changed;
    end;

    procedure TShower.ShowText;
    var
      LinesWritten : integer;
      OneMore : boolean;
    begin
      LinesWritten := 0;
      OneMore := true;
      gotoxy(1,1);
      while OneMore and (LinesWritten < 25) do
        begin
          write(tmp^.Line);
          clreol;
          inc(LinesWritten);
          if LinesWritten < 25 then
            begin
              writeln;
              clreol;
            end;
          if tmp^.next <> nil then tmp := tmp^.Next
            else OneMore := false;
        end;
      while LinesWritten < 24 do
        begin
          writeln;
          clreol;
          inc(LinesWritten);
        end;
    end;

    procedure TShower.Go;
    var
      Ch : char;
    begin
      tmp := Text;
      ShowText;
      while Ch <> #01 do
      begin
        Ch := ReadKey;
        case ch of
          #0  : ;
          #72 : ScrolFac := -1;   {omhoog}
          #80 : ScrolFac := 1;    {omlaag}
          #73 : ScrolFac := -25;  {page up}
          #81 : ScrolFac := 25;   {page down}
          else Ch := #01;
        end;
        if ScrolFac <> 0 then
          begin
            if UpdatePointer then ShowText;
          end;
      end;
    end;

    procedure TShower.ReadIn;
    var
      cur : PNewLine;
    begin
      new(Text);
      with Text^ do
        begin
          readln(InFile, Line);
          Next := nil;
          Prev := nil;
        end;
      cur := Text;
      while not EOF(InFile) do
        begin
          new(tmp);
          with tmp^ do
            begin
              readln(InFile, tmp^.line);
              tmp^.prev := cur;
              cur^.next := tmp;
              tmp^.next := nil;
            end;
          cur := tmp;
          tmp := nil;
        end;
      cur := nil;
      tmp := nil;
    end;

    destructor TShower.Done;
    begin
      inherited Done;
      while text^.next <> nil do
        begin
          text := text^.next;
          dispose(text^.prev);
          text^.prev := nil;
        end;
      dispose(text);
      text := nil;
      Cursor;
      RestoreScreen;
    end;

    begin
      AShower.Init;
      AShower.Go;
      AShower.Done;
    end.

[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]