OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vpbgib2.zip/GRAPHSRV.PAS

Pascal/Delphi Source File | 1996-11-02 | 14KB | 480 lines

{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█                                                       █}
{█      Virtual Pascal v1.1                              █}
{█      BGI Graphics Server for mixed BGI/Textmode       █}
{█      ─────────────────────────────────────────────────█}
{█      Copyright (C) 1996 fPrint UK Ltd                 █}
{█        Written May-Sep 1996 by Allan Mertner          █}
{█        Pipe interface engineered by Alex Vermeulen    █}
{█                                                       █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}

program GraphSrv;

{&PMTYPE PM}
{$Delphi+}

uses Use32, Dos, Os2Def, Os2Base, Strings, Dgraph, BGImsg, SysUtils, VPUtils;

const
  Stopping : boolean = false;

var
  que  : HQueue;       // Queue used to notify about input

{-----[ Graph Server wrappers for Image functions ]-----}

function SrvGetImage( x1, y1, x2, y2: Longint; Buffer: Pointer ): uLong;
var
  rc: ApiRet;

begin
  // Get access to shared memory
  rc := DosGetSharedMem( Buffer, pag_Write );
  if rc = 0 then
    begin
      GetImage( x1, y1, x2, y2, Buffer^ );

      // Release access to shared memory
      DosFreeMem( Buffer );
      SrvGetImage := 0;
    end
  else
    SrvGetImage := rc;
end;

function SrvPutImage( x, y: Longint; Buffer: Pointer; Mode: Longint ): uLong;
var
  rc: ApiRet;

begin
  // Get access to shared memory
  rc := DosGetSharedMem( Buffer, pag_Read or pag_Write );
  if rc = 0 then
    begin
      PutImage( x, y, Buffer^, Mode );

      // Release access to shared memory
      DosFreeMem( Buffer );
      SrvPutImage := 0;
    end
  else
    SrvPutImage := rc;
end;

{-----[ Graph Server input handler ]-----}

// SendKeyStroke: Send keystroke notification to client
function InputThread( p: Pointer ): ApiRet;
var
  rc: ApiRet;
  data: pInputT;
  Buffer : pInputArrayT;
  M: MouseEventRecT;
  Inx: Word;

  function NextData: pInputT;
  begin
    NextData := @Buffer^[Inx];
    Inc(Inx);
    if Inx > MaxInput then
      Inx := 0;
  end;

begin
  // Allocate memory buffer for talking to client process
  rc := DosAllocSharedMem( Pointer(Buffer), nil, Sizeof(InputArrayT),
    pag_read or pag_write or pag_commit or obj_gettable );
  Inx := 0;

  // Tell client the address of the memory
  Data := NextData;
  rc := DosWriteQueue( que, bgi_Init, Sizeof(Data), Data, 0 );

  while not Stopping do
    begin
      if KeyPressed then
        begin
          Data := NextData;
          data^.Ch := ReadKey;
          rc := DosWriteQueue( que, bgi_Key, Sizeof(Data), Data, 0 );
        end
      else if MouseMoved then
        begin
          MouseMoved := False;
          Data := NextData;
          data^.X := CurrentMouseX;
          data^.Y := CurrentMouseY;
          rc := DosWriteQueue( que, bgi_mPos, Sizeof(Data), Data, 0 );
        end
      else if MouseClicked then
        begin
          Data := NextData;
          GetMouseEvent( M );
          data^.EventX := M.X;
          data^.EventY := M.Y;
          data^.EventType := Byte(M.Event);
          rc := DosWriteQueue( que, bgi_Mou, Sizeof(Data), Data, 0 );
        end
      else
        DosSleep( 31 );
    end;
  DosFreeMem( Buffer );
end;

{-----[ Graph Server error handlers ]-----}

type
  EGraphSrv = class(Exception);

procedure Error( No: Integer; s: String; rc: Longint );
begin
  Case No of
    1 : raise EGraphSrv.CreateFmt( 'Cannot open BGI pipe %s. Maybe another instance is already running.', [s] );
    2 : raise EGraphSrv.CreateFmt( 'Cannot create semaphore %s; rc = %d', [s, rc] );
    3 : raise EGraphSrv.CreateFmt( 'Cannot link named pipe and semaphore; rc = %d', [rc] );
    4 : raise EGraphSrv.CreateFmt( 'Cannot read data from pipe; rc = %d', [rc] );
    5 : raise EGraphSrv.CreateFmt( 'Cannot send result to client; rc = %d', [rc] );
    6 : raise EGraphSrv.Create( 'SetTextStyle failed; check BGIPath' );
    7 : raise EGraphSrv.CreateFmt( 'Cannot connect to pipe; rc = %d', [rc] );
    8 : raise EGraphSrv.CreateFmt( 'Cannot open queue %s; rc = %d', [s, rc] );
  else
    raise EGraphSrv.CreateFmt( 'Unknown error occured; rc = %d', [rc] );
  end;
  Halt( No );
end;

{-----[ Graph Server pipe handler and message dispatcher ]-----}

var
  pip  : HPipe;        // Pipe used to talk to client
  hevn : HEv;          // Event semaphore associated with pipe

procedure openpipe( Name: String );
var
  rc: ApiRet;
  MyName: String;
  Pid: ULong;

begin
  // Create named pipe for communicating with client
  name[Length(name)+1] := #0;
  rc:=DosCreateNPipe( @Name[1],pip,NP_ACCESS_DUPLEX,  // Duplex pipe
                      NP_WAIT OR
                      NP_WMESG OR                     // Write messages
                      NP_RMESG OR                     // Read messages
                      1,                              // Unique instance of pipe
                      256,                            // Output buffer size
                      4096*sizeof(Word),              // Input buffer size
                      1000);                          // Use default time-out
  if rc <> No_Error then
    Error( 1, Name, rc );

  // Create event semaphore to link with pipe
  while pos( '\', Name ) <> 0 do
    Delete( Name, 1, pos( '\', Name ) );
  MyName := '\SEM32\' + name+#0;
  rc := DosCreateEventSem( @Myname[1], hevn, 0, false );
  if rc <> No_Error then
    Error( 2, MyName, rc );

  // Link semaphore and pipe together
  rc := DosSetNPipeSem( Pip, hsem(hevn), 1);
  if rc <> No_Error then
    Error( 3, '', rc );

  // Connect to the pipe
  rc := DosConnectNPipe(Pip);
  if rc <> No_Error then
    Error( 7, '', rc );

  // Create queue for transmitting input events
  MyName := '\QUEUES\' + name+#0;
  rc := DosOpenQueue( Pid, que, @MyName[1] );
  if rc <> No_Error then
    Error( 8, MyName, rc );
end;

// WaitForConn: Wait for client to connect to the pipe
procedure WaitForConn;
var
  rc     : ApiRet;
  Buffer : Longint;
  fRead  : Longint;
  fAvail : AvailData;
  fState : Longint;

begin
  repeat
    // Have a look at the pipe data
    rc := DosPeekNPipe(pip, Buffer, 0, fRead, fAvail, fState);
    if rc <> 0 then
      Stopping := True;
    if fAvail.cbPipe = 0 then
      begin
        // No data available in pipe
        if fState in [ np_state_Disconnected, np_State_Closing ] then
          begin
            // If exiting, return EOF
            Stopping := True;
            Exit;
          end;
        // No data: Wait a little before retrying
        DosSleep( 31 );
      end;
    // Stay in loop until data received
  until ( rc = No_Error ) and ( fAvail.cbPipe <> 0 );
end;

procedure ProcessBGIMessages;
var
  point   : ^CommandListT;
  nrpar   : word;
  len     : word;
  cmd     : word;
  lineS   : LineSettingsType;
  ArcC    : ArcCoordsType;
  Pal     : PaletteType;
  Fill    : FillPatternType;
  FillI   : FillSettingsType;
  textS   : TextSettingsType;
  View    : ViewPortType;
  State   : Ulong;
  rc      : ApiRet;
  Ptr     : word;
  res     : BGIResArT;
  ulBytesR: uLong;
  ulBytes : uLong;
  r       : DisplayListT;

begin
  repeat
    repeat
      rc := DosRead(Pip,                  { Handle of pipe }
                    r,                    { Buffer for message read }
                    sizeof(DisplayListT), { Buffer size }
                    ulBytesR);            { Number of bytes actually read }
      if rc = Error_No_Data then
        WaitForConn;
    until (rc <> error_no_Data) or Stopping;

    if rc <> No_Error then
      // Error; cannot normally occur, since we know that there are
      // data in the pipe
      Error( 4, '', rc );

    // Stop DIVE from refreshing the display while drawing
    SuspendRefresh;
    Ptr    :=0;
    res[0] :=0;

    // Process all messages
    while Ptr < ulBytesR div Sizeof(word) do
    begin
      cmd   := r.w[Ptr];      // Command number
      nrpar := r.w[Ptr+1];    // Parameter count
      len   := r.w[Ptr+2];    // Length of expected return value
      point := @r.w[Ptr+3];   // Array of points (x,y)

      // Execute one command
      with point^ do
        case cmd of
          1: Arc(x1,y1,w3,w4,w5);
          2: Bar(x1,y1,x2,y2);
          3: Bar3D(x1,y1,x2,y2,w5,w6=1);
          4: Circle(x1,y1,w3);
          5: ClearDevice;
          6: ClearViewPort;
          7: CloseGraph;
          8: DetectGraph(res[0],res[1]);
          9: DrawPoly(nr,pts);
          10: Ellipse(x1,y1,w3,w4,w5,w6);
          11: FillEllipse(x1,y1,w3,w4);
          12: FillPoly(nr,pts);
          13: FloodFill(x1,y1,w3);
          14: begin GetArcCoords(ArcC);move(arcC,res,sizeof(arcC)) end;
          15: GetAspectRatio(res[0],res[1]);
          16: res[0]:=getBkColor;
          17: res[0]:=GetColor;
          18: begin GetDefaultpalette(Pal);move(Pal,res,sizeof(Pal)) end;
          19: begin s:=GetDriverName;move(s,res,sizeof(s)) end;
          20: begin GetFillPattern(Fill);move(fill,res,sizeof(fill)) end;
          21: begin GetFillSettings(FillI);move(fillI,res,sizeof(fillI)) end;
          22: res[0]:=GetGraphMode;
          23: res[0]:=SrvGetImage( x1, y1, x2, y2, Pointer(i[4]) );
          24: begin getlinesettings(lineS);move(lineS,res,sizeof(lineS)) end;
          25: res[0]:=GetMaxColor;
          26: res[0]:=GetMaxX;
          27: res[0]:=GetMaxY;
          28: begin s:=getModeName(w1);move(s,res,sizeof(s)) end;
          29: begin GetPalette(Pal); move(Pal,res,sizeof(Pal)) end;
          30: res[0]:=GetPaletteSize;
          31: res[0]:=GetPixel(x1,y1);
          32: begin gettextsettings(textS);move(texts,res,sizeof(texts)) end;
          33: begin getviewsettings(view);move(view,res,sizeof(view)) end;
          34: res[0]:=GetX;
          35: res[0]:=GetY;
          36: GraphDefaults;
          39: res[0]:=ImageSize(x1,y1,x2,y2);
          41: res[0]:=InstallUserFont(s);
          42: Line(x1,y1,x2,y2);
          43: LineRel(x1,y1);
          44: LineTo(x1,y1);
          45: MoveRel(x1,y1);
          46: MoveTo(x1,y1);
          47: OutText(s);
          48: OutTextXY(x1,y1,s);
          49: PieSlice(x1,y1,w3,w4,w5);
          50: res[0]:=SrvPutImage(x,y,Buffer,m);
          51: PutPixel(x1,y1,w3);
          52: Rectangle(x1,y1,x2,y2);
          53: RegisterBGIFont(i1,pointer(w2));
          54: Sector(x1,y1,w3,w4,w5,w6);
          55: SetAllPalette(PaletteType(i[0]));
          56: SetAspectRatio(w1,w2);
          57: SetBkColor(w1);
          58: SetColor(w1);
          59: SetFillPattern(fillpatterntype(w[1]),w1);
          60: SetFillStyle(w1,w2);
          61: SetLineStyle(w1,w2,w3);
          62: SetPalette(w1,w2);
          63: SetRGBPalette(w1,w2,w3,w4);
          64: SetTextJustify(w1,w2);
          65: SetTextStyle(i1,i2,i3);
          66: SetUserCharSize(w1,w2,w3,w4);
          67: SetViewPort(x1,y1,x2,y2,w5=1);
          68: SetWriteMode(i1);
          69: res[0]:=TextHeight(s);
          70: res[0]:=TextWidth(s);
          71: SetWideFillPattern(newpatterntype(w[1]),w1);
        else
          // Ignore unknown commands
        end;

        // Skip command and parameters
        Inc(Ptr,nrpar+3);
      end;

    // Re-enable DIVE refreshind the display
    EnableRefresh;

    // Always send at least one word of acknowledgment to client
    if len = 0 then
      len := 1;

    if ulBytesR > 0 then
      begin
        rc:= DosWrite(Pip,              // Handle of pipe
                      res,              // Buffer containing message to write
                      len*sizeof(word), // Length of message
                      ulBytes);         // Number of bytes actually written

        if rc <> No_Error then
          Error( 5, '', rc );
      end
    else
      // Check if connection is broken
      WaitForConn;

  until ulBytesR = 0;
end;

// Close pipe connection
procedure shutconn;
var
  rc: ApiRet;
begin
  rc := DosCloseEventSem(hevn);
  rc := DosDisConnectNPipe(Pip);
end;

procedure ServerProcess;
begin
  // Open pipe for communications with client
  OpenPipe(BGIPipeName);
  // Start thread capturing input events
  VPBeginThread( InputThread, 16384, nil );

  try
    try
      ClearDevice;
      GraphDefaults;

      // Receive and execute BGI commands
      repeat
        if not Stopping then
          ProcessBGIMessages;
      until Stopping;

    except
      // Ignore ^C but terminate.  This is also generated if the
      // parent process is closed
      on EControlC do ;
    else
      // Re-raise all other exceptions to display error message
      raise;
    end;
  finally
    // Close the DIVE window and pipe connection
    CloseGraph;
    ShutConn;
  end;
end;

var
  ok          : Integer;
  BGIPath     : String;

procedure ParseCmdLine;
var
  s : String;
  x : Integer;

begin
  // Set up defaults;
  WaitKeypressed := False;
  BGIPath := '';
  x_Size := 640;
  y_Size := 480;
  // Process command line parameters
  // -P<PipeName> sets the pipe name
  // -X<Number>   sets the horizontal resolution
  // -Y<Number>   sets the vertical resolution
  // -B<Path>     sets the path to BP BGI fonts
  for x:=1 to paramcount do
    begin
      s := ParamStr(x);
      if s[1] IN ['/','-'] then
        case upcase(s[2]) of
          'P': begin
                 BGIPipeName:=copy(s,3,length(s));
                 WindowTitle:=copy(s,3,length(s));
               end;
          'X': Val(copy(s,3,length(s)),X_Size,ok);
          'Y': Val(copy(s,3,length(s)),Y_Size,ok);
          'B': begin
                 BGIPath := s;
                 Delete( BGIPath, 1, 2 );
               end;
        end;
    end;

  if BGIPath = '' then
    BGIPath := GetEnv( 'BGIDIR' );
end;

begin
  ParseCmdLine;

  // Initialise DIVE window
  VPInitGraph( x_Size, y_Size, BGIPath );
  ok := GraphResult;
  if ok <> 0 then
    raise EGraphSrv.CreateFmt( 'Error initialising GRAPH window; rc = %d', [ok] );

  ServerProcess;
end.