vpdfzlib.pas

生成PDF文档的控件

begin
  if FZRec.total_in = 0 then
    Result := 0
  else
    Result := (1.0 - (FZRec.total_out / FZRec.total_in)) * 100.0;
end;

constructor TDecompressionStream.Create(Source: TStream);
begin
  inherited Create(Source);
  FZRec.next_in := FBuffer;
  FZRec.avail_in := 0;
  DCheck(inflateInit_(FZRec, zlib_version, sizeof(FZRec)));
end;

destructor TDecompressionStream.Destroy;
begin
  FStrm.Seek(-FZRec.avail_in, 1);
  inflateEnd(FZRec);
  inherited Destroy;
end;

procedure PDFRunLengthEnCode(InStream, OutStream: TStream; Size: Integer);
var
  tmpbuf: array[1..3] of Byte;
  ch: Byte;
  OutBuf: array[0..127] of Byte;
  BufCnt: Byte;
  outcnt: Byte;
  RC: Integer;
  ret: Integer;
  procedure Flush;
  var
    t: Byte;
  begin
    if outcnt = 0 then Exit;
    t := outcnt - 1;
    OutStream.Write(t, 1);
    OutStream.Write(outbuf, outcnt);
    outcnt := 0;
  end;
  procedure ProcessUncomp(c: Byte);
  begin
    OutBuf[outcnt] := c;
    Inc(outcnt);
    if outcnt = 128 then Flush;
  end;
  function GetByte: Boolean;
  begin
    Inc(RC);
    if RC > Size then
    begin
      if BufCnt = 1 then ProcessUncomp(tmpbuf[1])
      else if BufCnt = 2 then
      begin
        ProcessUncomp(tmpbuf[1]);
        ProcessUncomp(tmpbuf[2]);
      end;
      Result := False;
      Exit;
    end;
    InStream.read(ch, 1);
    Result := True;
  end;
  function processcomp: integer;
  var
    Len: Integer;
    t: Byte;
  begin
    Len := 3;
    Flush;
    while GetByte do
    begin
      if ch <> tmpbuf[1] then
      begin
        t := (129 - Len) or $80;
        OutStream.Write(t, 1);
        OutStream.Write(tmpbuf[1], 1);
        tmpbuf[1] := ch;
        Result := 1;
        Exit;
      end;
      Inc(Len);
      if Len = 128 then
      begin
        t := (129 - Len) or $80;
        OutStream.Write(t, 1);
        OutStream.Write(tmpbuf[1], 1);
        Result := 2;
        Exit;
      end;
    end;
    t := (129 - Len) or $80;
    OutStream.Write(t, 1);
    OutStream.Write(tmpbuf[1], 1);
    Result := 0;
  end;

begin
  BufCnt := 0;
  outcnt := 0;
  RC := 0;
  while True do
  begin
    if not GetByte then Break;
    Inc(BufCnt);
    tmpbuf[BufCnt] := ch;
    if BufCnt = 3 then
    begin
      if (tmpbuf[1] = tmpbuf[2]) and (tmpbuf[2] = tmpbuf[3]) then
      begin
        ret := processcomp;
        if ret = 0 then Break;
        if ret = 1 then
          BufCnt := 1 else BufCnt := 0;
      end
      else
      begin
        ProcessUncomp(tmpbuf[1]);
        if tmpbuf[2] = tmpbuf[3] then
        begin
          tmpbuf[1] := tmpbuf[3];
          BufCnt := 2;
        end else
        begin
          ProcessUncomp(tmpbuf[2]);
          tmpbuf[1] := tmpbuf[3];
          BufCnt := 1;
        end;
      end;
    end;
  end;
  Flush;
  ch := 128;
  OutStream.Write(ch, 1);
end;

procedure IncFlushByte(InStream, OutStream: TStream);
var
  ch, ak: Byte;
  I: Integer;
begin
  while True do
  begin
    InStream.read(ch, 1);
    if ch = 128 then Break;
    if ch > 128 then
    begin
      InStream.read(ak, 1);
      for i := 1 to 257 - ch do OutStream.Write(ak, 1);
    end;
    if ch < 128 then
      for I := 0 to ch do
      begin
        InStream.read(ak, 1);
        OutStream.Write(ak, 1);
      end;
  end;
end;

function TDecompressionStream.Read(var Buffer; Count: Longint): Longint;
begin
  FZRec.next_out := @Buffer;
  FZRec.avail_out := Count;
  if FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
  while (FZRec.avail_out > 0) do
  begin
    if FZRec.avail_in = 0 then
    begin
      FZRec.avail_in := FStrm.Read(FBuffer, sizeof(FBuffer));
      if FZRec.avail_in = 0 then
      begin
        Result := Count - FZRec.avail_out;
        Exit;
      end;
      FZRec.next_in := FBuffer;
      FStrmPos := FStrm.Position;
      Progress(Self);
    end;
    CCheck(inflate(FZRec, 0));
  end;
  Result := Count;
end;

procedure UpdateContent(InStream, OutStream: TStream);
var
  in_buffer: PByte;
  out_buffer: PByte;
  fin_size: Integer;
  pf_size: PInteger;
begin
  fin_size := 0;
  GetMem(in_buffer, InStream.Size);
  try
    InStream.Position := 0;
    InStream.Read(in_buffer^, InStream.Size);
    pf_size := @fin_size;
    out_buffer := _run_content_specific(in_buffer, InStream.Size, pf_size);
    try
      OutStream.Write(out_buffer^, fin_size);
    finally
      FreeMem(out_buffer);
    end;
  finally
    FreeMem(in_buffer);
  end;
end;

procedure StrToStream(AStream: TStream; st: AnsiString; CR: Boolean = False);
var
  WS: AnsiString;
  Ad: Pointer;
begin
  WS := st;
  if CR then WS := WS + #13#10;
  Ad := @WS[1];
  AStream.Write(ad^, Length(WS));
end;

procedure TraceStream(InStream, OutStream: TStream);
var
  b: Byte;
  ch1, ch2: Byte;
  ex: Boolean;
begin
  ex := False;
  while True do
  begin
    repeat
      InStream.read(ch1, 1);
    until not (ch1 in [32, 13, 10]);
    if ch1 = 62 then
      Exit;
    repeat
      InStream.read(ch2, 1);
    until not (ch2 in [32, 13, 10]);
    if ch2 = 62 then
    begin
      ch2 := 48;
      ex := True;
    end;
    if not ch1 in [48..57, 65..70, 97..102] then
      raise Exception.CreateFmt('Illegal character <%02x>', [ch1]);
    if not ch2 in [48..57, 65..70, 97..102] then
      raise Exception.CreateFmt('Illegal character <%02x>', [ch2]);
    if ch1 in [48..57] then b := (ch1 - 48) shl 4;
    if ch1 in [65..70] then b := (ch1 - 55) shl 4;
    if ch1 in [97..102] then b := (ch1 - 87) shl 4;
    if ch2 in [48..57] then b := (ch2 - 48) + b;
    if ch2 in [65..70] then b := (ch2 - 55) + b;
    if ch2 in [97..102] then b := (ch2 - 87) + b;
    OutStream.Write(b, 1);
    if ex then Exit;
  end;
end;

procedure EscapeValue(ValByte, FlushB: TStream);
var
  ba: array[0..4] of Byte;
  Ou: DWORD;
  a: array[1..4] of Byte absolute Ou;
  i, j: Integer;
  ex: Boolean;
begin
  ex := False;
  while True do
  begin
    repeat
      ValByte.Read(ba[0], 1);
    until not (ba[0] in [32, 13, 10]);
    if ba[0] = 126 then
      Break;
    if ba[0] = 122 then
    begin
      Ou := 0;
      FlushB.Write(ou, 4);
      Continue;
    end;
    if not (ba[0] in [33..117]) then
      raise Exception.CreateFmt('Illegal character <%02x>', [ba[0]]);
    i := 1;
    while i <= 4 do
    begin
      repeat
        ValByte.Read(ba[i], 1);
      until not (ba[i] in [32, 13, 10]);
      if ba[i] = 126 then
      begin
        ex := True;
        Break;
      end;
      if not (ba[i] in [33..117]) then
        raise Exception.CreateFmt('Illegal character <%02x>', [ba[i]]);
      Inc(i);
    end;
    for j := i to 4 do
      ba[j] := 117;
    Ou := 0;
    for j := 0 to 4 do
      Ou := Ou * 85 + Byte(ba[j] - 33);
    if not ex then
    begin
      FlushB.Write(a[4], 1);
      FlushB.Write(a[3], 1);
      FlushB.Write(a[2], 1);
      FlushB.Write(a[1], 1);
    end else
      for j := 1 to i - 1 do
        FlushB.Write(a[5 - j], 1);
    if ex then Break;
  end;
end;

function TDecompressionStream.Write(const Buffer; Count: Longint): Longint;
begin
  raise EDecompressionError.CreateRes(@sInvalidStreamOp);
end;

function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
var
  I: Integer;
  Buf: array[0..4095] of AnsiChar;
begin
  if (Offset = 0) and (Origin = soFromBeginning) then
  begin
    DCheck(inflateReset(FZRec));
    FZRec.next_in := FBuffer;
    FZRec.avail_in := 0;
    FStrm.Position := 0;
    FStrmPos := 0;
  end
  else if ((Offset >= 0) and (Origin = soFromCurrent)) or
    (((Offset - FZRec.total_out) > 0) and (Origin = soFromBeginning)) then
  begin
    if Origin = soFromBeginning then Dec(Offset, FZRec.total_out);
    if Offset > 0 then
    begin
      for I := 1 to Offset div sizeof(Buf) do
        ReadBuffer(Buf, sizeof(Buf));
      ReadBuffer(Buf, Offset mod sizeof(Buf));
    end;
  end
  else
    raise EDecompressionError.CreateRes(@sInvalidStreamOp);
  Result := FZRec.total_out;

end;

procedure PDFASCIIHexEnCode(InStream, OutStream: TStream; Size: Integer);
var
  I: Integer;
  b: Byte;
begin
  for I := 0 to Size - 1 do
  begin
    InStream.read(b, 1);
    OutStream.Write(Z_HexArr[B shr 4], 1);
    OutStream.Write(Z_HexArr[B and $F], 1);
    if (I and $1F) = $1F then
      StrToStream(OutStream, #13);
  end;
  StrToStream(OutStream, '>'#13);
end;

procedure PDFASCII85EnCode(InStream, OutStream: TStream; Size: Integer);
var
  I, tc: Integer;
  o: ShortString;
  t: dword;
  a: array[1..4] of Byte absolute t;
  c: Byte;
begin
  o[0] := #5;
  tc := 0;
  c := 0;
  while tc < Size do
  begin
    if tc + 4 <= Size then
    begin
      InStream.read(a[4], 1);
      InStream.read(a[3], 1);
      InStream.read(a[2], 1);
      InStream.read(a[1], 1);
      if t = 0 then
      begin
        StrToStream(OutStream, 'z');
        Inc(c);
      end else
      begin
        for I := 1 to 5 do
        begin
          o[6 - I] := AnsiChar(chr(t mod 85 + $21));
          t := t div 85;
        end;
        StrToStream(OutStream, o);
        Inc(c, 5);
      end;
      if c > 65 then
      begin
        c := 0;
        StrToStream(OutStream, '', True);
      end;
      Inc(tc, 4);
    end else
    begin
      t := 0;
      for i := 1 to Size - tc do
        InStream.read(a[5 - i], 1);
      for I := 1 to 5 do
      begin
        o[6 - I] := AnsiChar(chr(t mod 85 + $21));
        t := t div 85;
      end;
      o[0] := AnsiChar(chr(Size - tc + 1));
      StrToStream(OutStream, o);
      Inc(tc, 4);
    end;
  end;
  StrToStream(OutStream, '~>');
end;

end.