CP/M/CPM_CDROM.iso/beehive/bbs/picsuncr.arc/PICSUNCR.PAS

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

{ PICSUNCR.PAS vers 1.0  06mar88
  by W. Brimhall  Z-Node 52  [phone]

  This program adds Uncrunch support to a modified CP/M 80 PICS vers
  1.6 system.

  To install make sure your .MCH, .MDM & .CLK file names match the
  ones below then compile this program with the cHn option using the
  same Start & End addresses as the main PICS program. The resulting
  PICSUNCR.CHN file must then be placed in the same file area with
  PICS.COM. The main PICS program must also be re-compiled with the
  new uncrunch support files.

  The main PICS program passes parameters to PICSUNCR 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       PICS.COM Drive
      HomUsr        integer       PICS.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 PICS.COM program is then re-executed.  This chained file scheme was
  necessary because of the 24k buffer needed for UNCREL to operate.

  The main PICS program requires these modifications:
   1) It must chain to PICSUNCR.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 picsuncr;
{$C-}

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

  {$I PICSDEF.INC}    { PICS definitions }
  {$I PICSTYPE.INC}   { PICS Type statements }
  {$I PICSVAR.INC}    { PICS Variables }
  {$I picsvar1.unc}   { New file with global uncrunch variables }

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

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

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

{ These files names must match your PICS hardware files. }

  {$I pics.MCH}             { Terminal and channel routines }
  {$I pics.MDM}             { Modem routines }

{************************************************}
{* Procedures duplicated from main PICS program *}
{************************************************}

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
                  putstat('^W: CHAT, ^E: Remote copy on/off, ^R: Remote offline - delayed, ^T: Twit');
                  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;

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

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

  procedure getbyt; forward;

  procedure out; forward;

  procedure uncrel;
    begin
      {$I UNCREL.UNC}  { patched vers of 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;
  { Get a byte from crunched file }
    begin
      inline(
        $cd/getbyte/  {call getbyte}
        $3a/fbyte    {ld a,(fbyte)}
      );
    end;

  procedure out;
  { Output uncrunched byte to User output routine }
    begin
      inline(
        $32/fbyte/    {ld (fbyte),a}
        $cd/output   {call output}
      );
    end;

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

  begin
    UsrOutPtr:=addr(putchar);      { Reassign USR: to PICS output driver }
    BufferPtr := MaxInt;           { Force a file read }
    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 PICS.COM }
    assign(chain_file,'PICS.COM');
    execute(chain_file);           { Reexecute PICS.COM }
  end.

{ end of PICSuncr.pas }