htmlgif1.pas

查看html文件的控件

    ReadSourceInteger(2, rTop);             // top position
    ReadSourceInteger(2, rWidth);           // size of image
    ReadSourceInteger(2, rHeight);          // size of image

    if rHeight > Height then   {LDB make sure bad values don't overflow elsewhere}  
      rHeight := Height;

    ReadSourceInteger(1, n);                // packed bit field
    rLocalColorValid := ((n and $80) <> 0);
    rInterlaced      := ((n and $40) <> 0);
    rSorted          := ((n and $20) <> 0);

    i := (n and $07);
    if      (i = 0) then rLocalColorSize :=   2
    else if (i = 1) then rLocalColorSize :=   4
    else if (i = 2) then rLocalColorSize :=   8
    else if (i = 3) then rLocalColorSize :=  16
    else if (i = 4) then rLocalColorSize :=  32
    else if (i = 5) then rLocalColorSize :=  64
    else if (i = 6) then rLocalColorSize := 128
    else if (i = 7) then rLocalColorSize := 256
    else                 rLocalColorSize := 256;


// if a local color table is defined, read it
// otherwise, use the global color table

    if (rLocalColorValid) then ReadColorTable(rLocalColorSize, rLocalColorTable)
    else                       rLocalColorTable := fScreenDescriptor^.rGlobalColorTable;

// _something_ must have defined by now ...

    if (rLocalColorTable < 0) then GIF_Error(2);

// the LZW minimum code size

    ReadSourceInteger(1, rLZWSize);

// read data blocks until the end of the list

    ReadSourceInteger(1, db.rSize);
    while (db.rSize > 0) do
        begin
        if fIOStream.Read(db.rData, db.rSize) < db.rSize then
          Gif_Error(24);             {LDB}
        fDataStream.Write(db.rData, db.rSize);
        ReadSourceInteger(1, db.rSize);
        end;

// save the pixel list

    rPixelCount := rWidth * rHeight;
    if rPixelCount = 0 then    {LDB}  
      Gif_Error(26);
    rPixelList := allocmem(rPixelCount);
    if (rPixelList = nil) then
      OutOfMemoryError;

// uncompress the data and write the bitmap

    LZWDecode(id);
    end; // with id^
end;


{ ---------------------------------------------------------------------------- }
{ read in a group of data blocks until a zero-length block is found }
{ store the data on the give TList }

procedure TGif.ReadDataBlockList(List: TList);
var
    b:      byte;
    db:     PGifDataBlock;
    BytesRead: integer;
begin

// read data blocks until the end of the list

fIOStream.Read(b, 1);                       // size of next block
while (b > 0) do                            // more blocks to get?
    begin
    new(db);                                // new data block record
    db^.rSize := b;
    BytesRead := fIOStream.Read(db^.rData, db^.rSize);   // read the data
    List.Add(db);                           // save in given list

    if BytesRead < db^.rSize then
      Gif_Error(24);                       {LDB}
    fIOStream.Read(b, 1);                   // size of next block
    end;
end;



{ ---------------------------------------------------------------------------- }
{ read in any type of extension record }
{ assume that the source position is AFTER the extension separator, }
{ but BEFORE the specific extension label }
{ the extension record we read in is stored in the master extension }
{ list; however, the indexes for these exrtensions is stored in a }
{ temporary list which will be assigned to the next image descriptor }
{ record read in.  this is because all extension blocks preceed the }
{ image descriptor to which they belong }

procedure TGif.ReadExtension(var Done: boolean);
var
    n:    integer;
    b:      byte;
    eb:     PGifExtension;
begin

// make a list exists

if (fExtension = nil) then fExtension := TList.Create;

// make a new extension record and add it to temp holding list

new(eb);
if (eb = nil) then OutOfMemoryError;
fillchar(eb^, sizeof(TGifExtension), 0);
fExtension.Add(eb);

// get the type of extension

fIOStream.Read(b, 1);
eb^.rLabel := b;

// "with eb^" gives us access to rGraphic, rText, rComment, and rApp

with eb^ do
    begin

// a graphic extension

    if (rLabel = kGifLabelGraphic) then
        begin
        ReadSourceInteger(1, rGraphic.rBlockSize);      // block size
        if (rGraphic.rBlockSize <> 4) then GIF_Error(5);

        ReadSourceInteger(1, n);                        // packed bit field
        rGraphic.rDisposal         := ((n shr 2) and $07);
        rGraphic.rUserInputValid   := ((n and $02) <> 0);
        rGraphic.rTransparentValid := ((n and $01) <> 0);

        ReadSourceInteger(2, rGraphic.rDelayTime);      // delay time
        ReadSourceInteger(1, rGraphic.rTransparentIndex);   // transparent color
        ReadSourceInteger(1, n);                        // block terminator
        if (n <> 0) then GIF_Error(7);
        end

// a comment extension

    else if (rLabel = kGifLabelComment) then
        begin
        rComment.rDataBlockList := TList.Create;
          ReadDataBlockList(rComment.rDataBlockList);
        end

// a plain text extension

    else if (rLabel = kGifLabelText) then
        begin
        ReadSourceInteger(1, rText.rBlockSize);         // block size
        if (rText.rBlockSize <> 12) then GIF_Error(5);
        ReadSourceInteger(2, rText.rGridLeft);          // grid position
        ReadSourceInteger(2, rText.rGridTop);           // grid position
        ReadSourceInteger(2, rText.rGridWidth);         // grid size
        ReadSourceInteger(2, rText.rGridHeight);        // grid size
        ReadSourceInteger(1, rText.rCellWidth);         // character cell size    {LDB}{was 2 bytes}
        ReadSourceInteger(1, rText.rCellHeight);        // character cell size
        ReadSourceInteger(1, rText.rForegroundIndex);   // foreground color
        ReadSourceInteger(1, rText.rBackgroundIndex);   // background color
        rText.rDataBlockList := TList.Create;           // list of text data blocks
        ReadDataBlockList(rText.rDataBlockList);
        end

// an application extension

    else if (rLabel = kGifLabelApplication) then
        begin
        ReadSourceInteger(1, rApp.rBlockSize);          // block size
        if (rApp.rBlockSize <> 11) then //GIF_Error(5);       {LDB} allow other  blocksizes
          begin
          fIOStream.Position := fIOStream.Position+rApp.rBlockSize;
          rApp.rDataBlockList := TList.Create;
          ReadDataBlockList(rApp.rDataBlockList);
          end
        else
          begin
        fIOStream.Read(rApp.rIdentifier, 8);            // application identifier
        fIOStream.Read(rApp.rAuthentication, 3);        // authentication code
        rApp.rDataBlockList := TList.Create;
        ReadDataBlockList(rApp.rDataBlockList);
        if rApp.rIdentifier = 'NETSCAPE' then
          ExtractLoopCount(rApp.rDataBlockList);
          end;
        end

// unknown type

    else
        begin
        GIF_ErrorMessage('unknown extension: ' + IntToHex(rLabel, 4)); 
        end;
    end; // with eb^
end;


{ ---------------------------------------------------------------------------- }
{ read a 1 or 2-byte integer from the source stream }

procedure TGif.ReadSourceInteger(size: integer; var value: integer);
var
    b:  byte;
    w:  word;
begin
if (size = 1) then
    begin
    fIOStream.Read(b, 1);
    value := b;
    end
else if (size = 2) then
    begin
    fIOStream.Read(w, 2);
    value := w;
    end
else
    begin
    GIF_Error(8);
    end;
end;

{ ---------------------------------------------------------------------------- }
{ decode the compressed data blocks into a bitmap }

procedure TGif.LZWDecode(pID: PGifImageDescriptor);
var
    pc:         integer;            // next compressed code parsed from input
    cc:         integer;            // current code to translate
    oc:         integer;            // old code translated
    tt:         integer;            // temp storage for OldCode
    Done:       boolean;
begin

// init local data

LZWInit(pID);
LZWReset;

// do everything within the ZIP record

with fZipData^ do
    begin

// parse next code from BitString

    pc := LZWGetCode;
    oc := pc;
    Done := False;
    while (pc <> rEndCode) and not Done do      
        begin

// reset decode parameters and save first code

        if (pc = rClearCode) then
            begin
            rCurSize := rID^.rLZWSize + 1;
            rCurSlot := rEndCode + 1;
            rTopSlot := (1 shl rCurSize);
            while (pc = rClearCode) do pc := LZWGetCode;
            if (pc = rEndCode) then
              GIF_Error(13);   
            if (pc >= rCurSlot) then pc := 0;
            oc := pc;
            LZWSaveCode(pc);
            end

// find a code in the table and write out translation

        else
            begin
            cc := pc;
            if (cc < rCurSlot) then
                begin
                LZWDecodeCode(cc);
                if (rCurSlot <= rTopSlot) then
                    begin
                    LZWSaveSlot(oc, cc);
                    oc := pc;
                    end;
                LZWCheckSlot;
                end

// add a new code to the decode table

            else
                begin
                if (cc <> rCurSlot) then GIF_Error(13);
                tt := oc;
                while (oc > rHighCode) do oc := rPrefix[oc];
                if (rCurSlot <= rTopSlot) then LZWSaveSlot(tt, oc);
                LZWCheckSlot;
                LZWDecodeCode(cc);
                oc := pc;
                end;
            end;

// write out translated bytes to the image storage

            LZWWriteBitmap;
            if fDataStream.Position < fDataStream.Size then
              pc := LZWGetCode
            else Done := True;    
            rMaxVal := false;

        end; // while not EOI

    end;    // with

// done with stack space

LZWFinit;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.LZWInit(pID: PGifImageDescriptor);
begin

// get a valid record?

if (pID = nil) then GIF_Error(11);

// make sure we can actually decode this turkey

// if ((pID^.rLZWSize < 2) or (pID^.rLZWSize > 9)) then GIF_Error(12);

// allocate stack space

new(fZipData);
if (fZipData = nil) then OutOfMemoryError;

// init data block

fillchar(fZipData^, sizeof(TGifZip), 0);
fZipData^.rID := pID;
fZipData^.rCT := fColorTableList.Items[pID^.rLocalColorTable];

// reset data stream

fDataStream.Position := 0;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.LZWFinit;
begin
if (fZipData <> nil) then dispose(fZipData);
fZipData := nil;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.LZWReset;
var
    i:    integer;
begin
with fZipData^ do
    begin
    for i := 0 to (kGifCodeTableSize - 1) do
        begin
        rPrefix[i] := 0;
        rSuffix[i] := 0;
        end;

    rCurSize   := rID^.rLZWSize + 1;
    rClearCode := (1 shl rID^.rLZWSize);
    rEndCode   := rClearCode + 1;
    rHighCode  := rClearCode - 1;
    rFirstSlot := (1 shl (rCurSize - 1)) + 2;
    rNextSlot  := rFirstSlot;
    rMaxVal    := false;
    end;    // with
end;


{ ---------------------------------------------------------------------------- }
{ get the next code from the BitString }
{ CurrentSize specifies the number of bits to get }

function TGif.LZWGetCode: integer;
var
    n:    integer;
    cc:     integer;
    mask:   integer;
    b:      byte;
begin
with fZipData^ do
    begin

// make sure we have enough bits