Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OOBPLS10.ZIP/OLGIF.PAS

Pascal/Delphi Source File | 1992-11-06 | 14.0 KB | 474 lines

{$F+,O+,R-,S-,V-,A+}
unit OLGIF;  {online GIF decoder using OOBPLUS services}

{$I OPDEFINE.INC}
{.$DEFINE Debug}

interface

uses
  DOS,
  OpRoot,
  OpInline,
  OpCrt,
  OpMouse,
  OpDrag,
  OpFrame,
  OpWindow,
  ApMisc,
  ApTimer,
  ApPort,
  OOCom,
  OOBPlus,
  DeGIF,
  GIFVideo;

const
  UnitVers = '1.0d';
  UnitDate = '05-Jun-91';
  TmpGifName = '$$TEMP$$.GIF';

const
  GifCapOK : Boolean = True;
  GifCapName : PathStr = '';

function DisplayGIFOnline(APP : AbstractPortPtr;
                          WaitForKey : Boolean) : Boolean;
  {-decodes BPlus-encapsulated GIF image data stream}

implementation

const
  BuffSize = 2048;                               {size of our local buffer}
  YInc : Array[1..6] of Byte = (8,8,4,2,1,0);    {used for interlaced image}
  YLin : Array[1..6] of Byte = (0,4,2,1,0,0);    {decoding/management}
  YInt : Array[1..6] of Byte = (7,3,1,0,0,0);

type
  BuffType = Array[1..$FFF1] of Byte;            {local decode buffer types}
  BuffPtr  = ^BuffType;

var
  GBP : BPProtoGIFPtr;       {our GIF BPlus handler}

var
  GIFBuff  : BuffPtr;           {our decode I/O buffer}
  GRec     : JumpRecord;        {used for error handling}
  Pass     : Byte;              {interlace pass counter}
  Intrlace : Boolean;           {true if an interlaced image}
  Image    : Word;              {counter for images in this stream}
  Done     : Boolean;           {true when complete}
  GIFCap   : Boolean;           {true if capturing stream to file}
  InBPlus  : Boolean;           {true once B+ processing active}
  BufIdx   : Word;              {current index in the I/O buffer}
  Count    : Word;              {bytes currently in I/O buffer}
  GF       : File;              {file to write stream to}
  EOFin    : Boolean;           {true if we've seen EOF mark in stream}
  SW       : StackWindowPtr;    {used to save underlying screen}
  MouseB   : Boolean;

{-------------------------------}
{ High-level online GIF decoder }
{-------------------------------}

  procedure RingBell;
    {-noisemaker}
  begin
    Sound(440);
    Delay(100);
    NoSound;
  end;

  procedure Purge(GBP : BPProtoGIFPtr);
    {-purge pending <DLE> after abort}
  var
    E : EventTimer;
    I : Integer;
    C : Char;
  begin
    with GBP^, APort^ do begin
      for I := 1 to 3 do begin
        NewTimerSecs(E,5);
        while not CharReady do
          if TimerExpired(E) then exit;
        PeekChar(C,1);
        if C <> cDLE then
          exit
        else
          if bpGetGIFDataBlock(GIFBuff^,Count,EOFin) then ;
      end;
    end;
  end;

  procedure EndIt(GBP : BPProtoGIFPtr; B : Boolean);
    {-abort processing procedure}
  begin
    if InBPlus then with GBP^ do begin
      if NOT Aborting then
        SendFailure('AAborted by user');
      Purge(GBP);
    end;
    if GraphOn then
      SetTextMode;
    if B then begin
      RingBell;
      RingBell;
    end;
    LongJump(GRec,1);
  end;

  function MyGetByte : Byte;
    {-get next byte in stream}
  var B : Boolean;
  begin
    with GBP^ do begin
        {if we've exhausted the last block, read a new one}
      if BufIdx > Count then begin
        if bpGetGIFDataBlock(GIFBuff^,Count,EOFin) then begin
{$IFDEF Debug}
          if NOT GraphOn then
            WriteLn('Packet size=',Count);
{$ENDIF}
          if GIFCap then begin                  {write the file}
            BlockWrite(GF,GIFBuff^,Count);
            if IOResult <> 0 then begin         {whoops!  clean house}
              Close(GF);  if IOResult = 0 then ;
              GIFCap := False;                  {and set our flag}
            end;
          end;
          bpSendACK;                            {acknowledge the packet}
          BufIdx := 1;                          {reset the buffer index}
        end
        else begin                              {failed packet read, abort...}
{$IFDEF Debug}
          if NOT GraphOn then begin
            WriteLn('Unable to read B+ data packet - Aborting...');
            Delay(2000);
          end;
{$ENDIF}
          EndIt(GBP,True);                      {and leave}
        end;
      end;
    end;

    MyGetByte := GIFBuff^[BufIdx];              {get the byte}
    Inc(BufIdx);                                {keep counter straight}
  end;

  procedure MyPutLine;
    {-plot the raster line of pixels to hardware, handle interlacing}
  var I : Integer;
  begin
    if YCord <= Raster then          {don't wrap back to top of screen!}
      PlotLine(YCord);
    Inc(YCord,YInc[Pass]);           {select next line to plot per interlace}
    if YCord >= BotEdge then begin
      if Pass < 5 then Inc(Pass);    {reset to top of image per interlace}
      YCord := YLin[Pass] + TopEdge;
    end;
  end;

  procedure MyPutLineDbl;
    {-our decoder's PutLine proc.  This method accomodates interlaced GIFs}
  var I : Integer;
  begin
    if YCord <= Raster then        {don't wrap back to top of screen!}
      PlotLine(YCord);
    Inc(YCord,YInc[Pass] shl 1);
    if YCord >= BotEdge then begin
      if Pass < 5 then Inc(Pass);
      YCord := (YLin[Pass] shl 1) + TopEdge;
    end;
  end;

  procedure AdjustVars;
    {-match decode/display vars to image sizes}
  var I : Byte;
  begin
    Inc(Image);
    Pass := 5;
    IntrLace := FALSE;
    LeftEdge  := ImageLeft;
    TopEdge   := ImageTop;
    if (ScrWidth = 300) and (ScrHeight = 200) then begin
      Inc(LeftEdge, 10);
      RightEdge := ImageWidth + LeftEdge;
      BotEdge   := ImageHeight + TopEdge;
    end
    else if (ScrWidth = 378) and (ScrHeight = 240) then begin
      if (DoDbl) then begin
        RightEdge := 700;
        BotEdge := 480;
      end
      else begin
        Inc(LeftEdge, 131);
        Inc(TopEdge, (Raster shr 1) - 120);
        RightEdge := ImageWidth + LeftEdge;
        BotEdge   := ImageHeight + TopEdge;
      end;
    end
    else begin
      if ImageWidth < Pixels then
        Inc(LeftEdge, (Pixels shr 1) - (ImageWidth shr 1));
      if ImageHeight < Raster then
        Inc(TopEdge, (Raster shr 1) - (ImageHeight shr 1));
      RightEdge := ImageWidth + LeftEdge;
      BotEdge   := ImageHeight + TopEdge;
    end;
    YCord := TopEdge;
    if Maps[Local].Interlaced then
      Pass := 1;
  end;

  function OnLineGIFSig : Boolean;
    {-init B+ proto for GIF and get signature.  The scenario is:

         (host->remote)  <ENQ>
         (host<-remote)  <DLE>++<DLE>0
         (host->remote)  BPlus "+" packet
         (host<-remote)  process "+" packet, send ACK packet
         (host->remote)  first "N" packet containing actual GIF stream...

    For hysterical, uh, historical reasons we wait up to 6 chars to receive
    the handshake for the protocol.  (Actually, until recently there were a few
    areas of CIS, such as TREND, that did not provide B+ encapsulation and just
    sent the stream; we had to be able to get either a handshake or the GIF
    signature, and if no B+ then abandon proto processing and get the stream
    "raw".) }

  var C : Char;
      S : String[5];
      I,X : Integer;
  begin
      {set things up}
    OnlineGIFSig := False;
    I := 0;
    GIFSig := '';
{$IFDEF Debug}
    WriteLn('Getting GIF signature...');
{$ENDIF}

      {loop getting bytes from the port and processing}
    repeat
      Inc(I);
      C := #0;
      AsyncStatus := ecOK;
      if I = 1 then X := 30 else X := 10;      {30 secs for first byte, else 10}
      GBP^.APort^.GetCharTimeOut(C,Secs2Tics(X));
      if AsyncStatus <> ecOK then              {read failed, drop out}
        Exit;

      case C of
        #5 :   {<ENQ> seen, respond}
          begin
            GBP^.bpHandleENQ;
            Dec(I);  {dec counter to allow more chars}
          end;
        #16:   {<DLE> starting "+" packet seen, handle it}
          begin
            if GBP^.bpDLESeen then begin    {"+" packet OK, we outa here:}
              OnlineGIFSig := True;
              InBPlus := True;
              GetGIFSig;                    {force first packet read, get}
              exit;                         {6-byte signature for check}
            end
            else
              exit;                         {"+" packet failed, get out}
          end;
        else
          GIFSig := GIFSig + C;             {attempt build of "raw" signature}
      end;
    until I >= 6;
    OnlineGIFSig := True;
  end;

  function PortQuiese(AP : AbstractPortPtr; MinWait,MaxWait : Word) : Boolean;
    {-wait at least MinWait secs for port "quiet", up to MaxWait secs}
  var
    E1,E2 : EventTimer;
    Tmp : BPtr;
  begin
    PortQuiese := True;
    with AP^.Pr^ do begin
      NewTimer(E1,Secs2Tics(MaxWait));
      repeat
        Tmp := InHead;
        NewTimer(E2,Secs2Tics(MinWait));
        while not TimerExpired(E2) do ;
        if Tmp = InHead then exit;
      until TimerExpired(E1);
      PortQuiese := False;
    end;
  end;

  function DecodeGIF(GBP : BPProtoGIFPtr) : Integer;
    {-GIF stream decode logic}
  var I         : Integer;
      BlockType : Char;
  begin
      {init vars}
    Done := False;
    Image := 0;
    CurMap := Global;
    DecodeGIF := -9;

      {get signature (inits BPlus protocol)}
    if NOT OnlineGIFSig then
      EndIt(GBP,False);

      {verify signature.  To accomodate future versions, we accept anything}
      {with the first 3 chars "GIF" and the next 3 as 2 digits and a lower }
      {case char.                                                          }
    if (Pos('GIF',GIFSig) <> 1) or
       (NOT(GIFSig[4] in ['0'..'9'])) or
       (NOT(GIFSig[5] in ['0'..'9'])) or
       (NOT(GIFSig[6] in ['a'..'z'])) then
      EndIt(GBP,True);

      {get the hardware specifics, match a video mode as close as we can}
    GetScrDes(Maps[Global]);
    SelMode := SelectMode(ScrWidth,ScrHeight);
    if SelMode = 0 then EndIt(GBP,True);

      {if we have a global map, process it}
    if Maps[Global].MapExists then
      DoMapping
    else
      SetDefMap;

      {kick into graphics mode then juggle the palette to match our map}

    with GBP^, APort^ do begin
      PutChar(cXoff);                     {tell host to stop transmitting}
      if PortQuiese(APort,1,6) then ;     {wait for port to quiese}
      HideMousePrim(MouseB);              {hide the mouse}
      SW^.Draw;                           {save the screen}
      if (CurrentDisplay in [EGA,VGA]) and
         (ScrWidth = 378) and
         (ScrHeight = 240) then
        if (DoDbl) then
          PutLine := MyPutLineDbl;
      SetGraphicsMode(SelMode);           {set graphics mode}
      AdjustPalette(SelMode);             {and juggle the palette}
      PutChar(cXon);                      {tell host it can start again}
    end;

      {loop reading blocks and processing...}
    while NOT Done do begin
      BlockType := Chr(GetByte);  {get blocktype char}
      case BlockType of
        ',': begin         {"Local descriptor"/image, process...}
               GetImageDescription(Maps[Local]);
               AdjustVars;
               if Maps[Local].MapExists then begin
                   {juggle palette again}
                 CurMap := Local;
                 DoMapping;
                 AdjustPalette(SelMode);
               end;
                 {decode the image data and display}
               I := ExpandGIF;
               if I <> 0 then begin
                 DecodeGIF := I;          {decoder error (LZW couldn't decomp)}
                 EndIt(GBP,True);
               end;
               CurMap := Global;  {reselect global map for possible next image}
             end;
        '!': SkipExtendBlock;     {"Extension" block, we discard}
        ';': begin                {Terminator seen, clean up and go home}
               Done := True;
                 {a "TC" packet will be pending, get it}
               with GBP^ do while NOT EOFin do
                 if bpGetGIFDataBlock(GIFBuff^,Count,EOFin) then
                   bpSendACK;
               InBPlus := False;
                 {if the capture file is open, close it}
               if GIFCap then begin
                 Close(GF);  if IOResult = 0 then ;
                 GifCapOK := True;
               end;
               DecodeGIF := 0;
               exit;
             end;
      end;
    end;
  end;

  function DisplayGIFOnLine(APP : AbstractPortPtr;
                            WaitForKey : Boolean): Boolean;
    {-our high-level online decoder}
  label
    Break;
  var L : LongInt;
      W : Word;
      C : Char Absolute W;
      N : Integer;
      B : Boolean;
  begin
    DisplayGIFOnline := False;
    InBPlus := False;
    MouseB := True;
    GifCapOK := False;
    GBP := nil;

    if NOT GetMemCheck(GIFBuff,BuffSize) then
      exit;

    New(SW, Init(1, 1, ScreenWidth, ScreenHeight));
    if SW = nil then begin
      FreeMemCheck(GIFBuff, BuffSize);
      exit;
    end;

      {init protocol object}
    New(GBP,Init(APP));
    if GBP = NIL then
      goto Break;

      {point to our get/put routines}
    GetByte := MyGetByte;
    PutLine := MyPutLine;

      {init error handler}
    N := SetJump(GRec);
    if N <> 0 then
      goto Break;

      {set buffer vars to force initial read}
    Count := 0;
    BufIdx := 999;

      {init capture file}
    Assign(GF, TmpGifName);
    Rewrite(GF, 1);
    GIFCap := (IOResult = 0);

      {process...}
    N := DecodeGIF(GBP);

      {if successful, wait for keypress}
    if N = 0 then begin
      RingBell;
      DisplayGIFOnline := GIFCap;
        {wait for <CR> or <ESC> before clearing}
      if WaitForKey then repeat
        W := ReadKeyOrButton;
      until (C = #13) or (C = #27) or (Hi(W) in [$ED, $EE, $EF]);
      ClearMouseEvents;
    end;
    SetTextMode;

Break:
    if GBP <> nil then
      Dispose(GBP, Done);
    if SW^.IsActive then
      SW^.EraseHidden;

    MouseGoToXY(ScreenWidth shr 1, ScreenHeight shr 1);
    ShowMousePrim(MouseB);
    Dispose(SW, Done);
    FreeMemCheck(GIFBuff, BuffSize);
  end;

end.