CP/M/CPM_CDROM.iso/beehive/bbs/rosuncr.arc/ROSUNCR.PAS

Pascal/Delphi Source File | 1991-08-11 | 10KB | 342 lines

{ ROSUNCR.PAS vers 1.0  17Dec87
  by W. Brimhall  Z-Node 52  [phone]

  This program adds Uncrunch support to a modified CP/M 80 ROS
  vers 3.4 system. It must be compiled with the cHn option using
  the same Start & End address as the main ROS program.

  The main ROS program passes parameters to ROSUNCR in these global
  variables:

      name          type          desc
      =========     ============  ==================================
      in_library    boolean       true if library file open
      libr_file     untyped file  file to uncrunch if in_library
      XfrFile       untyped file  file to uncrunch if not in_library
      SetDrv        integer       file area Drive
      SetUsr        integer       file area User
      HomDrv        integer       ROS.COM Drive
      HomUsr        integer       ROS.COM User
      remote_online boolean       true if online with remote system
      local_online  boolean       true if online with local console
      usr_rec       record        User data

  The file will be open and ready to access once the correct file area
  is selected. If it is a LBR file it will be positioned to the record
  containing the selected file member.

  The file is uncrunched and typed using UNCREL by Steven Greenberg. The
  main ROS.COM program is then reexecuted.  This chained file scheme was
  necessary because of the 24k buffer needed for UNCREL to operate.

  The main ROS program requires these modifications:
   1) It must chain to ROSUNCR.CHN when a crunched file is specified
      for the <T>ype command.
   2) It must preserve the heap during the chain & execute.
   3) It must go directly into file mode when it is executed by Turbo
      Pascal instead of CP/M.
}

program rosuncr;
{$C-}

{****************************************}
{* Global variables shared with ROS.COM *}
{****************************************}

  {$I ROSDEF.INC}

{**************************************}
{* Variables used by ROSUNCR.CHN only *}
{**************************************}

  var
    fbyte: byte;
    x, BufferPtr, curin,
    lastc, NoOfRecs, line_count, remaining: integer;
    EndOFFile: Boolean;

{**************************}
{* Machine dependent code *}
{**************************}

{ These file names should be changed to match your ROS hardware files. }

  {$I tdoswy60.MCH}                  { teminal and channel routines }
  {$I courier.MDM}                   { Modem routines }
  {$I tdos.CLK}                      { Clock routines }


{******************************}
{* Procedures from ROSKIO.INC *}
{******************************}

function online: boolean;
{ Determine whether system is still online - local or remote }
  begin
    if remote_online
      then if ch_carck
             then online := TRUE
             else
               begin
                 putstat('Carrier lost');
                 mdhangup;
                 remote_online := FALSE;
                 online := FALSE
               end
      else online := local_online;
  end;

Procedure PutChar(ch: char);
{ User written I/O driver to output character }
  var
    i: integer;
  begin
    if user_rec.shift_lock
      then ch := UpCase(ch);
    if printer_copy
      then BDOS(5, ord(ch));
    if online
      then
        begin
          if (ch <> BEL) or local_online
            then BDOS(6, ord(ch));
          if remote_copy
            then
              begin
                ch_out($7F and ord(ch));
                if ch = CR
                  then for i := 1 to user_rec.nulls do
                    ch_out(ord(NUL));
                if ch = LF
                  then for i := 1 to (user_rec.nulls shr 2) do
                    ch_out(ord(NUL))
              end
        end
  end;

function GetChar: char;
{ Get character: no wait, no echo }
  var
    ch: char;
  begin
    if keypressed
      then
        begin
          read(KBD, ch);
          if (not online) and (not (ch in [^C, LF, CR]))
            then ch := NUL;
          case ch of
            ^W: begin
                  op_chat := TRUE;
                  ch := ' '
                end;
            ^E: begin
                  remote_copy := not remote_copy;
                  if remote_copy
                    then putstat('Remote copy on')
                    else putstat('Remote copy off');
                  ch := NUL
                end;
            ^R: begin
                  delay_down := not delay_down;
                  if delay_down
                    then putstat('Delayed shutdown on')
                    else putstat('Delayed shutdown off');
                  ch := NUL
                end;
            ^T: begin
                  remote_online := FALSE;
                  mdhangup;
                  ch := NUL
                end;
            LF: begin
                  if online
                    then putstat('^W: CHAT, ^E: Remote copy on/off, ^R: Remote offline - delayed, ^T: Twit')
                    else putstat('^C: Shutdown ROS, [C/R]: Local use');
                  ch := NUL
                end
          end
        end
    else if remote_online and remote_copy and ch_carck and ch_inprdy
      then ch := chr($7F and ch_inp)
      else ch := NUL;
    GetChar := ch
  end;

function brk: boolean;
{ Check for break or pause }
  var
    ch: char;
  begin
    ch := GetChar;
    while ch = DC3 do                       { ^S }
      repeat
        ch := GetChar
      until (not online) or (ch <> NUL);
    brk := (not online) or (ch = ETX)       { ^C }
  end;

procedure pause;
{ Pause for user response before continuing }
  begin
    Write(USR, 'Press any key to continue...');
    if user_rec.noisy
      then Write(USR, BEL);
    repeat
    until (not online) or (GetChar <> NUL);
    Write(USR, CR, ' ':28, CR)
  end;

{******************************}
{* Procedures from ROSKMS.INC *}
{******************************}

procedure SetSect(Drive, User: integer);
{ Set to file section }
  begin
    BDOS(seldrive, Drive);
    BDOS(getseluser, User)
  end;

{**********************************}
{* New procedures for Uncrunching *}
{**********************************}

  procedure uncrel;
    begin
      {$I UNCREL.INC}

      {UNCREL.INC must have following addresses patched in:

         byte          address
         ----          -----------------
         1+2            24k uncr buffer
         7+8            getbyt routine
         10+11          out routine

        The calling SP is stored at Uncrel+542h. To abort the uncrunch
       procedure the in or out routine must restore the SP to this value
       and execute a Z80 RET instruction.
      }

  end;

  function getc: integer;
  { Get an 8 bit value from the input buffer - read block if necessary }
    begin
      if BufferPtr > 128 then
        begin
          if in_library
            then
              {$I-} BlockRead(libr_file, Buffer, 1) {$I+}
            else
          {$I-} BlockRead(XfrFile, Buffer, 1) {$I+};
          EndOfFile := (IOresult <> 0);
          BufferPtr := 1
        end;
      getc := Buffer[BufferPtr];
      BufferPtr := succ(BufferPtr)
    end;

  procedure uncr_fname;
  { Display uncrunched file name }
    var
      b: byte;
    begin
      write(USR,'      ===> ');
      for i:= 1 to 2 do
        b:=getc;                 { skip header bytes (76feh) }
      while (b <> 0) do          { display uncrunched file name }
        begin
          write(USR,char(b));
          b:=getc
        end;
      for b:=1 to 2 do
        writeln(USR);
      BufferPtr:=1;              { Reset pointer to start of file }
      line_count:=3
    end;

  procedure getbyte;
    begin
      if EndOFFile then { exit from Uncrel if premature eof }
        begin
          writeln(USR);
          inline(
            $ed/$7b/uncrel+$542/    { ld sp,(uncrel+542h) ;restore old sp }
            $c9)              { ret }
        end;
      fbyte := getc;
         end;

  procedure output;
  { Output uncruched bytes to USR output driver. Filter clear screen
    and form feed chars. Insert screen breaks & monitor for ^S and
    ^C. }
   begin
     if (fbyte <> $1a) and (fbyte <> $0c) then
       begin  { filter clear screen & form feed chars }
          write(USR,char(fbyte));
            if (user_rec.lines <> 99) and (char(fbyte) = LF) then
              begin
                line_count := succ(line_count);
                if line_count mod user_rec.lines = 0
                  then pause
              end;
       end;
     if brk then { Exit Uncrel if ^C is entered }
       begin
         writeln(USR);
         inline(
           $ed/$7b/uncrel+$542/    { ld sp,(uncrel+542h) ;restore old sp }
           $c9)              { ret }
       end;
   end;

  procedure getbyt;
    begin
      inline(
        $cd/getbyte/  {call getbyte}
        $3a/fbyte    {ld a,(fbyte)}
      );
    end;

  procedure out;
    begin
      inline(
        $32/fbyte/    {ld (fbyte),a}
        $cd/output   {call output}
      );
    end;

procedure patch;
{ Patch UNCREL I/O addresses and set 24k buffer to 3800h }
  begin
    mem[addr(uncrel)+1]:=$00;
    mem[addr(uncrel)+2]:=$38;
    {Set address of getbyt & out routines}
    mem[addr(uncrel)+7]:=addr(getbyt) mod 256;
    mem[addr(uncrel)+8]:=addr(getbyt) div 256;
    mem[addr(uncrel)+10]:=addr(out) mod 256;
    mem[addr(uncrel)+11]:=addr(out) div 256;
  end;

{*****************}
{* Main  program *}
{*****************}

  begin
    UsrOutPtr:=addr(putchar);      { Reassign USR: to ROS output driver }
    BufferPtr := MaxInt;           { Force a file read }
    patch;                         { Patch UNCREL addresses }
    SetSect(SetDrv,SetUsr);        { Select DU: of file area }
    uncr_fname;                    { Display uncrunched file name }
    uncrel;                        { Uncrunch & type the file }
    if not in_library then         { Close the file if not in LBR }
      close (XfrFile);
    SetSect(HomDrv,HomUsr);        { Select DU: of ROS.COM }
    assign(chain_file,'ROS.COM');
    execute(chain_file);           { Reexecute ROS.COM }
  end.