{ Linux framebuffer interface

  Copyright 2004-2006 Frank Heckenbach <frank@pascal.gnu.de>

  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License as
  published by the Free Software Foundation, version 2.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; see the file COPYING. If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA. }

{$gnu-pascal,I-}
{$if __GPC_RELEASE__ < 20050506}
{$error This program requires GPC release 20050506 or newer.}
{$endif}

unit LinuxFB;

interface

uses GPC;

const
  DefaultFBDevice = '/dev/fb0';

type
  Card8 = Cardinal attribute (Size = 8);
  Card16 = Cardinal attribute (Size = 16);
  Card32 = Cardinal attribute (Size = 32);

  TFBVarScreenInfo = record
    XRes, YRes, XResV, YResV, XOffset, YOffset, BPP, GrayScale: Card32;
    Red, Green, Blue, Transparency: record
      Offset, Length, MSBRight: Card32
    end;
    NonStandard, Activate, Height, Width, AccelFlags, PixelClock, Left, Right, Upper, Lower, HSync, VSync, Sync, VMode: Card32;
    Reserved: array [1 .. 6] of Card32
  end;

  TFBColorMapEntry = array [0 .. 255] of Card16;
  TFBColorMap = record
    Start, Length: Card32;
    r, g, b, t: ^TFBColorMapEntry
  end;

procedure WaitVTActive;
procedure CatchVTChange (procedure ReleaseProc; procedure AcquireProc; GraphicsMode: Boolean);
procedure CleanupVT;
function GetFBScreenInfo (var FBFile: AnyFile; var   Info: TFBVarScreenInfo): Boolean;
function SetFBScreenInfo (var FBFile: AnyFile; const Info: TFBVarScreenInfo): Boolean;
function GetFBColorMap (var FBFile: AnyFile; var   ColorMap: TFBColorMap): Boolean;
function SetFBColorMap (var FBFile: AnyFile; const ColorMap: TFBColorMap): Boolean;

implementation

const
  VT_GETMODE    = $5601;
  VT_SETMODE    = $5602;
  VT_RELDISP    = $5605;
  VT_WAITACTIVE = $5607;
  VT_PROCESS    = 1;

  FBIOGET_VSCREENINFO = $4600;
  FBIOPUT_VSCREENINFO = $4601;
  FBIOGETCMAP = $4604;
  FBIOPUTCMAP = $4605;

  KDSETMODE = $4B3A;
  KDGETMODE = $4B3B;
  KD_TEXT = 0;
  KD_GRAPHICS = 1;

type
  TVTMode = record
    Mode, WaitV: Byte;
    RelSig, AcqSig, FrSig: ShortInt
  end;

var
  VTSaved: Boolean = False;
  VTReleaseProc, VTAcquireProc: procedure;
  VTFile: Text;
  VTModeOld: CInteger = -1;
  VMOld, VMNew: TVTMode;

function IOCtl (...): Integer; external name 'ioctl';

{ Get the number of the working VC -- not the one that's currently active, but
  the one that belongs to our terminal (if any). That's a kludge. Is
  there no official way to find out? }
function TTYNumber: Integer;
var
  i, e: Integer;
  s: TString;
  f: Text;
begin
  TTYNumber := 0;
  {$local I-}
  Reset (f, '/proc/self/stat');
  ReadLn (f, s);
  Close (f);
  {$endlocal}
  if IOResult <> 0 then Exit;
  i := LastPos (') ', s);
  if i = 0 then Exit;
  Delete (s, 1, i + 1);
  for i := 1 to 4 do Delete (s, 1, Pos (' ', s));
  i := Pos (' ', s);
  if i <= 1 then Exit;
  Val (s[1 .. i - 1], i, e);
  if (e <> 0) or (i < $400) or (i >= $480) then Exit;
  TTYNumber := i - $400
end;

procedure WaitVTActive;
var f: Text;
begin
  Rewrite (f, TtyDeviceName);
  Discard (IOCtl (FileHandle (f), VT_WAITACTIVE, TTYNumber));
  Close (f)
end;

procedure Usr1Handler (Signal: CInteger);
begin
  Discard (Signal);
  if Assigned (VTReleaseProc) then VTReleaseProc;
  Discard (IOCtl (FileHandle (VTFile), VT_RELDISP, 1))
end;

procedure Usr2Handler (Signal: CInteger);
begin
  Discard (Signal);
  if Assigned (VTAcquireProc) then VTAcquireProc
end;

procedure CatchVTChange (procedure ReleaseProc; procedure AcquireProc; GraphicsMode: Boolean);
begin
  VTReleaseProc := ReleaseProc;
  VTAcquireProc := AcquireProc;
  Rewrite (VTFile, TtyDeviceName);
  if GraphicsMode then
    begin
      Discard (IOCtl (FileHandle (VTFile), KDGETMODE, @VTModeOld));
      Discard (IOCtl (FileHandle (VTFile), KDSETMODE, KD_GRAPHICS))
    end;
  Discard (InstallSignalHandler (SigUsr1, Usr1Handler, True, False, Null, Null));
  Discard (InstallSignalHandler (SigUsr2, Usr2Handler, False, False, Null, Null));
  Discard (IOCtl (FileHandle (VTFile), VT_GETMODE, @VMOld));
  VMNew := VMOld;
  VMNew.Mode := VT_PROCESS;
  VMNew.WaitV := 0;
  VMNew.RelSig := SigUsr1;
  VMNew.AcqSig := SigUsr2;
  Discard (IOCtl (FileHandle (VTFile), VT_SETMODE, @VMNew));
  VTSaved := True
end;

procedure CleanupVT;
begin
  if VTSaved then
    begin
      Discard (IOCtl (FileHandle (VTFile), VT_SETMODE, @VMOld));
      if VTModeOld >= 0 then Discard (IOCtl (FileHandle (VTFile), KDSETMODE, VTModeOld));
      Write (VTFile, #27'[H'#27'[J')
    end
end;

function GetFBScreenInfo (var FBFile: AnyFile; var Info: TFBVarScreenInfo): Boolean;
begin
  GetFBScreenInfo := IOCtl (FileHandle (FBFile), FBIOGET_VSCREENINFO, @Info) = 0
end;

function SetFBScreenInfo (var FBFile: AnyFile; const Info: TFBVarScreenInfo): Boolean;
begin
  SetFBScreenInfo := IOCtl (FileHandle (FBFile), FBIOPUT_VSCREENINFO, @Info) = 0
end;

function GetFBColorMap (var FBFile: AnyFile; var ColorMap: TFBColorMap): Boolean;
begin
  GetFBColorMap := IOCtl (FileHandle (FBFile), FBIOGETCMAP, @ColorMap) = 0
end;

function SetFBColorMap (var FBFile: AnyFile; const ColorMap: TFBColorMap): Boolean;
begin
  SetFBColorMap := IOCtl (FileHandle (FBFile), FBIOPUTCMAP, @ColorMap) = 0
end;

end.