Prima Shareware 3/DuCom_Prima-Shareware-3_cd1.bin/PROGRAMO/delphi/TSMTP/MIME.PAS

Pascal/Delphi Source File | 1996-04-26 | 10.5 KB | 473 lines

unit Mime;

interface

uses Classes, Windows, SysUtils, Forms, Dialogs, Registry;

const
  MaxChars = 57;

type
  TBinBytes = array[1..MaxChars] of byte;
  TTxtBytes = array[1..2*MaxChars] of byte;
  T24Bits = array[0..8*MaxChars] of boolean;

EUUInvalidCharacter = class(Exception)
  constructor Create;
end;

 EMIMEError = class(Exception);


  TBase64 = class
  private
    TextStream : TStringList;
    Stream : TStream;
    CurSection : byte;
    A24Bits : T24Bits;
    FOnProgress : TNotifyEvent;
    FOnStart : TNotifyEvent;
    FOnEnd : TNotifyEvent;
    function GenerateTxtBytes(tb : TBinBytes; NumOfBytes : byte) : string;
    procedure GenerateBinBytes(InS : ShortString; BufPtr : pointer;
                               var BytesGenerated : word);
    function ByteFromTable(Ch : Char) : byte;
    procedure DoProgress(Sender : TObject);
    procedure DoStart(Sender : TObject);
    procedure DoEnd(Sender : TObject);
  public
    Progress : Integer;
    ProgressStep : Integer;
    Canceled : boolean;
    Table : string;
    constructor Create(AStream : TStream; ATextStream : TStringList);
    procedure Encode;
    procedure Decode;
    property OnProgress : TNotifyEvent read FOnProgress
                             write FOnProgress;
    property OnStart : TNotifyEvent read FOnStart write FOnStart;
    property OnEnd : TNotifyEvent read FOnEnd write FOnEnd;
  end;

  TQuotedPrintable = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
    Stream : TStream;
    Lines : TStringList;
    procedure ReplaceHiChars(var s : ShortString);
    procedure ReplaceHex(var s : ShortString);
    procedure ReformatParagraph(Buf : PChar; Len : Integer;
               TL : TStringList);
  public
    { Public declarations }
    Canceled : boolean;
    constructor Create(AStream : TStream; ALines : TStringList);
    procedure Encode;
    procedure Decode;
  published
    { Published declarations }
  end;

function GetContentType(const FileName : string) : string;
function MakeUniqueID : string;

implementation

constructor EUUInvalidCharacter.Create;
begin
  inherited Create('Invalid character in the input file');
end;

{implementation for TBase64}
constructor TBase64.Create(AStream : TStream; ATextStream : TStringList);
begin
  inherited Create;
  Stream:=AStream;
  TextStream:=ATextStream;
  ProgressStep:=10;
  Table:='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
  FillChar(A24Bits,SizeOf(A24Bits),0);
end;

procedure TBase64.DoProgress(Sender : TObject);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Sender);
end;

procedure TBase64.DoStart(Sender : TObject);
begin
  if Assigned(FOnStart) then
    FOnStart(Sender);
end;

procedure TBase64.DoEnd(Sender : TObject);
begin
  if Assigned(FOnEnd) then
    FOnEnd(Sender);
end;

function TBase64.GenerateTxtBytes(tb : TBinBytes; NumOfBytes : byte) : string;
var
  i,j,k,b,m : word;
  s : string;
begin
  k:=0;
  FillChar(A24Bits,SizeOf(T24Bits),0);
  for i:=1 to MaxChars do
  begin
    b:=tb[i];
    for j:=7 DownTo 0 do
    begin
      m:=1 shl j;
      if (b and m = m) then
        A24Bits[k]:=true;
      Inc(k);
    end;
  end;
  s:=''; k:=0; m:=4*(MaxChars div 3);
  for i:=1 to m do
  begin
    b:=0;
    for j:=5 DownTo 0 do
    begin
      if A24Bits[k] then b:= b or (1 shl j);
      Inc(k);
    end;
    s:=Concat(s,Table[b+1]);
  end;
  if (NumOfBytes=MaxChars) or (NumOfBytes mod 3=0) then
     SetLength(s,4*NumOfBytes div 3)
  else
  begin
    SetLength(s,4*NumOfBytes div 3+1);
    while (Length(s) mod 4)<>0 do
      s:=Concat(s,'=');
  end;
  Result:=s;
end;

procedure TBase64.Encode;
var
  BytesRead : word;
  ABinBytes : TBinBytes;
  Total : LongInt;
begin
  DoStart(Self);
  TextStream.Clear;
  Progress:=0; Total:=0; Canceled:=false;
  try
    repeat
      FillChar(ABinBytes,SizeOf(TBinBytes),0);
      BytesRead:=Stream.Read(ABinBytes,MaxChars);
      Inc(Total,BytesRead);
      TextStream.Add(GenerateTxtBytes(ABinBytes,BytesRead));
      Progress:=Round(100*Total/Stream.Size);
      if Progress mod ProgressStep = 0 then
         DoProgress(Self);
      Application.ProcessMessages;
    until (BytesRead<MaxChars) or Canceled;
  finally
    Progress:=100;
    DoProgress(Self);
    if Canceled then TextStream.Clear;
    DoEnd(Self);
  end;
end;

function TBase64.ByteFromTable(Ch : Char) : byte;
var
  i : byte;
begin
  i:=1;
  while (Ch<>Table[i]) and (i<=64) do Inc(i);
  if i>64 then
  begin
    Result:=0;
    if Ch<>'=' then
      raise EUUInvalidCharacter.Create;
  end
  else
    Result:=i-1;
end;

procedure TBase64.GenerateBinBytes(InS : ShortString; BufPtr : pointer;
                          var BytesGenerated : word);
var
  i,j,k,b,m : word;
  ActualLen : byte;
begin
  FillChar(BufPtr^,MaxChars,0);
  FillChar(A24Bits,SizeOf(T24Bits),0);
  k:=0;
  for i:=1 to Length(InS) do
  begin
    b:=ByteFromTable(InS[i]);
    for j:=5 DownTo 0 do
    begin
      m:=1 shl j;
      if (b and m = m) then
        A24Bits[k]:=true;
      Inc(k);
    end;
  end;
  k:=0;
  if Length(InS)<>4*MaxChars div 3 then
  begin
    ActualLen:=3*Length(InS) div 4;
    while InS[Length(InS)]='=' do
    begin
      Dec(ActualLen);
      Delete(InS,Length(InS),1);
    end;
  end
  else
    ActualLen:=MaxChars;
  for i:=1 to ActualLen do
  begin
    b:=0;
    for j:=7 DownTo 0 do
    begin
      if A24Bits[k] then b:= b or (1 shl j);
      Inc(k);
    end;
    byte(PChar((PChar(BufPtr)+i-1))^):=b;
  end;
  BytesGenerated:=i-1;
end;

procedure TBase64.Decode;
var
  BytesGenerated : word;
  s : ShortString;
  p : pointer;
  i : LongInt;
begin
  DoStart(Self);
  Progress:=0;
  Canceled:=false;
  i:=0;
  try
    GetMem(p,MaxChars);
    repeat
      FillChar(p^,MaxChars,0);
      s:=TextStream[i];
      GenerateBinBytes(s,p,BytesGenerated);
      Stream.Write(p^,BytesGenerated);
      Progress:=Round(100*i/(TextStream.Count-1));
      if Progress mod ProgressStep = 0 then
         DoProgress(Self);
      Application.ProcessMessages;
      Inc(i);
    until (i>=TextStream.Count);
  finally
    Progress:=100;
    DoProgress(Self);
    FreeMem(p,MaxChars);
    DoEnd(Self);
  end;
end;

{implementation for TQuotedPrintable}

const
  BufSize=$6000;

constructor TQuotedPrintable.Create(AStream : TStream; ALines : TStringList);
begin
  Stream:=AStream;
  Lines:=ALines;
  Canceled:=false;
end;

procedure TQuotedPrintable.ReplaceHiChars(var s : ShortString);
var
  sLen : byte absolute s;
  i : byte;
begin
  i:=1;
  while i<sLen do
  begin
    if Ord(s[i]) in [0..31,61,128..255] then
    begin
      Insert(Concat('=',IntToHex(Ord(s[i]),2)),s,i+1);
      Delete(s,i,1);
      Inc(i,2);
    end;
    Inc(i);
  end;
end;

procedure TQuotedPrintable.ReformatParagraph(Buf : PChar; Len : Integer;
          TL : TStringList);
var
  cp,sp : PChar;
  s : ShortString;
  sLen : byte absolute s;
  Finished : boolean;
begin
  sp:=Buf;
  TL.Clear;
  repeat
    cp:=sp+Len;
    Finished:=cp>StrEnd(Buf);
    if Finished then cp:=StrEnd(Buf)
    else
    begin
      while (cp^<>' ') and (cp>sp) do Dec(cp);
      if cp=sp then
        cp:=sp+Len;
    end;
    sLen:=cp-sp;
    move(sp^,s[1],sLen);
    if not Finished then s:=Concat(s,'=');
    ReplaceHiChars(s);
    TL.Add(s);
    sp:=cp;
  until Finished;
end;

procedure TQuotedPrintable.Encode;
var
  j : Integer;
  Ch : Char;
  Buf : PChar;
  Finished : boolean;
  TempLines : TStringList;
begin
  Buf:=StrAlloc(BufSize);
  TempLines:=TStringList.Create;
  try
    repeat
      {Read a paragraph}
      j:=0;
      FillChar(Buf^,BufSize,0);
      repeat
        if j>=BufSize then
          raise EMIMEError.Create('Paragraph is too large');
        Stream.Read(Ch,1);
        if Stream.Position=Stream.Size then
        begin
          Finished:=true;
          move(Ch,(Buf+j)^,1);
          Inc(j);
        end
        else
        if Ch in [^M,^J] then
        begin
          Finished:=true;
          Stream.Read(Ch,1);
          if not (Ch in [^M,^J])
            then Stream.Position:=Stream.Position-1;
        end
        else
        begin
          Finished:=false;
          move(Ch,(Buf+j)^,1);
          Inc(j);
        end;
        Application.ProcessMessages;
      until Finished;
      ReformatParagraph(Buf,65,TempLines);
      if TempLines.Count=0 then Lines.Add('')
        else Lines.AddStrings(TempLines);
    until (Stream.Position=Stream.Size) or Canceled;
  finally
    TempLines.Free;
    StrDispose(Buf);
  end;
end;

procedure TQuotedPrintable.ReplaceHex(var s : ShortString);
var
  i : byte;
  sLen : byte absolute s;
  Hex : byte;
begin
  i:=1;
  while i<sLen do
  begin
    if (s[i]='=') then
    begin
      try
        Hex:=StrToInt('$'+Copy(s,i+1,2));
        Delete(s,i,3);
        Insert(Char(Hex),s,i);
      except
        on EConvertError do {Do nothing}
          else raise;
      end;
    end;
    Inc(i);
  end;
end;

procedure TQuotedPrintable.Decode;
var
  Buf : PChar;
  i : Integer;
  Finished : boolean;
  s : ShortString;
  sLen : byte absolute s;
begin
  Buf:=StrAlloc(BufSize);
  i:=-1;
  try
    repeat
      FillChar(Buf^,BufSize,0);
      repeat
        Inc(i);
        s:=Lines[i];
        ReplaceHex(s);
        Finished:=(sLen=0) or (s[sLen]<>'=');
        if not Finished then Dec(sLen)
          else s:=Concat(s,^M^J);
        s:=Concat(s,#00);
        if StrLen(Buf)+sLen>=BufSize then
          raise EMIMEError.Create('Paragraph is too large');
        StrCat(Buf,@s[1]);
      until Finished;
      Stream.Write(Buf^,StrLen(Buf));
      Application.ProcessMessages;
    until (i=Lines.Count-1) or Canceled;
  finally
    StrDispose(Buf);
  end;
end;

function GetContentType(const FileName : string) : string;
var
  Key : string;
begin
  Result:='';
  with TRegistry.Create do
  try
    RootKey:=HKEY_CLASSES_ROOT;
    Key:=ExtractFileExt(FileName);
    if KeyExists(Key) then
    begin
      OpenKey(Key,false);
      Result:=ReadString('Content Type');
      CloseKey;
    end;
  finally
    if Result='' then
      Result:='application/octet-stream';
    free;
  end;
end;

function MakeUniqueID : string;
var
  i : Integer;
begin
  Randomize;
  Result:='';
  for i:=1 to 8 do
    Result:=Concat(Result,IntToStr(Random(9)));
end;

end.