mimeinln_simail.pas

siMail, siMail, siMail, siMail

{==============================================================================|
| Project : Ararat Synapse                                       | 001.001.002 |
|==============================================================================|
| Content: Inline MIME support procedures and functions                        |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s): Miha Vrhovnik MIME lines are limited to 76 chars             |
|                               so multiple lines are returned if needed.      |
|                               Fixed: InlineEncode, InlineEmailEx             |
|                               Added: InlineEncodeHdr, InlineEmailHdrEx,      |
|                                      InlineEmailHdr, InlineCodeHdr,          |
|                                      InlineCodeHdrEx, InlineEmailsHdr,       |
|                                      InlineEmailsHdrEx                       |
|                                   !!!!!!!!!!                                 |
|                                   HEADER IS NOT PREPENDED                    |
|                                   YOU MUST PREPEND IT YOURSELF!!             |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

//RFC-1522

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}

unit mimeinln_siMail;

interface

uses
  SysUtils, Classes,
  synachar, synacode, synautil;

function InlineDecode(const Value: string; CP: TMimeChar): string;
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
function NeedInline(const Value: string): boolean;
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
function InlineCode(const Value: string): string;
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
function InlineEmail(const Value: string): string;

function InlineEncodeHdr(const Value, Header: string; CP, MimeP: TMimeChar): string;
function InlineCodeHdrEx(const Value, Header: string; FromCP: TMimeChar): string;
function InlineCodeHdr(const Value, Header: string): string;
function InlineEmailHdrEx(const Value, Header: string; FromCP: TMimeChar): string;
function InlineEmailHdr(const Value, Header: string): string;
function InlineEmailsHdrEx(const Value: string;Header:String; FromCP: TMimeChar): string;
function InlineEmailsHdr(const Value, Header: string): string;

implementation

const maxMimeLineLen = 76;

{==============================================================================}

function InlineDecode(const Value: string; CP: TMimeChar): string;
var
  s, su, v: string;
  x, y, z, n: Integer;
  ichar: TMimeChar;
  c: Char;

  function SearchEndInline(const Value: string; be: Integer): Integer;
  var
    n, q: Integer;
  begin
    q := 0;
    Result := 0;
    for n := be + 2 to Length(Value) - 1 do
      if Value[n] = '?' then
      begin
        Inc(q);
        if (q > 2) and (Value[n + 1] = '=') then
        begin
          Result := n;
          Break;
        end;
      end;
  end;

begin
  Result := '';
  v := Value;
  x := Pos('=?', v);
  y := SearchEndInline(v, x);
  //fix for broken coding with begin, but not with end.
  if (x > 0) and (y <= 0) then
    y := Length(Result);
  while (y > x) and (x > 0) do
  begin
    s := Copy(v, 1, x - 1);
    if Trim(s) <> '' then
      Result := Result + s;
    s := Copy(v, x, y - x + 2);
    Delete(v, 1, y + 1);
    su := Copy(s, 3, Length(s) - 4);
    ichar := GetCPFromID(su);
    z := Pos('?', su);
    if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
    begin
      c := UpperCase(su)[z + 1];
      su := Copy(su, z + 3, Length(su) - z - 2);
      if c = 'B' then
      begin
        s := DecodeBase64(su);
        s := CharsetConversion(s, ichar, CP);
      end;
      if c = 'Q' then
      begin
        s := '';
        for n := 1 to Length(su) do
          if su[n] = '_' then
            s := s + ' '
          else
            s := s + su[n];
        s := DecodeQuotedPrintable(s);
        s := CharsetConversion(s, ichar, CP);
      end;
    end;
    Result := Result + s;
    x := Pos('=?', v);
    y := SearchEndInline(v, x);
  end;
  Result := Result + v;
end;

{==============================================================================}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var
  s, s1: string;
  n: Integer;
  ll:Integer;
  sLen:Integer;
begin
  s := CharsetConversion(Value, CP, MimeP);
  s := EncodeSafeQuotedPrintable(s);
  s1 := '';

  //why SPACE is not encoded in EncodeSafeQuotedPrintable ??
  for n := 1 to Length(s) do
    if s[n] = ' ' then
      s1 := s1 + '=20'
    else
      s1 := s1 + s[n];


  //lets build final string
  sLen:=Length(s1);
  s:='';
  n:=1;
  while n <= sLen do begin
      s:=s + ' =?' + GetIdFromCP(MimeP) + '?Q?';

      ll:=maxMimeLineLen;

      ll:=ll - 8 - Length(GetIdFromCP(MimeP)); //-8 is used for ' =?','?Q?','?='

      //we must stop ether if we are at the end of the string or if we reached ll
      while (ll <> 0) and (n <= sLen) do begin
        //line cannot end with uncomplete encode state e.g =,=0,...
        if (s1[n] = '=') and (ll < 3) then
          break;
        s:=s + s1[n];
        Inc(n);
        Dec(ll);
      end;

      if n < sLen then
        s:=s + '?='+#13#10
      else
        s:=s + '?=';
  end;

  Result := s;
end;

{==============================================================================}

function NeedInline(const Value: string): boolean;
var
  n: Integer;
begin
  Result := False;
  for n := 1 to Length(Value) do
    if Value[n] in (SpecialChar + [Char(1)..Char(31), Char(128)..Char(255)]) then
    begin
      Result := True;
      Break;
    end;
end;

{==============================================================================}

function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
var
  c: TMimeChar;
begin
  if NeedInline(Value) then
  begin
    c := IdealCharsetCoding(Value, FromCP,
      [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
      ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
    Result := InlineEncode(Value, FromCP, c);
  end
  else
    Result := Value;
end;

{==============================================================================}

function InlineCode(const Value: string): string;
begin
  Result := InlineCodeEx(Value, GetCurCP);
end;

{==============================================================================}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
var
  sd, se: string;
begin
  sd := GetEmailDesc(Value);
  se := GetEmailAddr(Value);
  if sd = '' then
    Result := se
  else begin
    sd:='"' + InlineCodeEx(sd, FromCP) + '"';
    if (Length(sd) + Length(se)) > maxMimeLineLen then
      Result :=  sd + #13#10 + '<' + se + '>'
    else
      Result :=  sd + '<' + se + '>';
  end;
end;

{==============================================================================}

function InlineEmail(const Value: string): string;
begin
  Result := InlineEmailEx(Value, GetCurCP);
end;

{==============================================================================}
function InlineCodeHdrEx(const Value, Header: string; FromCP: TMimeChar): string;
var
  c: TMimeChar;
begin
  if NeedInline(Value) then begin
    c := IdealCharsetCoding(Value, FromCP,
      [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
      ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
    Result := InlineEncodeHdr(Value, Header, FromCP, c);
  end
  else
    Result := Value;
end;

{==============================================================================}
function InlineCodeHdr(const Value, Header: string): string;
begin
  Result := InlineCodeHdrEx(Value, Header, GetCurCP);
end;

{==============================================================================}
function InlineEncodeHdr(const Value, Header: string; CP, MimeP: TMimeChar): string;
var
  s, s1: string;
  n: Integer;
  firstLine:Boolean;
  ll:Integer;
  sLen:Integer;
begin
  s := CharsetConversion(Value, CP, MimeP);
  s := EncodeSafeQuotedPrintable(s);
  s1 := '';

  //why SPACE is not encoded in EncodeSafeQuotedPrintable ??
//NOW it is!!
(*  for n := 1 to Length(s) do
    if s[n] = ' ' then
      s1 := s1 + '=20'
    else
      s1 := s1 + s[n];
*)

  firstLine:=True;
  //lets build final string
  s1:=s;  
  sLen:=Length(s1);
  s:='';
  n:=1;
  while n <= sLen do begin
      s:=s + ' =?' + GetIdFromCP(MimeP) + '?Q?';

      if firstLine then begin
        ll:=maxMimeLineLen - Length(Header);
        firstLine:=False;
      end
      else ll:=maxMimeLineLen;

      ll:=ll - 8 - Length(GetIdFromCP(MimeP)); //-8 is used for ' =?','?Q?','?='

      //we must stop ether if we are at the end of the string or if we reached ll
      while (ll <> 0) and (n <= sLen) do begin
        //line cannot end with uncomplete encode state e.g =,=0,...
        if (s1[n] = '=') and (ll < 3) then
          break;
        s:=s + s1[n];
        Inc(n);
        Dec(ll);
      end;

      if n < sLen then
        s:=s + '?='+#13#10
      else
        s:=s + '?=';
  end;

  Result := s;
end;

{==============================================================================}
function InlineEmailHdrEx(const Value, Header: string; FromCP: TMimeChar): string;
var
  sd, se: string;
begin
  sd := GetEmailDesc(Value);
  se := GetEmailAddr(Value);
  if sd = '' then
    Result := se
  else begin
    sd:='"' + InlineCodeHdrEx(sd, Header, FromCP) + '"';
    if (Length(sd) + Length(se)) > (maxMimeLineLen - Length(Header)) then
      Result :=  sd + #13#10 + '<' + se + '>'
    else
      Result :=  sd + '<' + se + '>';
  end;
end;

{==============================================================================}
function InlineEmailHdr(const Value, Header: string): string;
begin
  Result := InlineEmailHdrEx(Value, Header, GetCurCP);
end;

{==============================================================================}
//e-mail addresses must be delimeted by ,
//this function returns emails, but everything is very ugly formated
function InlineEmailsHdrEx(const Value: string;Header:String; FromCP: TMimeChar): string;
var sd, se: string;
var strLst:TStringList;
var i:Integer;
var first:Boolean;
begin
    Result:='';
    strLst:=TStringList.Create;

    //break apart
    sd:=Value;
    repeat
        se:=FetchEx(sd, ',', '"');
        if se <> '' then strLst.Add(se);
    until sd='';

    first:=True;
    for i:=0 to strLst.Count - 1 do begin
        sd := GetEmailDesc(strLst.Strings[i]);
        se := GetEmailAddr(strLst.Strings[i]);
        if sd <> '' then begin
            if first then begin
                sd:='"' + InlineCodeHdrEx(sd, Header, FromCP) + '"';
                Header:='';
            end
            else sd:='"' + InlineCodeEx(sd, FromCP) + '"';
        end;

        if not First then Result:=Result + #13#10
        else first:=False;

        if (Length(sd) + Length(se)) > (maxMimeLineLen - Length(Header)) then
              Result:= Result + sd + #13#10 + '<' + se + '>,'
        else Result:=Result + sd + '<' + se + '>,';

    end;
    if Length(Result) > 0 then if Result[Length(Result)] = ',' then SetLength(Result,Length(Result)-1);
    strLst.Free;
end;

{==============================================================================}
function InlineEmailsHdr(const Value, Header: string): string;
begin
  Result := InlineEmailsHdrEx(Value, Header, GetCurCP);
end;

end.