mail2000.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

    Inc(Quads, 4);
  end;

  if (Decoded.Size mod 3) = 1 then
  begin

    Decoded.Read(B, 1);

    Stream[Quads+1] := _Code64[(B[0] div 4)+1];
    Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + 1];
    Stream[Quads+3] := '=';
    Stream[Quads+4] := '=';
    Inc(Quads, 4);
  end;

  Stream[0] := Chr(Quads);

  if Quads > 0 then
  begin

    EncLine := Stream+#13#10;
    Encoded.Write(EncLine[1], Length(EncLine));
  end;

  Result := Encoded.Size;
end;

// Search in a StringList

function SearchStringList(Lista: TStringList; Chave: String; Occorrence: Integer = 0): Integer;
var
  nPos: Integer;
  lAchou: Boolean;
  Casas: Integer;
  Temp: String;
  nOccor: Integer;

begin

  Casas := Length(Chave);
  lAchou := False;
  nPos := 0;
  nOccor := 0;

  try

    if Lista <> nil then
    begin

      while (not lAchou) and (nPos < Lista.Count) do
      begin

        Temp := Lista[nPos];

        if UpperCase(Copy(Temp, 1, Casas)) = UpperCase(Chave) then
        begin

          if nOccor = Occorrence then
          begin
          
            lAchou := True;
          end
          else
          begin

            Inc(nOccor);
          end;
        end;

        if not lAchou then
          Inc(nPos);
      end;
    end;

  finally

    if lAchou then
      result := nPos
    else
      result := -1;
  end;
end;

// Search lines into a string

procedure DataLine(var Data, Line: String; var nPos: Integer);
begin

  Line := '';

  while True do
  begin

    Line := Line + Data[nPos];
    Inc(nPos);

    if nPos > Length(Data) then
    begin

      nPos := -1;
      Break;
    end
    else
    begin

      if Length(Line) >= 2 then
      begin

        if (Line[Length(Line)-1] = #13) and (Line[Length(Line)] = #10) then
        begin

          Break;
        end;
      end;
    end;
  end;
end;

// Search lines into a string
// I need to do in this confusing way in order to improve performance

procedure DataLinePChar(const Data: PChar; const TotalLength: Integer; var LinePos, LineLen: Integer; var Line: PChar; var DataEnd: Boolean); assembler;
begin

  if LinePos >= 0 then
  begin

    Data[LinePos+LineLen] := #13;
    LinePos := LinePos+LineLen+2;
    LineLen := 0;
  end
  else
  begin

    LinePos := 0;
    LineLen := 0;
  end;

  while (LinePos+LineLen) < TotalLength do
  begin

    if Data[LinePos+LineLen] = #13 then
    begin

      if (LinePos+LineLen+1) < TotalLength then
      begin

        if Data[LinePos+LineLen+1] = #10 then
        begin

          Data[LinePos+LineLen] := #0;
          Line := @Data[LinePos];
          Exit;
        end;
      end;
    end;

    Inc(LineLen);
  end;

  if LinePos < TotalLength then
    Line := @Data[LinePos]
  else
    DataEnd := True;
end;

// Wrap long lines in a StringList

procedure WrapSL(Source: TStringList; var Dest: String; Margin: Integer);
var
  Buffer: PChar;
  Loop: Integer;
  Line: String;
  Quote: Boolean;

begin

  Buffer := PChar(Source.Text);
  Line := '';
  Dest := '';
  Quote := False;

  for Loop := 0 to StrLen(Buffer)-1 do
  begin

    if Buffer[Loop] = '"' then
      Quote := not Quote;

    Line := Line + Buffer[Loop];

    if (Loop > 0) then
    begin

      if (Buffer[Loop] = #10) and (Buffer[Loop-1] = #13) then
      begin

        Dest := Dest + Line;
        Line := '';
      end;
    end;

    if (Length(Line) >= Margin) and (Buffer[Loop] = #32) and (not Quote) then
    begin

      Dest := Dest + Copy(Line, 1, Length(Line)-1) + #13#10;
      Line := #9;
    end;
  end;
end;

// Determine if string is a numeric IP or not (Thanks to Hou Yg [e-mail])

function IsIPAddress(SS: String): Boolean;
var
  Loop: Integer;
  P: String;

begin

  Result := True;
  P := '';

  for Loop := 1 to Length(SS)+1 do
  begin

    if (Loop > Length(SS)) or (SS[Loop] = '.') then
    begin

      if StrToIntDef(P, -1) < 0 then
      begin

        Result := False;
        Break;
      end;

      P := '';
    end
    else
    begin

      P := P + SS[Loop];
    end;
  end;
end;

// Find and replace substrings

function FindReplace(Source, Old, New: String): String;
var
  Position: Integer;

  function Stuff(Source: String; Position, DelCount: Integer; InsString: String): String;
  begin

    result := Copy(Source, 1, Position-1) + InsString +
              Copy(Source, Position+DelCount, Length(Source));
  end;

begin

  repeat
  begin

    Position := Pos(Old, Source);

    if Position > 0 then
      Source := Stuff(Source, Position, Length(Old), New);
  end
  until Position = 0;

  Result := Source;
end;

// Remove leading and trailing spaces from string
// Thanks to Yunarso Anang ([e-mail])

function TrimSpace(const S: string): string;
var
  I, L: Integer;

begin

  L := Length(S);
  I := 1;

  while (I <= L) and (S[I] = ' ') do
    Inc(I);

  if I > L then Result := '' else
  begin

    while S[L] = ' ' do
      Dec(L);

    Result := Copy(S, I, L - I + 1);
  end;
end;

// Remove left spaces from string
// Thanks to Yunarso Anang ([e-mail])

function TrimLeftSpace(const S: string): string;
var
  I, L: Integer;

begin

  L := Length(S);
  I := 1;

  while (I <= L) and (S[I] = ' ') do
    Inc(I);

  Result := Copy(S, I, Maxint);
end;

// Remove right spaces from string
// Thanks to Yunarso Anang ([e-mail])

function TrimRightSpace(const S: string): string;
var
  I: Integer;

begin

  I := Length(S);

  while (I > 0) and (S[I] = ' ') do
    Dec(I);

  Result := Copy(S, 1, I);
end;

// Convert date from message to Delphi format

function MailDateToDelphiDate(const DateStr: String): TDateTime;
const
  Months: String = 'Jan,Feb,Mar,Apr,May,Jun,Jul,Ago,Sep,Oct,Nov,Dec,';

var
  Field, Loop: Integer;
  Hour, Min, Sec, Year, Month, Day: Word;
  sHour, sMin, sSec, sYear, sMonth, sDay, sTZ: String;
  HTZM, MTZM: Word;
  STZM: Integer;
  TZM: Double;

begin

  sHour := '';
  sMin := '';
  sSec := '';
  sYear := '';
  sMonth := '';
  sDay := '';
  sTZ := '';

  if DateStr <> '' then
  begin

    if DateStr[1] in ['0'..'9'] then
      Field := 1
    else
      Field := 0;

    for Loop := 1 to Length(DateStr) do
    begin

      if DateStr[Loop] in [' ', ':'] then
      begin

        Inc(Field);
      end
      else
      begin

        case Field of

          1: sDay := sDay + DateStr[Loop];
          2: sMonth := sMonth + DateStr[Loop];
          3: sYear := sYear + DateStr[Loop];
          4: sHour := sHour + DateStr[Loop];
          5: sMin := sMin + DateStr[Loop];
          6: sSec := sSec + DateStr[Loop];
          7: sTZ := sTZ + DateStr[Loop];
        end;
      end;
    end;

    Hour := StrToIntDef(sHour, 0);
    Min := StrToIntDef(sMin, 0);
    Sec := StrToIntDef(sSec, 0);
    Year := StrToIntDef(syear, 0);
    Month := (Pos(sMonth, Months)-1) div 4 + 1;
    Day := StrToIntDef(sDay, 0);

    if Year < 100 then
    begin

      if Year < 50 then
        Year := 2000 + Year
      else
        Year := 1900 + Year;
    end;

    if (sTZ = 'GMT') or (Length(Trim(sTZ)) <> 5) then
    begin

      STZM := 1;
      HTZM := 0;
      MTZM := 0;
    end
    else
    begin

      STZM := StrToIntDef(Copy(sTZ, 1, 1)+'1', 1);
      HTZM := StrToIntDef(Copy(sTZ, 2, 2), 0);
      MTZM := StrToIntDef(Copy(sTZ, 4, 2), 0);
    end;

    TZM := EncodeTime(HTZM, MTZM, 0, 0)*STZM;

    Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Min, Sec, 0) + TZM - GetTimeZoneBias;
  end
  else
  begin

    Result := Now;
  end;
end;

// To make sure that a file name (without path!) is valid

function ValidFileName(FileName: String): String;
const
  InvChars: String = ':.\/*?"<>| ';

var
  Loop: Integer;

begin

  FileName := Copy(TrimSpace(FileName), 1, 254);
  Result := '';

  for Loop := 1 to Length(FileName) do
  begin

    if (Ord(FileName[Loop]) < 32) or (Pos(FileName[Loop], InvChars) > 0) then
      Result := Result + '_'
    else
      Result := Result + FileName[Loop];
  end;
end;

{ TMailPart ================================================================== }

// Initialize MailPart

constructor TMailPart.Create(AOwner: TComponent);
begin

  FHeader := TStringList.Create;
  FBody := TMemoryStream.Create;
  FDecoded := TMemoryStream.Create;
  FSubPartList := TMailPartList.Create;
  FOwnerPart := nil;
  FOwnerMessage := nil;
  FAttachedMessage := nil;

  inherited Create(AOwner);
end;

// Finalize MailPart

destructor TMailPart.Destroy;
var
  Loop: Integer;

begin

  for Loop := 0 to FSubPartList.Count-1 do
    FSubPartList.Items[Loop].Destroy;

  FHeader.Free;
  FBody.Free;
  FDecoded.Free;
  FSubPartList.Free;

  if FAttachedMessage <> nil then
    FAttachedMessage.Free;

  inherited Destroy;
end;

// Return the value of a label from the header like "To", "Subject"

function TMailPart.GetLabelValue(cLabel: String): String;
var
  Loop: Integer;

begin

  Result := '';
  Loop := SearchStringList(FHeader, cLabel+':');

  if Loop >= 0 then