units/synapse/MIMEpart.pas

   1 {==============================================================================|
   2 | Project : Delphree - Synapse                                   | 001.005.002 |
   3 |==============================================================================|
   4 | Content: MIME support procedures and functions                               |
   5 |==============================================================================|
   6 | The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
   7 | (the "License"); you may not use this file except in compliance with the     |
   8 | License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
   9 |                                                                              |
  10 | Software distributed under the License is distributed on an "AS IS" basis,   |
  11 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
  12 | the specific language governing rights and limitations under the License.    |
  13 |==============================================================================|
  14 | The Original Code is Synapse Delphi Library.                                 |
  15 |==============================================================================|
  16 | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  17 | Portions created by Lukas Gebauer are Copyright (c)2000,2001.                |
  18 | All Rights Reserved.                                                         |
  19 |==============================================================================|
  20 | Contributor(s):                                                              |
  21 |==============================================================================|
  22 | History: see HISTORY.HTM from distribution package                           |
  23 |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  24 |==============================================================================}
  25
  26 unit MIMEpart;
  27
  28 interface
  29
  30 uses
  31   KOL,SynaChar, SynaCode, SynaUtil, MIMEinLn;
  32
  33 type
  34
  35   TMimePrimary = (MP_TEXT, MP_MULTIPART,
  36     MP_MESSAGE, MP_BINARY);
  37
  38   TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
  39     ME_BASE64, ME_UU, ME_XX);
  40
  41   PMimePart = ^TMimePart;
  42   TMimePart = object(TObj)
  43   private
  44     FPrimary: string;
  45     FEncoding: string;
  46     FCharset: string;
  47     FPrimaryCode: TMimePrimary;
  48     FEncodingCode: TMimeEncoding;
  49     FCharsetCode: TMimeChar;
  50     FTargetCharset: TMimeChar;
  51     FSecondary: string;
  52     FDescription: string;
  53     FDisposition: string;
  54     FContentID: string;
  55     FBoundary: string;
  56     FFileName: string;
  57     FLines: PStrList;
  58     FDecodedLines: PStream;//TMemoryStream;
  59     procedure SetPrimary(Value: string);
  60     procedure SetEncoding(Value: string);
  61     procedure SetCharset(Value: string);
  62   public
  63     destructor Destroy;virtual;
  64     procedure Clear;
  65     function ExtractPart(Value: PStrList; BeginLine: Integer): Integer;
  66     procedure DecodePart;
  67     procedure EncodePart;
  68     procedure MimeTypeFromExt(Value: string);
  69     property Primary: string read FPrimary write SetPrimary;
  70     property Encoding: string read FEncoding write SetEncoding;
  71     property Charset: string read FCharset write SetCharset;
  72     property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
  73     property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
  74     property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
  75     property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
  76     property Secondary: string read FSecondary Write FSecondary;
  77     property Description: string read FDescription Write FDescription;
  78     property Disposition: string read FDisposition Write FDisposition;
  79     property ContentID: string read FContentID Write FContentID;
  80     property Boundary: string read FBoundary Write FBoundary;
  81     property FileName: string read FFileName Write FFileName;
  82     property Lines: PStrList read FLines;
  83     property DecodedLines: PStream read FDecodedLines;
  84   end;
  85
  86 const
  87   MaxMimeType = 25;
  88   MimeType: array[0..MaxMimeType, 0..2] of string =
  89   (
  90     ('AU', 'audio', 'basic'),
  91     ('AVI', 'video', 'x-msvideo'),
  92     ('BMP', 'image', 'BMP'),
  93     ('DOC', 'application', 'MSWord'),
  94     ('EPS', 'application', 'Postscript'),
  95     ('GIF', 'image', 'GIF'),
  96     ('JPEG', 'image', 'JPEG'),
  97     ('JPG', 'image', 'JPEG'),
  98     ('MID', 'audio', 'midi'),
  99     ('MOV', 'video', 'quicktime'),
 100     ('MPEG', 'video', 'MPEG'),
 101     ('MPG', 'video', 'MPEG'),
 102     ('MP2', 'audio', 'mpeg'),
 103     ('MP3', 'audio', 'mpeg'),
 104     ('PDF', 'application', 'PDF'),
 105     ('PNG', 'image', 'PNG'),
 106     ('PS', 'application', 'Postscript'),
 107     ('QT', 'video', 'quicktime'),
 108     ('RA', 'audio', 'x-realaudio'),
 109     ('RTF', 'application', 'RTF'),
 110     ('SND', 'audio', 'basic'),
 111     ('TIF', 'image', 'TIFF'),
 112     ('TIFF', 'image', 'TIFF'),
 113     ('WAV', 'audio', 'x-wav'),
 114     ('WPD', 'application', 'Wordperfect5.1'),
 115     ('ZIP', 'application', 'ZIP')
 116     );
 117
 118 function NormalizeHeader(Value: PStrList; var Index: Integer): string;
 119 function GenerateBoundary: string;
 120
 121 function NewMimePart : PMimePart;
 122
 123 implementation
 124
 125 function NormalizeHeader(Value: PStrList; var Index: Integer): string;
 126 var
 127   s, t: string;
 128   n: Integer;
 129 begin
 130   s := Value.Items[Index];
 131   Inc(Index);
 132   if s <> '' then
 133     while (Value.Count - 1) > Index do
 134     begin
 135       t := Value.Items[Index];
 136       if t = '' then
 137         Break;
 138       for n := 1 to Length(t) do
 139         if t[n] = #9 then
 140           t[n] := ' ';
 141       if t[1] <> ' ' then
 142         Break
 143       else
 144       begin
 145         s := s + ' ' + Trim(t);
 146         Inc(Index);
 147       end;
 148     end;
 149   Result := s;
 150 end;
 151
 152 {==============================================================================}
 153
 154
 155 function NewMimePart : PMimePart;
 156 begin
 157   New(Result,Create);
 158   Result.FLines := NewStrList;//TStringList.Create;
 159   Result.FDecodedLines := NewMemoryStream;//TMemoryStream.Create;
 160   Result.FTargetCharset := GetCurCP;
 161 end;
 162
 163 destructor TMIMEPart.Destroy;
 164 begin
 165   FDecodedLines.Free;
 166   FLines.Free;
 167   inherited Destroy;
 168 end;
 169
 170 {==============================================================================}
 171
 172 procedure TMIMEPart.Clear;
 173 begin
 174   FPrimary := '';
 175   FEncoding := '';
 176   FCharset := '';
 177   FPrimaryCode := MP_TEXT;
 178   FEncodingCode := ME_7BIT;
 179   FCharsetCode := ISO_8859_1;
 180   FTargetCharset := GetCurCP;
 181   FSecondary := '';
 182   FDisposition := '';
 183   FContentID := '';
 184   FDescription := '';
 185   FBoundary := '';
 186   FFileName := '';
 187   FLines.Clear;
 188 //  FDecodedLines.Clear;
 189   FDecodedLines.Size := 0;
 190 end;
 191
 192 {==============================================================================}
 193
 194 function TMIMEPart.ExtractPart(Value: PStrList; BeginLine: Integer): Integer;
 195 var
 196   n, x, x1, x2: Integer;
 197   t: PStrList;
 198   s, su, b: string;
 199   st, st2: string;
 200   e: Boolean;
 201   fn: string;
 202 begin
 203   t := NewStrList;//TStringlist.Create;
 204   try
 205     { defaults }
 206     FLines.Clear;
 207     Primary := 'text';
 208     FSecondary := 'plain';
 209     FDescription := '';
 210     Charset := 'US-ASCII';
 211     FFileName := '';
 212     Encoding := '7BIT';
 213
 214     fn := '';
 215     x := BeginLine;
 216     b := FBoundary;
 217     { if multipart - skip pre-part }
 218     if b <> '' then
 219       while Value.Count > x do
 220       begin
 221         s := Value.Items[x];
 222         Inc(x);
 223         if Pos('--' + b, s) = 1 then
 224           Break;
 225       end;
 226
 227     { parse header }
 228     while Value.Count > x do
 229     begin
 230       s := NormalizeHeader(Value, x);
 231       if s = '' then
 232         Break;
 233       su := UpperCase(s);
 234       if Pos('CONTENT-TYPE:', su) = 1 then
 235       begin
 236         st := SeparateRight(su, ':');
 237         st2 := SeparateLeft(st, ';');
 238         Primary := SeparateLeft(st2, '/');
 239         FSecondary := SeparateRight(st2, '/');
 240         if (FSecondary = Primary) and (Pos('/', st2) < 1) then
 241           FSecondary := '';
 242         case FPrimaryCode of
 243           MP_TEXT:
 244             begin
 245               Charset := UpperCase(GetParameter(s, 'charset='));
 246               FFileName := GetParameter(s, 'name=');
 247             end;
 248           MP_MULTIPART:
 249             FBoundary := GetParameter(s, 'Boundary=');
 250           MP_MESSAGE:
 251             begin
 252             end;
 253           MP_BINARY:
 254             FFileName := GetParameter(s, 'name=');
 255         end;
 256       end;
 257       if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
 258         Encoding := SeparateRight(su, ':');
 259       if Pos('CONTENT-DESCRIPTION:', su) = 1 then
 260         FDescription := SeparateRight(s, ':');
 261       if Pos('CONTENT-DISPOSITION:', su) = 1 then
 262       begin
 263         FDisposition := SeparateRight(su, ':');
 264         FDisposition := Trim(SeparateLeft(FDisposition, ';'));
 265         fn := GetParameter(s, 'FileName=');
 266       end;
 267       if Pos('CONTENT-ID:', su) = 1 then
 268         FContentID := SeparateRight(s, ':');
 269     end;
 270
 271     if (PrimaryCode = MP_BINARY) and (FFileName = '') then
 272       FFileName := fn;
 273     FFileName := InlineDecode(FFileName, getCurCP);
 274     FFileName := ExtractFileName(FFileName);
 275
 276     { finding part content x1-begin x2-end }
 277     x1 := x;
 278     x2 := Value.Count - 1;
 279     { if multipart - end is before next boundary }
 280     if b <> '' then
 281     begin
 282       for n := x to Value.Count - 1 do
 283       begin
 284         x2 := n;
 285         s := Value.Items[n];
 286         if Pos('--' + b, s) = 1 then
 287         begin
 288           Dec(x2);
 289           Break;
 290         end;
 291       end;
 292     end;
 293     { if content is multipart - content is delimited by their boundaries }
 294     if FPrimaryCode = MP_MULTIPART then
 295     begin
 296       for n := x to Value.Count - 1 do
 297       begin
 298         s := Value.Items[n];
 299         if Pos('--' + FBoundary, s) = 1 then
 300         begin
 301           x1 := n;
 302           Break;
 303         end;
 304       end;
 305       for n := Value.Count - 1 downto x do
 306       begin
 307         s := Value.Items[n];
 308         if Pos('--' + FBoundary, s) = 1 then
 309         begin
 310           x2 := n;
 311           Break;
 312         end;
 313       end;
 314     end;
 315     { copy content }
 316     for n := x1 to x2 do
 317       FLines.Add(Value.Items[n]);
 318     Result := x2;
 319     { if content is multipart - find real end }
 320     if FPrimaryCode = MP_MULTIPART then
 321     begin
 322       e := False;
 323       for n := x2 + 1 to Value.Count - 1 do
 324         if Pos('--' + b, Value.Items[n]) = 1 then
 325         begin
 326           e := True;
 327           Break;
 328         end;
 329       if not e then
 330         Result := Value.Count - 1;
 331     end;
 332     { if multipart - skip ending postpart}
 333     if b <> '' then
 334     begin
 335       x1 := Result;
 336       for n := x1 to Value.Count - 1 do
 337       begin
 338         s := Value.Items[n];
 339         if Pos('--' + b, s) = 1 then
 340         begin
 341           s := TrimRight(s);
 342           x := Length(s);
 343           if x > 4 then
 344             if (s[x] = '-') and (S[x-1] = '-') then
 345               Result := Value.Count - 1;
 346           Break;
 347         end;
 348       end;
 349     end;
 350   finally
 351     t.Free;
 352   end;
 353 end;
 354
 355 {==============================================================================}
 356
 357 procedure TMIMEPart.DecodePart;
 358 const
 359   CRLF = #13#10;
 360 var
 361   n: Integer;
 362   s: string;
 363 begin
 364   FDecodedLines.Size := 0;//  FDecodedLines.Clear;
 365   for n := 0 to FLines.Count - 1 do
 366   begin
 367     s := FLines.Items[n];
 368     case FEncodingCode of
 369       ME_7BIT:
 370         s := s + CRLF;
 371       ME_8BIT:
 372         begin
 373           s := CharsetConversion(s, FCharsetCode, FTargetCharset);
 374           s := s + CRLF;
 375         end;
 376       ME_QUOTED_PRINTABLE:
 377         begin
 378           if s = '' then
 379             s := CRLF
 380           else
 381             if s[Length(s)] <> '=' then
 382               s := s + CRLF;
 383           s := DecodeQuotedPrintable(s);
 384           if FPrimaryCode = MP_TEXT then
 385             s := CharsetConversion(s, FCharsetCode, FTargetCharset);
 386         end;
 387       ME_BASE64:
 388         begin
 389           if s <> '' then
 390             s := DecodeBase64(s);
 391           if FPrimaryCode = MP_TEXT then
 392             s := CharsetConversion(s, FCharsetCode, FTargetCharset);
 393         end;
 394       ME_UU:
 395         if s <> '' then
 396           s := DecodeUU(s);
 397       ME_XX:
 398         if s <> '' then
 399           s := DecodeXX(s);
 400     end;
 401     FDecodedLines.Write(Pointer(s)^, Length(s));
 402   end;
 403   FDecodedLines.Seek(0,spBegin);
 404 end;
 405
 406 {==============================================================================}
 407
 408 procedure TMIMEPart.EncodePart;
 409 var
 410   l: PStrList;
 411   s, buff: string;
 412   n, x: Integer;
 413 begin
 414   if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
 415     Encoding := 'base64';
 416   l := NewStrList;//TStringList.Create;
 417   FLines.Clear;
 418   FDecodedLines.Seek(0, spBegin);
 419   try
 420     case FPrimaryCode of
 421       MP_MULTIPART, MP_MESSAGE:
 422         FLines.LoadFromStream(FDecodedLines,false);
 423       MP_TEXT, MP_BINARY:
 424         if FEncodingCode = ME_BASE64 then
 425         begin
 426           while FDecodedLines.Position < FDecodedLines.Size do
 427           begin
 428             Setlength(Buff, 54);
 429             s := '';
 430             x := FDecodedLines.Read(pointer(Buff)^, 54);
 431             for n := 1 to x do
 432               s := s + Buff[n];
 433             if FPrimaryCode = MP_TEXT then
 434               s := CharsetConversion(s, FTargetCharset, FCharsetCode);
 435             s := EncodeBase64(s);
 436             FLines.Add(s);
 437           end;
 438         end
 439         else
 440         begin
 441           l.LoadFromStream(FDecodedLines,false);
 442           for n := 0 to l.Count - 1 do
 443           begin
 444             s := l.Items[n];
 445             if FPrimaryCode = MP_TEXT then
 446               s := CharsetConversion(s, FTargetCharset, FCharsetCode);
 447             s := EncodeQuotedPrintable(s);
 448             FLines.Add(s);
 449           end;
 450         end;
 451
 452     end;
 453     FLines.Add('');
 454     FLines.Insert(0, '');
 455     if FSecondary = '' then
 456       case FPrimaryCode of
 457         MP_TEXT:
 458           FSecondary := 'plain';
 459         MP_MULTIPART:
 460           FSecondary := 'mixed';
 461         MP_MESSAGE:
 462           FSecondary := 'rfc822';
 463         MP_BINARY:
 464           FSecondary := 'octet-stream';
 465       end;
 466     if FDescription <> '' then
 467       FLines.Insert(0, 'Content-Description: ' + FDescription);
 468     if FDisposition <> '' then
 469     begin
 470       s := '';
 471       if FFileName <> '' then
 472         s := '; FileName="' + FFileName + '"';
 473       FLines.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
 474     end;
 475     if FContentID <> '' then
 476       FLines.Insert(0, 'Content-ID: ' + FContentID);
 477
 478     case FEncodingCode of
 479       ME_7BIT:
 480         s := '7bit';
 481       ME_8BIT:
 482         s := '8bit';
 483       ME_QUOTED_PRINTABLE:
 484         s := 'Quoted-printable';
 485       ME_BASE64:
 486         s := 'Base64';
 487     end;
 488     case FPrimaryCode of
 489       MP_TEXT,
 490         MP_BINARY: FLines.Insert(0, 'Content-Transfer-Encoding: ' + s);
 491     end;
 492     case FPrimaryCode of
 493       MP_TEXT:
 494         s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
 495       MP_MULTIPART:
 496         s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
 497       MP_MESSAGE:
 498         s := FPrimary + '/' + FSecondary + '';
 499       MP_BINARY:
 500         s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"';
 501     end;
 502     FLines.Insert(0, 'Content-type: ' + s);
 503   finally
 504     l.Free;
 505   end;
 506 end;
 507
 508 {==============================================================================}
 509
 510 procedure TMIMEPart.MimeTypeFromExt(Value: string);
 511 var
 512   s: string;
 513   n: Integer;
 514 begin
 515   Primary := '';
 516   FSecondary := '';
 517   s := UpperCase(ExtractFileExt(Value));
 518   if s = '' then
 519     s := UpperCase(Value);
 520   s := SeparateRight(s, '.');
 521   for n := 0 to MaxMimeType do
 522     if MimeType[n, 0] = s then
 523     begin
 524       Primary := MimeType[n, 1];
 525       FSecondary := MimeType[n, 2];
 526       Break;
 527     end;
 528   if Primary = '' then
 529     Primary := 'application';
 530   if FSecondary = '' then
 531     FSecondary := 'octet-string';
 532 end;
 533
 534 {==============================================================================}
 535
 536 procedure TMIMEPart.SetPrimary(Value: string);
 537 var
 538   s: string;
 539 begin
 540   FPrimary := Value;
 541   s := UpperCase(Value);
 542   FPrimaryCode := MP_BINARY;
 543   if Pos('TEXT', s) = 1 then
 544     FPrimaryCode := MP_TEXT;
 545   if Pos('MULTIPART', s) = 1 then
 546     FPrimaryCode := MP_MULTIPART;
 547   if Pos('MESSAGE', s) = 1 then
 548     FPrimaryCode := MP_MESSAGE;
 549 end;
 550
 551 procedure TMIMEPart.SetEncoding(Value: string);
 552 var
 553   s: string;
 554 begin
 555   FEncoding := Value;
 556   s := UpperCase(Value);
 557   FEncodingCode := ME_7BIT;
 558   if Pos('8BIT', s) = 1 then
 559     FEncodingCode := ME_8BIT;
 560   if Pos('QUOTED-PRINTABLE', s) = 1 then
 561     FEncodingCode := ME_QUOTED_PRINTABLE;
 562   if Pos('BASE64', s) = 1 then
 563     FEncodingCode := ME_BASE64;
 564   if Pos('X-UU', s) = 1 then
 565     FEncodingCode := ME_UU;
 566   if Pos('X-XX', s) = 1 then
 567     FEncodingCode := ME_XX;
 568 end;
 569
 570 procedure TMIMEPart.SetCharset(Value: string);
 571 begin
 572   FCharset := Value;
 573   FCharsetCode := GetCPFromID(Value);
 574 end;
 575
 576 {==============================================================================}
 577
 578 function GenerateBoundary: string;
 579 var
 580   x: Integer;
 581 begin
 582   Randomize;
 583   x := Random(MaxInt);
 584   Result := '--' + Int2Hex(x, 8) + '_Synapse_message_boundary--';
 585 end;
 586
 587 end.