
(*
  Improved DOS MORE, derived from R A M van Geel's SHOW.PAS of Nov 1994,
  but now very heavily fiddled with by JRS.
  If ParamCount = 0 then it shows Standard Input { try C:\> DIR | SHOWER }
  else if parameter = /? then it shows short Help else it shows that file.
  NOT restricted to 80 cols * 25 rows, colour, page 0, screen.

  If the whole file cannot be loaded, the border goes red.

  Layout is by JRS's program CLEAN-TP.PAS.
  Compile with TP7/BP7 to REAL or PROTECTED mode; test on empty, normal,
  vast input.  In PROTECTED, it will need RTM.EXE & DPMI16BI.OVL, or subs.

  In the display, the following effects occur for specific characters :
  #0  ^@ NUL ' ' shows as Space.
  #7  ^G BEL '' is ignored.
  #8  ^H BS  '' removes the previous character of the line.
  #9  ^I TAB '	' is expanded.
  #10 ^J LF  (when without #13 ^M CR) does LF, but could be better handled?
  #255 $FF   'ÿ' shows as Space.
  The effect of #27 ^[ ESC with ANSI.SYS is not considered.

  Output is of original input, apart for truncation to 255 chars/line.
  Outputs "Y" "Z" differ in what they leave on the screen, unredirected.

  J R Stockton, www.merlyn.demon.co.uk : Home, Surrey, UK.
  94/12/13++ - 
  RvG may use this with acknowledgement only in the source-code. *)


(* Derived from an original POSTed, as SHOW.PAS, headed :
  From: R.A.M.vGeel@kub.nl  (GEEL R.A.M.VAN)
  Subject: Re: scrolling
  Date: Wed, 02 Nov 1994  13:04 MET
  Wrote this as an alternative for the (horrible) type|more command.
  Hope it helps         Rob van Geel *)


{-000----------------------------------------TEST--------------------------------------}
{-001-was-very-long-line---that-breaks-CLEAN-TP--------------------------------}
{         1         2         3         4         5         6         7         8         9}
{123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890}

{$M 2048, 1024, 655360} {$X+}
program SHOWER {$IFDEF WINDOWS} Fail {$ENDIF} ;

uses {$IFDEF MSDOS} {for SetMemTop} Memory, {$ENDIF} Dos,
  Crt { will need new Crt or patch for PC>=200MHz; Crt is essential here };

const
MsgNone = 0 ;
MsgNoClose = 10 ;
MsgNoFile = 2 ;
MsgNoDrive = 152 ;
MsgHelp = 250 ;

(* procedure Border(const Hue : word) ;
  begin asm mov AH,0Bh ; mov BX,Hue ; int 10h end end {Border} ; *)

procedure SetBorder(Colour : byte) ; assembler ;
asm mov AH,0Bh ; mov BH,00h ; MOV BL,[Colour] ; int 10h end {SetBorder} ;

function GetBorder : byte ; assembler ;
asm mov AX,1008h ; int 10h ; mov AL,BH end {GetBorder} ;

type

PNewLine = ^NewLine ;
NewLine = record Next, Prev : PNewLine ; No : longint ; PLine : ^string end ;

TFiler = object
  FileName : PathStr ;
  Buf : array [0..4095] of char ;
  constructor Init ;
  procedure DoMsg(const MsgNumber : byte) ; virtual ;
  function OpenAFiler : byte ; virtual ;
  function CloseFiler : byte ; virtual ;
  destructor Done ; virtual ;
  end {TFiler} ;

TShower = object(TFiler)
  SaveMode : word ;
  PSave, PShow : pointer ;
  CurSize, ScreenSize : word ;
  FstCol, MaxL, Xcur, Ycur : byte ;
  First, ToP : PNewLine ;
  Amount, Last : longint ;
  Sk : string ;
  Cmd : char ;
  Bord : byte ;
  constructor Init ;
  procedure CursorOn ; virtual ;
  procedure NoCursor ; virtual ;
  procedure SaveScreen ; virtual ;
  procedure RestoreScr ; virtual ;
  procedure DoMsg(const MsgNumber : byte) ; virtual ;
  procedure GetInput ; virtual ;
  procedure ShowText ; virtual ;
  procedure WaitShow ; virtual ;
  procedure UpDateText ; virtual ;
  function UpdatePointer(Change : longint) : boolean ; virtual ;
  function StepPointer : boolean ; virtual ;
  function Sought(P : PNewLine) : boolean ; virtual ;
  procedure Run ; virtual ;
  procedure StandOut ; virtual ;
  destructor Done ; virtual ;
  end {TShower} ;


constructor TFiler.Init ;
begin FileName := ParamStr(1) ;
  if ParamStr(1)='/?' then begin DoMsg(MsgHelp) ; HALT(1) end ;
  DoMsg(OpenAFiler) end {TFiler.Init} ;

procedure TFiler.DoMsg(const MsgNumber : byte);
begin
  case MsgNumber of
    MsgNoFile : begin Writeln(FileName, ' not found') ; HALT(1) end ;
    MsgNoClose : Writeln('Could not close file') ;
    MsgNoDrive : begin Writeln('Drive not ready') ; HALT(1) end ;
    end {case} ;
  end {TFiler.DoMsg} ;

function TFiler.OpenAFiler : byte ;
begin Assign(Input, FileName) ; SetTextBuf(Input, Buf) ;
  {$I-} Reset(Input) {$I+} ; OpenAFiler := IOResult end {TFiler.OpenAFiler} ;

function TFiler.CloseFiler : byte ;
begin {$I-} Close(Input) {$I+} ;
  CloseFiler := IOResult end {TFiler.CloseFiler} ;

destructor TFiler.Done ;
begin DoMsg(CloseFiler) end {TFiler.Done} ;


var ScrCols, ScrPage, ScrRows : byte ;


constructor TShower.Init ;
var Sg : word ;
begin inherited Init ;
  {$IFDEF OLD}
  Bord := GetBorder ;
  SaveMode := LastMode ;
  ScrCols := Succ(Lo(WindMax)) ; ScrRows := Succ(Hi(WindMax)) ;
  asm mov AH,0Fh ; int 10h ; mov ScrPage,BH end ;
  Inc(WindMax) { Prevents screen scroll after writing to bottom right corner:
    see The Pascal Magazine #4 p.28 col.2 by Bob Swart } ;
  ScreenSize := 2*ScrCols*ScrRows ;
  if LastMode=Mono then Sg := SegB000 else Sg := SegB800 ; (* ThisMode ? *)
  PShow := Ptr(Sg, ScrPage*ScreenSize) ;
  SaveScreen ; GetInput ; NoCursor ;
  FstCol := 1 ; Amount := +1 ; ShowText ;
  {$ELSE}
  Bord := GetBorder ;
  SaveMode := LastMode ;
  if {ThisMode} Mem[Seg0040:$49]=Mono then Sg := SegB000 else Sg := SegB800 ; (* ThisMode ? *)
  asm mov AH,0Fh ; int 10h ; mov ScrPage,BH end ;
  { ScrCols := Succ(Lo(WindMax)) ; ScrRows := Succ(Hi(WindMax)) ; }
  ScrCols := MemW[Seg0040:$4A] ; ScrRows := Succ(Mem[Seg0040:$84]) ;
  Inc(WindMax) { Prevents screen scroll after writing to bottom right corner:
    see The Pascal Magazine #4 p.28 col.2 by Bob Swart } ;
  ScreenSize := 2*ScrCols*ScrRows ;
  PShow := Ptr(Sg, ScrPage*ScreenSize) ;
  SaveScreen ; GetInput ; NoCursor ;
  FstCol := 1 ; Amount := +1 ; ShowText ;
  {$ENDIF}
  end {TShower.Init} ;

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 {TShower.NoCursor} ;

procedure TShower.CursorOn ;
var S : word ;
begin S := CurSize ;
  asm mov ah,01h ; mov bh,0 ; mov cx,S ; int 10h end ;
  end {TShower.CursorOn} ;

procedure TShower.SaveScreen;
begin GetMem(PSave, ScreenSize) ; Move(PShow^, PSave^, ScreenSize) ;
  Xcur := WhereX ; Ycur := WhereY end {TShower.SaveScreen} ;

procedure TShower.RestoreScr ;
begin
  Move(PSave^, PShow^, ScreenSize) ; FreeMem(PSave, ScreenSize) ;
  GoToXY(Xcur, Ycur) end {TShower.RestoreScr} ;

procedure TShower.DoMsg(const MsgNumber : byte);
begin if MsgNumber=MsgHelp then begin
    Writeln('* SHOWER (c) 1994..7 Robert van Geel / John Stockton *') ;
    Writeln(
      'Mode: ' + {$IFDEF MSDOS} 'MSDOS' {$ENDIF}
      {$IFDEF DPMI} 'DPMI' {$ENDIF} + '; ' +
      'Usage: [|] SHOWER [<filename>] [|]'^M^J^J,
      'Help : ?.'^M^J +
      'Shift: Up Dn, PgUp PgDn, ^PgUp ^PgDn; Left Right tab TAB Home End <cr>.'^M^J +
      'Speed: ^Left ^Right, Space.'^M^J +
      'Saved: ^Home.'^M^J +
      'Lines: H/L 25/50.'^M^J +
      'Seeks: S...<cr> N, F B.'^M^J +
      'Exits: ![...]<cr>, Escape/X, Y, Z.'^J)
      end else inherited DoMsg(MsgNumber) ;
  end {TShower.DoMsg} ;

function TShower.UpdatePointer(Change : longint) : boolean ;
begin UpdatePointer := false ;
  while (Change>0) and (ToP^.No<=Last-ScrRows) do
    begin UpdatePointer := true ; ToP := ToP^.Next ; Dec(Change) end ;
  while (Change<0) and (ToP^.No>1) do
    begin UpdatePointer := true ; ToP := ToP^.Prev ; Inc(Change) end ;
  end {TShower.UpdatePointer} ;

function TShower.StepPointer : boolean ;
const By : array [boolean] of shortint = (-1, +1) ;
begin StepPointer := UpDatePointer(By[Amount>0]) end {TShower.StepPointer} ;

function TShower.Sought(P : PNewLine) : boolean ;
begin Sought := Pos(Sk, P^.PLine^)<>0 end {TShower.Sought} ;

procedure TShower.UpDateText ;
var Written : byte ; Tmpy : PNewLine ; S : string ; B : byte ;
{$IFDEF OK} const S7 = '       ' ; {$ELSE} C : char ; {$ENDIF}
begin MaxL := 0 ; Written := 0 ; GoToXY(1, 1) ; Tmpy := ToP ;
  if Assigned(First) then while Written<ScrRows do begin
    if Sought(Tmpy) then HighVideo ;
    with Tmpy^ do begin
      {$IFDEF OK}
      S := PLine^ ;
      repeat {tabs?} B := Pos(#9, S) ; if B=0 then BREAK ;
        S[B] := #32 ; Insert(Copy(S7, 1, 7-(Pred(B) and $7)), S, B) ;
        until false ;
      {$ELSE}
      S := '' ;
      for B := 1 to Length(PLine^) do begin C := PLine^[B] ;
        case C of
          ^G : ;
          ^H : if S[0]>#0 then Dec(S[0]) ;
          ^I : repeat S := S + #32 until (Length(S) mod 8)=0 ;
          { ^J : ? }
          else S := S + C ;
          end {C} ;
        end {B} ;
      {$ENDIF}
      if Length(S)>MaxL then MaxL := Length(S) ;
      Write(Copy(S, FstCol, ScrCols)) ;
      end ;
    LowVideo ; if WhereX<=ScrCols then ClrEol ;
    Inc(Written) ; if Written<ScrRows then Writeln ;
    if Assigned(Tmpy^.Next) then Tmpy := Tmpy^.Next else BREAK ;
    end {<} ;
  end {TShower.UpDateText} ;

procedure TShower.ShowText ;
begin ClrScr ; UpDateText end {TShower.ShowText} ;

procedure TShower.WaitShow ;
begin repeat ReadKey until not KeyPressed ; ShowText end {TShower.WaitShow} ;

(* {$IFDEF MSDOS} {Long, p.16}
  function AbAd(P : pointer) : longint ;
  type RP = record Os, Sg : word end ;
  begin AbAd := longint(RP(P).Sg) shl 4 + RP(P).Os end ;
  {$ENDIF} *)

procedure TShower.Run ;
const Ch : array [boolean] of char = #24#25 ;
Auto : boolean = false ;
Slowness : word = 166 {ms} ;
ScrollBy : longint = 0 ;
Cd : string = '' ;
var K : char ;
begin repeat
    if KeyPressed then begin Cmd := UpCase(ReadKey) ;
      case Cmd of
        #0 : case ReadKey of
          #119 : begin ClrScr ; Move(PSave^, PShow^, ScreenSize) ;
            WaitShow end {^Home: show saved screen} ;
          #79 : begin
            if MaxL<=ScrCols then FstCol := 1 else FstCol := MaxL-ScrCols+1 ;
            UpDateText end {End} ;
          #72 : ScrollBy := -1 {Up} ;
          #80 : ScrollBy := +1 {Dn} ;
          #73 : ScrollBy := -ScrRows+1 {PgUp} ;
          #81 : ScrollBy := +ScrRows-1 {PgDn} ;
          #132 : ScrollBy := -MaxLongInt {^PgUp} ;
          #118 : ScrollBy := +MaxLongInt {^PgDn} ;
          #71 : begin FstCol := 1 ; UpDateText end {Home} ;
          #75 : if FstCol>1 then begin Dec(FstCol) ; UpDateText end {Left} ;
          #77 : if FstCol<255 then begin Inc(FstCol) ; UpDateText end {Right} ;
          #115 : Slowness := Slowness + Slowness div 3 {Ctrl-left} ;
          #116 : Slowness := Slowness - Slowness div 4 {Ctrl-right} ;
          #15 : begin for K := #1 to #8 do if FstCol>1 then Dec(FstCol) ;
            UpDateText end {Shift-Tab} ;
          #45 : BREAK {Alt-X : Quit} ;
          else Write(^G) end {case ReadKey} ;
        ^I  : begin for K := #1 to #8 do if FstCol<255 then Inc(FstCol) ;
          UpDateText end {Tab} ;
        ^M  : ScrollBy := Amount ;
        '!' : begin Cd := '' ;
          repeat K := ReadKey ; if K=#13 then BREAK ; Cd := Cd+K until false ;
          CursorOn ; ClrScr ;
          if Cd='' then Write('Type EXIT to return to SHOWER')
            else Cd := ' /C '+Cd ;
          SwapVectors ; Exec(GetEnv('COMSPEC'), 'CON'+Cd) ; SwapVectors ;
          if Cd>'' then WaitShow else ShowText ;
          NoCursor end {Push-to-DOS} ;
        '?' : begin ClrScr ; DoMsg(MsgHelp) ;
          Write('File: "', FileName, '", Seek "', Sk, '" ', Ch[Amount>0]) ;
          if Assigned(Top) then
            Write(', Col ', FstCol, ', Line ', ToP^.No, '/', Last) ;
          WaitShow end {info} ;
        'B' : if Amount>0 then Amount := -Amount {Backwards gear} ;
        'F' : if Amount<0 then Amount := -Amount {Forwards gear} ;


        'H','L' : begin TextMode(LastMode xor Font8x8) ;
          ScrCols := Succ(Lo(WindMax)) ; ScrRows := Succ(Hi(WindMax)) ;
          Inc(WindMax) ; NoCursor ;
          ShowText end ;


        'N' : if Sk>'' then begin while StepPointer and (not Sought(ToP)) do ;
          ShowText end {Next match} ;
        'S' : begin Sk := '' ;
          repeat K := ReadKey ; if K=#13 then BREAK ; Sk := Sk+K until false ;
          if Sk>'' then while (not Sought(ToP)) and StepPointer do ;
          ShowText end {Seek exact match} ;
        'X', #27 : BREAK {X Esc: Quit} ;
        'Y' : begin SetBorder(Magenta) ; StandOut ; BREAK end ;
        'Z' : begin SetBorder(Green) ; RestoreScr ; StandOut ; BREAK end ;
        #32 : begin Auto := not Auto ; if Auto then ScrollBy := Amount end ;
        else Write(^G) end {case Cmd} ;
      end {KeyPressed} ;
    if ScrollBy<>0 then begin Amount := ScrollBy ;
      if Assigned(ToP) and UpdatePointer(ScrollBy)
        then UpDateText else Auto := false ;
      end ;
    if Auto then Delay(Slowness) else ScrollBy := 0 ;
    until false ;
  end {TShower.Run} ;

procedure TShower.GetInput ;
var Pold, Pnew : PNewLine ; TmpStr : string ;
begin SetBorder(Blue) ;
  Pold := NIL ; {Lest no input:} First := NIL ; Pnew := NIL ;
  while not EoF(Input) do begin
    if MaxAvail>=SizeOf(Pnew)+SizeOf(string) then New(PNew)
      else begin SetBorder(Red) ; BREAK end ;
    if Assigned(Pold) then
      begin Pold^.Next := Pnew ; Pnew^.No := Succ(Pold^.No) end else
      begin First := Pnew ; Pnew^.No := 1 end ;
    with Pnew^ do begin Prev := Pold ;
      Readln(Input, TmpStr) { Truncate at 255 } ;
      GetMem(PLine, Length(TmpStr)+1) { At least enough room } ;
      PLine^ := TmpStr end {Pnew^} ;
    Pold := Pnew ;
    end {N EoF} ;
  if Assigned(Pnew) then with Pnew^ do begin Next := NIL ; Last := No end ;
  ToP := First ;
  {$IFDEF MSDOS} { Free heap for Exec :
    see Brian Long, The Borland Pascal Problem Solver, pp.48 }
  SetMemTop(HeapPtr) ;
  (* Write('Freed ', AbAd(HeapEnd)-AbAd(HeapPtr), '':3) ; HeapEnd := HeapPtr ; *)
  {$ELSE} { DPMI : RTM frees Heap } {$ENDIF}
  end {TShower.GetInput} ;

procedure TShower.StandOut ;
var X : PNewLine ;
begin Write(^M) ; Assign(Output, '') ; Rewrite(Output) ; X := First ;
  while Assigned(X) do begin Writeln(X^.PLine^) ; X := X^.Next end ;
  Close(Output) end {TShower.StandOut} ;

destructor TShower.Done ;
var X : PNewLine ;
begin SetBorder(Bord) {?} ; inherited Done ;
  while Assigned(First) do begin X := First ;
    with X^ do begin FreeMem(PLine, Length(PLine^)+1) ; First := Next end ;
    Dispose(X) end {Assigned} ;
  if Cmd<>'Z' then RestoreScr ;
  Dec(WindMax) ; TextMode(SaveMode) ; CursorOn ;
  end {TShower.Done} ;


var AShower : TShower ;

BEGIN {$IFDEF DEBUG} {$IFDEF DPMI} HeapLimit := 0 {$ENDIF} {$ENDIF} ;
with AShower do begin Init ; Run ; Done end ;
END.
0
1
2
3
4
5
6
7
8
9
0
1
2
3
4
5
6
7
8
9
0
1
2
3
4
5
6
7
8
9