vpdftiff.pas

生成PDF文档的控件

function LibTiffDelphiVersion: AnsiString;
procedure TIFFReadRGBAImageSwapRB(Width, Height: Cardinal; Memory: Pointer); forward;
function TIFFGetVersion: PAnsiChar; cdecl; external;
function TIFFFindCODEC(Scheme: Word): PTIFFCodec; cdecl; external;
function TIFFRegisterCODEC(Scheme: Word; Name: PAnsiChar; InitMethod: TIFFInitMethod): PTIFFCodec; cdecl; external;
procedure TIFFUnRegisterCODEC(c: PTIFFCodec); cdecl; external;
function TIFFIsCODECConfigured(Scheme: Word): Integer; cdecl; external;
function TIFFGetConfiguredCODECs: PTIFFCodec; cdecl; external;
function TIFFOpen(const Name: AnsiString; const Mode: AnsiString): PTIFF;
function TIFFOpenStream(const Stream: TStream; const Mode: AnsiString): PTIFF;
function TIFFClientOpen(Name: PAnsiChar; Mode: PAnsiChar; ClientData: Cardinal;
  ReadProc: TIFFReadWriteProc;
  WriteProc: TIFFReadWriteProc;
  SeekProc: TIFFSeekProc;
  CloseProc: TIFFCloseProc;
  SizeProc: TIFFSizeProc;
  MapProc: TIFFMapFileProc;
  UnmapProc: TIFFUnmapFileProc): PTIFF; cdecl; external;
procedure TIFFCleanup(Handle: PTIFF); cdecl; external;
procedure TIFFClose(Handle: PTIFF); cdecl; external;
function TIFFFileno(Handle: PTIFF): Integer; cdecl; external;
function TIFFSetFileno(Handle: PTIFF; Newvalue: Integer): Integer; cdecl; external;
function TIFFClientdata(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFSetClientdata(Handle: PTIFF; Newvalue: Cardinal): Cardinal; cdecl; external;
function TIFFGetMode(Handle: PTIFF): Integer; cdecl; external;
function TIFFSetMode(Handle: PTIFF; Mode: Integer): Integer; cdecl; external;
function TIFFFileName(Handle: PTIFF): Pointer; cdecl; external;
function TIFFSetFileName(Handle: PTIFF; Name: PAnsiChar): PAnsiChar; cdecl; external;
function TIFFGetReadProc(Handle: PTIFF): TIFFReadWriteProc; cdecl; external;
function TIFFGetWriteProc(Handle: PTIFF): TIFFReadWriteProc; cdecl; external;
function TIFFGetSeekProc(Handle: PTIFF): TIFFSeekProc; cdecl; external;
function TIFFGetCloseProc(Handle: PTIFF): TIFFCloseProc; cdecl; external;
function TIFFGetSizeProc(Handle: PTIFF): TIFFSizeProc; cdecl; external;
{$IFNDEF VOLDVERSION}
procedure TIFFError(Module: Pointer; Fmt: Pointer); cdecl; external; varargs;
procedure TIFFWarning(Module: Pointer; Fmt: Pointer); cdecl; external; varargs;
{$ELSE}
procedure TIFFError(Module: Pointer; Fmt: Pointer); cdecl; external;
procedure TIFFWarning(Module: Pointer; Fmt: Pointer); cdecl; external;
{$ENDIF}
function TIFFSetErrorHandler(Handler: TIFFErrorHandler): TIFFErrorHandler; cdecl; external;
function LibTiffDelphiGetErrorHandler: LibTiffDelphiErrorHandler;
function LibTiffDelphiSetErrorHandler(Handler: LibTiffDelphiErrorHandler): LibTiffDelphiErrorHandler;
function TIFFSetWarningHandler(Handler: TIFFErrorHandler): TIFFErrorHandler; cdecl; external;
function LibTiffDelphiGetWarningHandler: LibTiffDelphiErrorHandler;
function LibTiffDelphiSetWarningHandler(Handler: LibTiffDelphiErrorHandler): LibTiffDelphiErrorHandler;
function TIFFSetTagExtender(Extender: TIFFExtendProc): TIFFExtendProc; cdecl; external;
function TIFFFlush(Handle: PTIFF): Integer; cdecl; external;
function TIFFFlushData(Handle: PTIFF): Integer; cdecl; external;
function TIFFReadDirectory(Handle: PTIFF): Integer; cdecl; external;
function TIFFCurrentDirectory(Handle: PTIFF): Word; cdecl; external;
function TIFFCurrentDirOffset(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFLastDirectory(Handle: PTIFF): Integer; cdecl; external;
function TIFFNumberOfDirectories(Handle: PTIFF): Word; cdecl; external;
function TIFFSetDirectory(Handle: PTIFF; Dirn: Word): Integer; cdecl; external;
function TIFFSetSubDirectory(Handle: PTIFF; Diroff: Cardinal): Integer; cdecl; external;
function TIFFCreateDirectory(Handle: PTIFF): Integer; cdecl; external;
function TIFFWriteDirectory(Handle: PTIFF): Integer; cdecl; external;
function TIFFUnlinkDirectory(handle: PTIFF; Dirn: Word): Integer; cdecl; external;
procedure TIFFPrintDirectory(Handle: PTIFF; Fd: Pointer; Flags: Integer); cdecl; external;
{$IFNDEF VOLDVERSION}
function TIFFGetField(Handle: PTIFF; Tag: Cardinal): Integer; cdecl; external; varargs;
function TIFFGetFieldDefaulted(Handle: PTIFF; Tag: Cardinal): Integer; cdecl; external; varargs;
function TIFFSetField(Handle: PTIFF; Tag: Cardinal): Integer; cdecl; external; varargs;
{$ELSE}
function TIFFGetField(Handle: PTIFF; Tag: Cardinal; var Value: Cardinal): Integer; cdecl; external;
function TIFFGetFieldDefaulted(Handle: PTIFF; Tag: Cardinal; var Value: Cardinal): Integer; cdecl; external;
function TIFFSetField(Handle: PTIFF; Tag: Cardinal; var Value: Cardinal): Integer; cdecl; external;
{$ENDIF}
function TIFFVGetField(Handle: PTIFF; Tag: Cardinal; Ap: Pointer): Integer; cdecl; external;
function TIFFVSetField(Handle: PTIFF; Tag: Cardinal; Ap: Pointer): Integer; cdecl; external;
function TIFFIsBigEndian(Handle: PTIFF): Integer; cdecl; external;
function TIFFIsTiled(Handle: PTIFF): Integer; cdecl; external;
function TIFFIsByteSwapped(Handle: PTIFF): Integer; cdecl; external;
function TIFFIsUpSampled(Handle: PTIFF): Integer; cdecl; external;
function TIFFIsMSB2LSB(Handle: PTIFF): Integer; cdecl; external;
function TIFFGetTagListCount(Handle: PTIFF): Integer; cdecl; external;
function TIFFGetTagListEntry(Handle: PTIFF; TagIndex: Integer): Cardinal; cdecl; external;
procedure TIFFMergeFieldInfo(Handle: PTIFF; Info: PTIFFFieldInfo; N: Integer); cdecl; external;
function TIFFFindFieldInfo(Handle: PTIFF; Tag: Cardinal; Dt: Integer): PTIFFFieldInfo; cdecl; external;
function TIFFFindFieldInfoByName(Handle: PTIFF; FIeldName: PAnsiChar; Dt: Integer): PTIFFFieldInfo; cdecl; external;
function TIFFFieldWithTag(Handle: PTIFF; Tag: Cardinal): PTIFFFieldInfo; cdecl; external;
function TIFFFieldWithName(Handle: PTIFF; FieldName: PAnsiChar): PTIFFFieldInfo; cdecl; external;
function TIFFDataWidth(DataType: Integer): Integer; cdecl; external;
function TIFFReadRGBAImage(Handle: PTIFF; RWidth, RHeight: Cardinal; Raster: Pointer; Stop: Integer): Integer; cdecl; external;
function TIFFReadRGBAImageOriented(Handle: PTIFF; RWidth, RHeight: Cardinal; Raster: Pointer; Orientation: Integer; Stop: Integer): Integer; cdecl; external;
function TIFFReadRGBAStrip(Handle: PTIFF; Row: Cardinal; Raster: Pointer): Integer; cdecl; external;
function TIFFReadRGBATile(Handle: PTIFF; Col, Row: Cardinal; Raster: Pointer): Integer; cdecl; external;
function TIFFRGBAImageOk(Handle: PTIFF; Emsg: PAnsiChar): Integer; cdecl; external;
function TIFFRGBAImageBegin(Img: PTIFFRGBAImage; Handle: PTIFF; Stop: Integer; Emsg: PAnsiChar): Integer; cdecl; external;
function TIFFRGBAImageGet(Img: PTIFFRGBAImage; Raster: Pointer; W, H: Cardinal): Integer; cdecl; external;
procedure TIFFRGBAImageEnd(Img: PTIFFRGBAImage); cdecl; external;
function TIFFCurrentRow(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFStripSize(Handle: PTIFF): Integer; cdecl; external;
function TIFFRawStripSize(Handle: PTIFF; Strip: Cardinal): Integer; cdecl; external;
function TIFFVStripSize(Handle: PTIFF; NRows: Cardinal): Integer; cdecl; external;
function TIFFDefaultStripSize(Handle: PTIFF; Request: Cardinal): Cardinal; cdecl; external;
function TIFFNumberOfStrips(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFComputeStrip(Handle: PTIFF; Row: Cardinal; Sample: Word): Cardinal; cdecl; external;
function TIFFReadRawStrip(Handle: PTIFF; Strip: Cardinal; Buf: Pointer; Size: Integer): Integer; cdecl; external;
function TIFFReadEncodedStrip(Handle: PTIFF; Strip: Cardinal; Buf: Pointer; Size: Integer): Integer; cdecl; external;
function TIFFWriteRawStrip(Handle: PTIFF; Strip: Cardinal; Data: Pointer; Cc: Integer): Integer; cdecl; external;
function TIFFWriteEncodedStrip(Handle: PTIFF; Strip: Cardinal; Data: Pointer; Cc: Integer): Integer; cdecl; external;
function TIFFCurrentStrip(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFTileSize(Handle: PTIFF): Integer; cdecl; external;
function TIFFTileRowSize(Handle: PTIFF): Integer; cdecl; external;
function TIFFVTileSize(Handle: PTIFF; NRows: Cardinal): Integer; cdecl; external;
procedure TIFFDefaultTileSize(Handle: PTIFF; Tw: PCardinal; Th: PCardinal); cdecl; external;
function TIFFNumberOfTiles(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFComputeTile(Handle: PTIFF; X, Y, Z: Cardinal; S: Word): Cardinal; cdecl; external;
function TIFFReadRawTile(Handle: PTIFF; Tile: Cardinal; Buf: Pointer; Size: Integer): Integer; cdecl; external;
function TIFFReadEncodedTile(Handle: PTIFF; Tile: Cardinal; Buf: Pointer; Size: Integer): Integer; cdecl; external;
function TIFFWriteRawTile(Handle: PTIFF; Tile: Cardinal; Data: Pointer; Cc: Integer): Integer; cdecl; external;
function TIFFWriteEncodedTile(Handle: PTIFF; Tile: Cardinal; Data: Pointer; Cc: Integer): Integer; cdecl; external;
function TIFFCurrentTile(Handle: PTIFF): Cardinal; cdecl; external;
function TIFFScanlineSize(Handle: PTIFF): Integer; cdecl; external;
function TIFFRasterScanlineSize(Handle: PTIFF): Integer; cdecl; external;
function TIFFReadScanline(Handle: PTIFF; Buf: Pointer; Row: Cardinal; Sample: Word): Integer; cdecl; external;
function TIFFWriteScanline(Handle: PTIFF; Buf: Pointer; Row: Cardinal; Sample: Word): Integer; cdecl; external;
procedure TIFFSetWriteOffset(Handle: PTIFF; Off: Cardinal); cdecl; external;
procedure TIFFSwabShort(Wp: PWord); cdecl; external;
procedure TIFFSwabLong(Lp: PCardinal); cdecl; external;
procedure TIFFSwabDouble(Dp: PDouble); cdecl; external;
procedure TIFFSwabArrayOfShort(Wp: PWord; N: Cardinal); cdecl; external;
procedure TIFFSwabArrayOfLong(Lp: PCardinal; N: Cardinal); cdecl; external;
procedure TIFFSwabArrayOfDouble(Dp: PDouble; N: Cardinal); cdecl; external;
procedure TIFFReverseBits(Cp: Pointer; N: Cardinal); cdecl; external;
function TIFFGetBitRevTable(Reversed: Integer): Pointer; cdecl; external;
function _TIFFmalloc(s: Longint): Pointer; cdecl;
function _TIFFrealloc(p: Pointer; s: Longint): Pointer; cdecl;
procedure _TIFFfree(p: Pointer); cdecl;

implementation

uses
  Math, VPDFCLibs, VPDFJpegLib, VPDFZLib;

type

  TQsortCompare = function(a, b: Pointer): Integer; cdecl;
  TBsearchFcmp = function(a: Pointer; b: Pointer): Integer; cdecl;

function floor(x: Double): Double; cdecl; forward;

function pow(x: Double; y: Double): Double; cdecl; forward;

function sqrt(x: Double): Double; cdecl; forward;

function atan2(y: Double; x: Double): Double; cdecl; forward;

function exp(x: Double): Double; cdecl; forward;

function log(x: Double): Double; cdecl; forward;

function fabs(x: Double): Double; cdecl; forward;

function rand: Integer; cdecl; forward;

function strlen(s: Pointer): Cardinal; cdecl; forward;
{$IFNDEF VOLDVERSION}
function strcmp(a: Pointer; b: Pointer): Integer; cdecl; forward;
{$ENDIF}

function strncmp(a: Pointer; b: Pointer; c: Longint): Integer; cdecl; forward;

procedure qsort(base: Pointer; num: Cardinal; width: Cardinal; compare: TQSortCompare); cdecl; forward;

function bsearch(key: Pointer; base: Pointer; nelem: Cardinal; width: Cardinal; fcmp: TBsearchFcmp): Pointer; cdecl; forward;

function memmove(dest: Pointer; src: Pointer; n: Cardinal): Pointer; cdecl; forward;

function strchr(s: Pointer; c: Integer): Pointer; cdecl; forward;

procedure _TIFFmemcpy(d: Pointer; s: Pointer; c: Longint); cdecl; forward;

procedure _TIFFmemset(p: Pointer; v: Integer; c: Longint); cdecl; forward;

function _TIFFmemcmp(buf1: Pointer; buf2: Pointer; count: Cardinal): Integer; cdecl; forward;

var

  _TIFFwarningHandler: TIFFErrorHandler;
  _TIFFerrorHandler: TIFFErrorHandler;
  FLibTiffDelphiWarningHandler: LibTiffDelphiErrorHandler;
  FLibTiffDelphiErrorHandler: LibTiffDelphiErrorHandler;

function fabs(x: Double): Double;
begin
  if x < 0 then
    Result := -x
  else
    Result := x;
end;

function atan2(y: Double; x: Double): Double;
begin
  Result := ArcTan2(y, x);
end;

function rand: Integer; cdecl;
begin
  Result := Trunc(Random * ($7FFF + 1));
end;

function sqrt(x: Double): Double; cdecl;
begin
  Result := System.Sqrt(x);
end;

function log(x: Double): Double; cdecl;
begin
  Result := Ln(x);
end;

function exp(x: Double): Double; cdecl;
begin
  Result := System.Exp(x);
end;

function strchr(s: Pointer; c: Integer): Pointer; cdecl;
begin
  Result := s;
  while True do
  begin
    if PByte(Result)^ = c then exit;
    if PByte(Result)^ = 0 then
    begin
      Result := nil;
      exit;
    end;
    Inc(PByte(Result));
  end;
end;

function memmove(dest: Pointer; src: Pointer; n: Cardinal): Pointer; cdecl;
begin
  MoveMemory(dest, src, n);
  Result := dest;
end;

function _TIFFmemcmp(buf1: Pointer; buf2: Pointer; count: Cardinal): Integer; cdecl;
var
  ma, mb: PByte;
  n: Integer;
begin
  ma := buf1;
  mb := buf2;
  n := 0;
  while Cardinal(n) < Count do
  begin
    if ma^ <> mb^ then
    begin
      if ma^ < mb^ then
        Result := -1
      else
        Result := 1;
      exit;
    end;
    Inc(ma);
    Inc(mb);
    Inc(n);
  end;
  Result := 0;
end;

procedure _TIFFmemset(p: Pointer; v: Integer; c: Longint); cdecl;
begin
  FillMemory(p, c, v);
end;

function bsearch(key: Pointer; base: Pointer; nelem: Cardinal; width: Cardinal; fcmp: TBsearchFcmp): Pointer; cdecl;
begin
  raise Exception.Create('Bsearch - should presumably not occur');
end;

procedure qsort(base: Pointer; num: Cardinal; width: Cardinal; compare: TQSortCompare); cdecl;
var
  m: Pointer;
  n: Integer;
  o: Pointer;
  oa, ob, oc: Integer;
  p: Integer;
begin
  if num < 2 then exit;
  GetMem(m, num * width);
  if compare(base, Pointer(Cardinal(base) + width)) <= 0 then
    CopyMemory(m, base, (width shl 1))
  else
  begin
    CopyMemory(m, Pointer(Cardinal(base) + width), width);
    CopyMemory(Pointer(Cardinal(m) + width), base, width);
  end;
  n := 2;
  while Cardinal(n) < num do
  begin
    o := Pointer(Cardinal(base) + Cardinal(n) * width);
    if compare(m, o) >= 0 then
      ob := 0
    else
    begin
      oa := 0;
      ob := n;
      while oa + 1 < ob do
      begin
        oc := ((oa + ob) shr 1);
        p := compare(Pointer(Cardinal(m) + Cardinal(oc) * width), o);
        if p < 0 then
          oa := oc
        else if p = 0 then
        begin
          ob := oc;
          break;
        end
        else
          ob := oc;
      end;
    end;
    if ob = 0 then
    begin
      MoveMemory(Pointer(Cardinal(m) + width), m, Cardinal(n) * width);
      CopyMemory(m, o, width);
    end
    else if ob = n then
      CopyMemory(Pointer(Cardinal(m) + Cardinal(n) * width), o, width)
    else
    begin
      MoveMemory(Pointer(Cardinal(m) + Cardinal(ob + 1) * width), Pointer(Cardinal(m) + Cardinal(ob) * width),
        Cardinal(n - ob) * width);
      CopyMemory(Pointer(Cardinal(m) + Cardinal(ob) * width), o, width);
    end;
    Inc(n);
  end;
  CopyMemory(base, m, num * width);
  FreeMem(m, num * width);
end;

function _TIFFrealloc(p: Pointer; s: Longint): Pointer; cdecl;
var
  m: TMemoryManager;
begin
  GetMemoryManager(m);
  if p = nil then
    Result := m.GetMem(s)
  else
    Result := m.ReallocMem(p, s);
end;

function strncmp(a: Pointer; b: Pointer; c: Longint): Integer; cdecl;
var
  ma, mb: PByte;
  n: Integer;
begin
  ma := a;
  mb := b;
  n := 0;
  while n < c do
  begin
    if ma^ <> mb^ then
    begin
      if ma^ < mb^ then
        Result := -1
      else
        Result := 1;
      exit;
    end;
    if ma^ = 0 then
    begin
      Result := 0;
      exit;