stmime.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

  { Create memory stream for search }
  ScanStream := TMemoryStream.Create;
  try
    ScanStream.SetSize(StmSize);
    StmOffset := Stream.Position;
    ScanSize := ScanStream.CopyFrom(Stream, Min(StmSize,
      (Stream.Size - Stream.Position)));

    StrPCopy(SearchString, #13#10'begin');
    BMMakeTableZ(SearchString, BMT);
    ScanStream.Position := 0;

    while True do begin
      { Look for an old style attachment -- process appropriately }
      if BMSearchZ(ScanStream.Memory^, ScanSize, BMT, SearchString, FoundPos) then begin

        FillChar(TempBuf, SizeOf(TempBuf), #0);
        Pos := FoundPos + 2;

        { Collect line containing potential begin marker }
        for I := 0 to 79 do begin
          if MemArray(ScanStream.Memory^)[Pos+I] = #13 then Break;
          TempBuf[I] := MemArray(ScanStream.Memory^)[Pos+I];
        end;

        { Grab second word -- should be a number if this is an attachment }
        ExtractWordZ(TokenBuf, 2, TempBuf, ' ');
        if Str2WordZ(TokenBuf, TempWord) then begin
          { We've got an attachment }
          NewAtt := TStAttachment.Create;
          NewAtt.atStreamOffset := Pos;
          ExtractWordZ(TokenBuf, 1, TempBuf, ' ');
          if CompStringZ(TokenBuf, 'begin') = 0 then
            NewAtt.atEncoding := 'uuencoded'
          else
            NewAtt.atEncoding := 'base64';
          ExtractWordZ(TokenBuf, 3, TempBuf, ' ');
          NewAtt.atFilename := StrPas(TokenBuf);
          NewAtt.atOldStyle := True;
          Attachments.AddObject(NewAtt.atFileName, NewAtt);
          NewAtt := nil;
          Break;
        end else begin
          Stream.Position := (StmOffset + LongInt(FoundPos) + LongInt(StrLen(SearchString)));
          StmOffset := Stream.Position;
          ScanStream.Position := 0;
          ScanSize := ScanStream.CopyFrom(Stream,
            Min(StmSize, (Stream.Size - Stream.Position)));
        end;

      end else begin
        if (ScanSize < StmSize) then Exit;
        Stream.Seek(-StrLen(SearchString), soFromCurrent);
        StmOffset := Stream.Position;
        ScanStream.Position := 0;
        ScanSize := ScanStream.CopyFrom(Stream,
          Min(StmSize, (Stream.Size - Stream.Position)));
      end;
    end;
  finally
    ScanStream.Free;
    NewAtt.Free;
  end;
end;

procedure TStMimeConverter.ForceType(ConverterType : TStConverterClass);
begin
  if not (Converter is ConverterType) then begin
    FConverter.Free;
    FConverter := nil;
    FConverter := ConverterType.Create(Self);
    FConverter.OnProgress := Progress;
  end;
end;

function TStMimeConverter.GenerateBoundary : string;
var
  Temp : TDateTime;
begin
  Temp := Now;
  Randomize;
  Result := 'StMime-' + IntToHex(Trunc(Temp), 8) + '-' +
    IntToHex(Trunc(Frac(Temp) * 10000), 8) + '-' +
    IntToHex(GetTickCount, 8) + '-' + IntToHex(Random($FFFF), 4);
end;

function TStMimeConverter.GetBoundary : string;
begin
  if FBoundary = '' then
    FBoundary := GenerateBoundary;
  Result := FBoundary;
end;

function TStMimeConverter.GetStream : TStream;
begin
  if not Assigned(FStream) then begin
    if not Assigned(FInternalStream) then
      FInternalStream := TMemoryStream.Create;
    FStream := FInternalStream;
  end;
  Result := FStream;
end;

function TStMimeConverter.GetTag(const Description : string): string;
var
  I : Integer;
begin
  for I := 0 to (Converters.Count - 1) do begin
    if CompareStr(Description,
      TCvtFormat(Converters.Objects[I]).Description) = 0 then begin
      Result := Converters[I];
      Exit;
    end;
  end;
end;

procedure TStMimeConverter.InitConverter;
begin
  FAttachments := TStringList.Create;
  FContentType := DefStContentType;
  FContentDisposition := DefStContentDisposition;
  FEncoding := DefStMimeEncoding;
  FMimeHeaders := True;                                                
  GetConverters;
end;

procedure TStMimeConverter.PositionForExtract(Att : TStAttachment);
const
  BufSize = 1024;
var
  I : Integer;
  Ptr : PChar;
  TempBuf : array[0..BufSize] of Char;
begin
  FillChar(TempBuf, SizeOf(TempBuf), #0);
  Stream.Position := Att.atStreamOffset;
  Stream.Read(TempBuf, BufSize);
  if Att.atOldStyle then begin
    for I := 0 to BufSize do begin
      if TempBuf[I] = #13 then begin
        Stream.Position := (Att.atStreamOffset + I);
        Exit;
      end;
    end;
  end else begin
    Ptr := StrPos(TempBuf, #13#10#13#10'');
    Stream.Position := (Att.atStreamOffset + (Ptr - TempBuf));
  end;
end;

procedure TStMimeConverter.Progress(Sender : TObject; Status : TStConvertState;
  PercentDone : Byte);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Sender, Status, PercentDone);
end;

class procedure TStMimeConverter.RegisterConverter(const ATag, ADesc : string;
  AClass : TStConverterClass);
begin
  GetConverters.AddConverter(ATag, ADesc, AClass);
end;

procedure TStMimeConverter.SaveAs(var FileName : string);
begin
  if Assigned(FOnSaveAs) then FOnSaveAs(Self, FileName);
end;

procedure TStMimeConverter.ScanAttachments;
const
  StmSize = 32*1024;
type
  MemArray = array[0..(StmSize-1)] of Char;
var
  I, Pos, ScanSize, StmOffset : LongInt;
  TTree : TStTernaryTree;
  TTag : Pointer;
  NewAtt : TStAttachment;
  ScanStream : TMemoryStream;
  OStr : TStString;
  FoundPos, BoundPos : Cardinal;
  SearchString : array[0..80] of Char;
  TempBuf : array[0..1024] of Char;
  AttToken : array[0..MaxMimeLine] of Char;
  BMT : BTable;

  function Min(A, B : LongInt) : LongInt;
  begin
    Result := A;
    if A > B then
      Result := B;
  end;

  procedure InitTree;
  begin
    TTree := TStTernaryTree.Create;
    with TTree do begin
      InsertStr('CONTENT-TYPE', Pointer(ctType));
      InsertStr('CONTENT-TRANSFER-ENCODING', Pointer(ctEncoding));
      InsertStr('CONTENT-DESCRIPTION', Pointer(ctDescription));
      InsertStr('CONTENT-DISPOSITION', Pointer(ctDisposition));
    end;
  end;

begin
  NewAtt := nil;
  TTree := nil;

  DeleteAttachments;

  { Position stream to beginning }
  Stream.Seek(0, soFromBeginning);

  { Create memory stream for search }
  ScanStream := TMemoryStream.Create;
  try
    ScanStream.SetSize(StmSize);
    StmOffset := Stream.Position;
    ScanSize := ScanStream.CopyFrom(Stream, Min(StmSize,
      (Stream.Size - Stream.Position)));

    { If we have a boundary, use it -- if not, look for one }
    if FBoundary = '' then
      StrCopy(SearchString, #13#10'--')
    else begin
      FBoundaryUsed := True;
      StrPCopy(SearchString, '--' + Boundary);
    end;
    BMMakeTableZ(SearchString, BMT);
    ScanStream.Position := 0;

    while True do begin
      { Look for a Mime boundary -- process appropriately }
      if BMSearchZ(ScanStream.Memory^, ScanSize, BMT, SearchString, FoundPos) then begin

        Pos := FoundPos + StrLen(SearchString);

        { Add add'l checks here -- look for the Boundary header entry first }
        { if that method fails, beef up this method against false positives a bit }
        { maybe checking for 'Content-' shortly following this potential boundary }

        { Do we have a boundary? If not, assume this might be it and collect }
        if FBoundary = '' then begin
          FillChar(TempBuf, SizeOf(TempBuf), #0);
          for I := 0 to (MaxMimeLine - 1) do begin
            if MemArray(ScanStream.Memory^)[Pos+I] = #13 then begin
              Pos := Pos+I;                                            
              Break;
            end;
            TempBuf[I] := MemArray(ScanStream.Memory^)[Pos+I];
          end;
          Boundary := StrPas(TempBuf);
          StrCopy(StrECopy(SearchString, '--'), TempBuf);

          { Adjust to account for CR/LF searched on this go around }
          Inc(FoundPos, 2);

          { Get this out of the way for subsequent searches }
          BMMakeTableZ(SearchString, BMT);
        end;

        if not Assigned(TTree) then InitTree;

        { Check to see if this was an 'ending' boundary }
        if (MemArray(ScanStream.Memory^)[Pos] = '-') and               
           (MemArray(ScanStream.Memory^)[Pos+1] = '-') then begin      
          { Position the stream to the beginning of the end marker }
          FEndBoundaryOffset := (StmOffset + LongInt(FoundPos) - 2);   
          Stream.Position := FEndBoundaryOffset;
          Exit;
        end else begin
          if not Assigned(NewAtt) then NewAtt := TStAttachment.Create;
          { Go ahead and reposition here -- won't lose us much, and it }
          { guarantees all tags for this attachment will be within the buffer }
          NewAtt.atStreamOffset := (StmOffset + LongInt(FoundPos));    
          Stream.Position := (StmOffset + LongInt(FoundPos) + Length(FBoundary) + 2); 
          StmOffset := Stream.Position;
          ScanStream.Position := 0;
          if Stream.Position >= Stream.Size then Exit;                 
          ScanSize := ScanStream.CopyFrom(Stream,
            Min(StmSize, (Stream.Size - Stream.Position)));
        end;

        { Init for token search }
        OStr := TStString.CreateZ(StrLCopy(TempBuf, ScanStream.Memory, SizeOf(TempBuf)-1));
        try
          with OStr do begin
            { Check for another boundary in buffer }
            if not BMSearchUC(FBoundary, BoundPos) then
              BoundPos := SizeOf(TempBuf);
            Delimiters := ' :;='#13#10;
            Quote := '"';
            EnableCursor := True;
            RepeatValue := 10;
            BMSearchUC('Content-', FoundPos);
            RepeatValue := 1;
          end;

          for I := 0 to OStr.Items.Count-1 do begin

            OStr.CursorPos := Cardinal(OStr.Items.Objects[I]);

            { These tokens belong to the next section }
            if OStr.CursorPos > BoundPos then Break;

            OStr.GetWordAtCursorZ(AttToken);

            { Process tag appropriately }
            if TTree.SearchUC(AttToken, TTag) then begin
              case TStContentTag(TTag) of
                ctType :
                  begin
                    OStr.CursorNextWord;
                    NewAtt.atContentType := OStr.GetAsciiAtCursor;
                    OStr.CursorNextWord;
                    if CompareText(OStr.GetAsciiAtCursor, 'name') = 0 then begin
                      OStr.Delimiters := ' :;="'#13#10;
                      OStr.CursorNextWord;
                      NewAtt.atFileName := OStr.GetWordAtCursor;
                      OStr.Delimiters := ' :;='#13#10;
                    end;
                  end;
                ctEncoding :
                  begin
                    OStr.CursorNextWord;
                    NewAtt.atEncoding := OStr.GetAsciiAtCursor;
                  end;
                ctDescription :
                  begin
                    OStr.CursorNextWord;
                    NewAtt.atContentDescription := OStr.GetAsciiAtCursor;
                  end;
                ctDisposition :
                  begin
                    OStr.CursorNextWord;
                    NewAtt.atContentDisposition := OStr.GetAsciiAtCursor;
                    OStr.CursorNextWord;
                    if CompareText(OStr.GetAsciiAtCursor, 'filename') = 0 then begin
                      OStr.Delimiters := ' :;="'#13#10;
                      OStr.CursorNextWord;
                      NewAtt.atFileName := OStr.GetWordAtCursor;
                      OStr.Delimiters := ' :;='#13#10;
                    end;
                  end;
              end;
            end;
          end;
          { If it's an 'attachment' -- add it to the list }
          if CompareText(NewAtt.atContentDisposition, 'attachment') = 0 then begin
            if NewAtt.atFilename = '' then
              NewAtt.atFileName := 'attach' + IntToStr(FAttachments.Count) + '.att';
            Attachments.AddObject(NewAtt.atFileName, NewAtt);
            NewAtt := nil;
          end else if CompareText(NewAtt.atContentDisposition, 'inline') = 0 then begin
            if NewAtt.atFilename = '' then
              NewAtt.atFileName := 'attach' + IntToStr(FAttachments.Count) + '.att';
            Attachments.AddObject(NewAtt.atFileName, NewAtt);
            NewAtt := nil;
          end;
        finally
          OStr.Free;
        end;

      end else begin
        if (ScanSize < StmSize) then Exit;
        Stream.Seek(-StrLen(SearchString), soFromCurrent);
        StmOffset := Stream.Position;
        ScanStream.Position := 0;
        ScanSize := ScanStream.CopyFrom(Stream,
          Min(StmSize, (Stream.Size - Stream.Position)));
      end;
    end;
  finally
    ScanStream.Free;
    NewAtt.Free;
    TTree.Free;
    if FAttachments.Count = 0 then FindOldAttachment;
  end;
end;

procedure TStMimeConverter.SetBoundary(Value : string);
begin
  if CompareStr(FBoundary, Value) <> 0 then begin
    FBoundary := Value;
    FBoundaryUsed := False;
    if Length(Value) > 74 then
      SetLength(FBoundary, 74);
  end;
end;

procedure TStMimeConverter.SetConverter(Value : TStConvertStream);
var
  NewConverter : TStConvertStream;
begin
  NewConverter := nil;
  if Value <> nil then begin
    NewConverter := TStConverterClass(Value.ClassType).Create(Self);
    NewConverter.OnProgress := Progress;
  end;
  try
    FConverter.Free;
    FConverter := NewConverter;
  except
    NewConverter.Free;
    raise;
  end;
end;

procedure TStMimeConverter.SetEncoding(Value : string);
var
  I : Integer;
begin
  if FEncoding <> Value then begin
    if Converters.Find(Value, I) then begin
      FEncoding := Value;
      ForceType(TCvtFormat(Converters.Objects[I]).ConverterClass);
    end else
      RaiseStError(EStMimeError, stscBadEncodeFmt);
  end;
end;

procedure TStMimeConverter.SetStream(Value : TStream);
begin
  {if FStream <> Value then begin}                                     
    FStream := Value;
    if FBoundaryUsed then
      Boundary := '';
    ScanAttachments;
  {end;}                                                               
end;

class procedure TStMimeConverter.UnRegisterConverterClass(AClass : TStConverterClass);
begin
  if Assigned(Converters) then Converters.Remove(AClass);
end;

initialization
  InitializeCriticalSection(CvtLock);

finalization
  Converters.Free;
  DeleteCriticalSection(CvtLock);
end.