aksdb
/
restemplate
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
restemplate/indy/Protocols/IdVCard.pas

1968 lines
64 KiB
Plaintext
Raw Permalink Normal View History

* Replaced fphttpclient with indy10. * Added compression support
2015-10-04 14:14:55 +02:00
{
$Project$
$Workfile$
$Revision$
$DateUTC$
$Id$
This file is part of the Indy (Internet Direct) project, and is offered
under the dual-licensing agreement described on the Indy website.
(http://www.indyproject.org/)
Copyright:
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
}
{
$Log$
}
{
Rev 1.7 2004.10.27 9:17:52 AM czhower
For TIdStrings
Rev 1.6 10/26/2004 10:54:16 PM JPMugaas
Updated refs.
Rev 1.5 2004.02.08 2:43:32 PM czhower
Fixed compile error.
Rev 1.4 2/7/2004 12:47:16 PM JPMugaas
Should work in DotNET and not touch the system settings at all.
Rev 1.3 2004.02.03 5:44:42 PM czhower
Name changes
Rev 1.2 1/21/2004 4:21:10 PM JPMugaas
InitComponent
Rev 1.1 6/13/2003 08:19:52 AM JPMugaas
Should now compile with new codders.
Rev 1.0 11/13/2002 08:04:32 AM JPMugaas
}
unit IdVCard;
{*******************************************************}
{ }
{ Indy VCardObject TIdCard }
{ }
{ Copyright (C) 2000 Winshoes Working Group }
{ Original author J. Peter Mugaas }
{ 2000-May-06 }
{ Based on RFC 2425, 2426 }
{ }
{*******************************************************}
{
2002-Jan-20 DOn Siders
- Corrected spelling errors in Categories properties, members, methods
2000-07-24 Peter Mee
- Added preliminary embedded vCard checking
- Added QP Check & Decode of individual properties
}
interface
{$i IdCompilerDefines.inc}
uses
Classes,
IdGlobal,
IdBaseComponent;
{ TODO:
Agent property does not work and the current parsing stops whenever it
sees END:VCard meaning that the VCard will be truncated if AGENT is
used to embed a VCard.
I omitted a property for spelling out a sound. Appearently VCard 2.1
permitted a charactor representation of sound in addition to an embedded
sound, and a URL.
I am not sure how well the KEY property works. That is used for
embedding some encryption keys into a VCard such as PGP public-key or
something from Versign.
VCard does not have any Quoted Printable decoding or Base64 encoding
and decoding. Some routines may have to be changed to accomodate
this although I don't have the where-with-all.
VCards can not be saved. }
type
{This contains the object for Sound, Logo, Photo, Key, and Agent property}
TIdVCardEmbeddedObject = class(TPersistent)
protected
FObjectType : String;
FObjectURL : String;
FBase64Encoded : Boolean;
FEmbeddedData : TStrings;
{Embeded data property set method}
procedure SetEmbeddedData(const Value: TStrings);
public
constructor Create;
destructor Destroy; override;
published
{this indicates the type of media such as the file type or key type}
property ObjectType : String read FObjectType write FObjectType;
{pointer to the URL where the object is located if it is NOT in this card
itself}
property ObjectURL : String read FObjectURL write FObjectURL;
{The object }
property Base64Encoded : Boolean read FBase64Encoded write FBase64Encoded;
{The data for the object if it is in the VCard. This is usually in an
encoded format such as BASE64 although some keys may not require encoding}
property EmbeddedData : TStrings read FEmbeddedData write SetEmbeddedData;
end;
{VCard business information}
TIdVCardBusinessInfo = class(TPersistent)
protected
FTitle : String;
FRole : String;
FOrganization : String;
FDivisions : TStrings;
procedure SetDivisions(Value : TStrings);
public
constructor Create;
destructor Destroy; override;
published
{The organization name such as XYZ Corp. }
property Organization : String read FOrganization write FOrganization;
{ The divisions in the orginization the person is in - e.g.
West Virginia Office, Computing Service}
property Divisions: TStrings read FDivisions write SetDivisions;
{The person's formal title in the business such
"Director of Computing Services"}
property Title : String read FTitle write FTitle;
{The person's role in an organization such as "system administrator" }
property Role : String read FRole write FRole;
end;
{Geographical information such as Latitude/Longitude and Time Zone}
TIdVCardGeog = class(TPersistent)
protected
FLatitude : Real;
FLongitude : Real;
FTimeZoneStr : String;
published
{Geographical latitude the person is in}
property Latitude : Real read FLatitude write FLatitude;
{Geographical longitude the person is in}
property Longitude : Real read FLongitude write FLongitude;
{The time zone the person is in}
property TimeZoneStr : String read FTimeZoneStr write FTimeZoneStr;
end;
TIdPhoneAttribute = ( tpaHome, tpaVoiceMessaging, tpaWork, tpaPreferred,
tpaVoice, tpaFax, tpaCellular, tpaVideo, tpaBBS, tpaModem, tpaCar,
tpaISDN, tpaPCS, tpaPager );
TIdPhoneAttributes = set of TIdPhoneAttribute;
{ This encapsolates a telephone number }
TIdCardPhoneNumber = class(TCollectionItem)
protected
FPhoneAttributes: TIdPhoneAttributes;
FNumber : String;
public
procedure Assign(Source: TPersistent); override;
published
{This is a descriptor for the phone number }
property PhoneAttributes: TIdPhoneAttributes read FPhoneAttributes write FPhoneAttributes;
{ the telephone number itself}
property Number : String read FNumber write FNumber;
end;
{Since a person can have more than one address, we put them into this collection}
TIdVCardTelephones = class(TOwnedCollection)
protected
function GetItem(Index: Integer) : TIdCardPhoneNumber;
procedure SetItem(Index: Integer; const Value: TIdCardPhoneNumber);
public
constructor Create(AOwner : TPersistent); reintroduce;
function Add: TIdCardPhoneNumber;
property Items[Index: Integer] : TIdCardPhoneNumber read GetItem write SetItem; default;
end;
TIdCardAddressAttribute = ( tatHome, tatDomestic, tatInternational, tatPostal, tatParcel, tatWork, tatPreferred );
TIdCardAddressAttributes = set of TIdCardAddressAttribute;
{This encapsulates a person's address} {Do not Localize}
TIdCardAddressItem = class(TCollectionItem)
protected
FAddressAttributes : TIdCardAddressAttributes;
FPOBox : String;
FExtendedAddress : String;
FStreetAddress : String;
FLocality : String;
FRegion : String;
FPostalCode : String;
FNation : String;
public
procedure Assign(Source: TPersistent); override;
published
{ attributes for this address such as Home or Work, postal, parcel, etc.}
property AddressAttributes : TIdCardAddressAttributes read FAddressAttributes write FAddressAttributes;
{ This is the P. O. Box for an address}
property POBox : String read FPOBox write FPOBox;
{ This could be something such as an Office identifier for a building or
an appartment number }
property ExtendedAddress : String read FExtendedAddress write FExtendedAddress;
{This is the streat address such as "101 Sample Avenue" }
property StreetAddress : String read FStreetAddress write FStreetAddress;
{ This is a city or town (e.g. Chicago, New York City, Montreol }
property Locality : String read FLocality write FLocality;
{ This is the political subdivision of a nation such as a Providence in Canda - Quebec,
a State in US such as "West Virginia", or a county in England such as "Kent"}
property Region : String read FRegion write FRegion;
{ This is the postal code for the locality such as a ZIP Code in the US }
property PostalCode : String read FPostalCode write FPostalCode;
{ This is the nation such as Canada, U.S.A., Mexico, Russia, etc }
property Nation : String read FNation write FNation;
end;
{Since a person can have more than one address, we put them into this collection}
TIdVCardAddresses = class(TOwnedCollection)
protected
function GetItem(Index: Integer) : TIdCardAddressItem;
procedure SetItem(Index: Integer; const Value: TIdCardAddressItem);
public
constructor Create(AOwner : TPersistent); reintroduce;
function Add: TIdCardAddressItem;
property Items[Index: Integer] : TIdCardAddressItem read GetItem write SetItem; default;
end;
{This type holds a mailing label }
TIdVCardMailingLabelItem = class(TCollectionItem)
private
FAddressAttributes : TIdCardAddressAttributes;
FMailingLabel : TStrings;
procedure SetMailingLabel(Value : TStrings);
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
{ attributes for this mailing label such as Home or Work, postal, parcel,
etc.}
property AddressAttributes : TIdCardAddressAttributes read FAddressAttributes write FAddressAttributes;
{ The mailing label itself}
property MailingLabel : TStrings read FMailingLabel write SetMailingLabel;
end;
{This type holds the }
TIdVCardMailingLabels = class(TOwnedCollection)
protected
function GetItem(Index: Integer) : TIdVCardMailingLabelItem;
procedure SetItem(Index: Integer; const Value: TIdVCardMailingLabelItem);
public
constructor Create(AOwner : TPersistent); reintroduce;
function Add : TIdVCardMailingLabelItem;
property Items[Index: Integer] : TIdVCardMailingLabelItem read GetItem write SetItem; default;
end;
{ This type is used to indicate the type E-Mail indicated in the VCard
which can be of several types }
TIdVCardEMailType = (
ematAOL, {America On-Line}
ematAppleLink, {AppleLink}
ematATT, { AT&T Mail }
ematCIS, { CompuServe Information Service }
emateWorld, { eWorld }
ematInternet, {Internet SMTP (default)}
ematIBMMail, { IBM Mail }
ematMCIMail, { Indicates MCI Mail }
ematPowerShare, { PowerShare }
ematProdigy, { Prodigy information service }
ematTelex, { Telex number }
ematX400 { X.400 service }
);
{This object encapsolates an E-Mail address in a Collection}
TIdVCardEMailItem = class(TCollectionItem)
protected
FEMailType : TIdVCardEMailType;
FPreferred : Boolean;
FAddress : String;
public
constructor Create(Collection: TCollection); override;
{ This is the type of E-Mail address which defaults to Internet }
procedure Assign(Source: TPersistent); override;
published
property EMailType : TIdVCardEMailType read FEMailType write FEMailType;
{ Is this the person's prefered E-Mail address? } {Do not Localize}
property Preferred : Boolean read FPreferred write FPreferred;
{ The user's E-Mail address itself } {Do not Localize}
property Address : String read FAddress write FAddress;
end;
TIdVCardEMailAddresses = class(TOwnedCollection)
protected
function GetItem(Index: Integer) : TIdVCardEMailItem;
procedure SetItem(Index: Integer; const Value: TIdVCardEMailItem);
public
constructor Create(AOwner : TPersistent); reintroduce;
function Add: TIdVCardEMailItem;
property Items[Index: Integer] : TIdVCardEMailItem read GetItem write SetItem; default;
end;
TIdVCardName = class(TPersistent)
protected
FFirstName : String;
FSurName : String;
FOtherNames : TStrings;
FPrefix : String;
FSuffix : String;
FFormattedName : String;
FSortName : String;
FNickNames : TStrings;
procedure SetOtherNames(Value : TStrings);
procedure SetNickNames(Value : TStrings);
public
constructor Create;
destructor Destroy; override;
published
{This is the person's first name, in the case of "J. Peter Mugaas",
this would be "J."}
property FirstName : String read FFirstName write FFirstName;
{This is the person's last name, in the case of "J. Peter Mugaas",
this would be "Mugaas"}
property SurName : String read FSurName write FSurName;
{This is a place for a middle name and some other names such as a woman's
maiden name. In the case of "J. Peter Mugaas", this would be "Peter".}
property OtherNames : TStrings read FOtherNames write SetOtherNames;
{This is a properly formatted name which was listed in the VCard}
property FormattedName : String read FFormattedName write FFormattedName;
{This is a prefix added to a name such as
"Mr.", "Dr.", "Hon.", "Prof.", "Reverend", etc.}
property Prefix : String read FPrefix write FPrefix;
{This is a suffix added to a name such as
"Ph.D.", "M.D.", "Esq.", "Jr.", "Sr.", "III", etc.}
property Suffix : String read FSuffix write FSuffix;
{The string used for sorting a name. It may not always be the person's last
name}
property SortName : String read FSortName write FSortName;
{ Nick names which a person may have such as "Bill" or "Billy" for Wiliam.}
property NickNames : TStrings read FNickNames write SetNickNames;
end;
TIdVCard = class(TIdBaseComponent)
protected
FComments : TStrings;
FCategories : TStrings;
FBusinessInfo : TIdVCardBusinessInfo;
FGeography : TIdVCardGeog;
FFullName : TIdVCardName;
FRawForm : TStrings;
FURLs : TStrings;
FEMailProgram : String;
FEMailAddresses : TIdVCardEMailAddresses;
FAddresses : TIdVCardAddresses;
FMailingLabels : TIdVCardMailingLabels;
FTelephones : TIdVCardTelephones;
FVCardVersion : Real;
FProductID : String;
FUniqueID : String;
FClassification : String;
FLastRevised : TDateTime;
FBirthDay : TDateTime;
FPhoto : TIdVCardEmbeddedObject;
FLogo : TIdVCardEmbeddedObject;
FSound : TIdVCardEmbeddedObject;
FKey : TIdVCardEmbeddedObject;
procedure SetComments(Value : TStrings);
procedure SetCategories(Value : TStrings);
procedure SetURLs(Value : TStrings);
{This processes some types of variables after reading the string}
procedure SetVariablesAfterRead;
procedure InitComponent; override;
public
destructor Destroy; override;
{ This reads a VCard from a TStrings object }
procedure ReadFromStrings(s : TStrings);
{ This is the raw form of the VCard }
property RawForm : TStrings read FRawForm;
published
{ This is the VCard specification version used }
property VCardVersion : Real read FVCardVersion;
{ URL's associated with the VCard such as the person's or organication's
webpage. There can be more than one.}
property URLs : TStrings read FURLs write SetURLs;
{ This is the product ID for the program which created this VCard}
property ProductID : String read FProductID write FProductID;
{ This is a unique indentifier for the VCard }
property UniqueID : String read FUniqueID write FUniqueID;
{ Intent of the VCard owner for general access to information described by the vCard
VCard.}
property Classification : String read FClassification write FClassification;
{ This is the person's birthday and possibly, time of birth} {Do not Localize}
property BirthDay : TDateTime read FBirthDay write FBirthDay;
{ This is the person's name } {Do not Localize}
property FullName : TIdVCardName read FFullName write FFullName;
{ This is the E-Mail program used by the card's owner} {Do not Localize}
property EMailProgram : String read FEMailProgram write FEMailProgram;
{ This is a list of the person's E-Mail address } {Do not Localize}
property EMailAddresses : TIdVCardEMailAddresses read FEMailAddresses;
{ This is a list of telephone numbers }
property Telephones : TIdVCardTelephones read FTelephones;
{ This is busines related information on a VCard}
property BusinessInfo : TIdVCardBusinessInfo read FBusinessInfo;
{ This is a list of Categories used for classification }
property Categories : TStrings read FCategories write SetCategories;
{ This is a list of addresses }
property Addresses : TIdVCardAddresses read FAddresses;
{ This is a list of mailing labels }
property MailingLabels : TIdVCardMailingLabels read FMailingLabels;
{ This is a miscellaneous comments, additional information, or whatever the
VCard wishes to say }
property Comments : TStrings read FComments write SetComments;
{ The owner's photograph} {Do not Localize}
property Photo : TIdVCardEmbeddedObject read FPhoto;
{ Organization's logo} {Do not Localize}
property Logo : TIdVCardEmbeddedObject read FLogo;
{ A sound associated with the VCard such as how to pronounce a person's name
or something cute }
property Sound : TIdVCardEmbeddedObject read FSound;
{ This is for an encryption key such as S/MIME, VeriSign, or PGP }
property Key : TIdVCardEmbeddedObject read FKey;
end;
//public for testing
type
TIdISO8601DateComps = record
Year, Month, Day: UInt16;
end;
TIdISO8601TimeComps = record
Hour, Min, Sec, MSec: UInt16;
UTCOffset: String;
end;
function ParseISO8601Date(const DateString: string; var VDate: TIdISO8601DateComps): Boolean;
function ParseISO8601Time(const DateString: string; var VTime: TIdISO8601TimeComps): Boolean;
function ParseISO8601DateTime(const DateString: string; var VDate: TIdISO8601DateComps; var VTime: TIdISO8601TimeComps): Boolean;
function ParseISO8601DateAndOrTime(const DateString: string; var VDate: TIdISO8601DateComps; var VTime: TIdISO8601TimeComps): Boolean;
function ParseISO8601DateTimeStamp(const DateString: string; var VDate: TIdISO8601DateComps; var VTime: TIdISO8601TimeComps): Boolean;
function ParseDateTimeStamp(const DateString: string): TDateTime; {$IFDEF HAS_DEPRECATED}deprecated{$IFDEF HAS_DEPRECATED_MSG} 'Use ParseISO8601DateTimeStamp()'{$ENDIF};{$ENDIF}
implementation
uses
IdCoderQuotedPrintable,
IdException,
IdGlobalProtocols, SysUtils;
const VCardProperties : array [0..27] of string = (
'FN', 'N', 'NICKNAME', 'PHOTO', {Do not Localize}
'BDAY', 'ADR', 'LABEL', 'TEL', {Do not Localize}
'EMAIL', 'MAILER', 'TZ', 'GEO', {Do not Localize}
'TITLE', 'ROLE', 'LOGO', 'AGENT', {Do not Localize}
'ORG', 'CATEGORIES', 'NOTE', 'PRODID', {Do not Localize}
'REV', 'SORT-STRING', 'SOUND', 'URL', {Do not Localize}
'UID', 'VERSION', 'CLASS', 'KEY' {Do not Localize}
);
{ These constants are for testing the VCard for E-Mail types.
Don't alter these } {Do not Localize}
const EMailTypePropertyParameter : array [0..11] of string = (
'AOL', {America On-Line} {Do not Localize}
'APPLELINK', {AppleLink} {Do not Localize}
'ATTMAIL', { AT&T Mail } {Do not Localize}
'CIS', { CompuServe Information Service } {Do not Localize}
'EWORLD', { eWorld } {Do not Localize}
'INTERNET', {Internet SMTP (default) } {Do not Localize}
'IBMMAIL', { IBM Mail } {Do not Localize}
'MCIMAIL', { MCI Mail } {Do not Localize}
'POWERSHARE', { PowerShare } {Do not Localize}
'PRODIGY', { Prodigy information service } {Do not Localize}
'TLX', { Telex number } {Do not Localize}
'X400' { X.400 service } {Do not Localize}
);
//This is designed for decimals as written in the English language.
//We require this because some protocols may require this as standard representation
//for floats
function IndyStrToFloat(const AStr: string): Extended;
var
LBuf : String;
LHi, LLo : UInt32;
i : Integer;
begin
LBuf := AStr;
//strip off
for i := Length(LBuf) downto 1 do begin
if LBuf[i] = ',' then begin
IdDelete(LBuf, i, 1);
end;
end;
LHi := IndyStrToInt(Fetch(LBuf,'.'), 0);
LBuf := PadString(LBuf, 2, '0');
LLo := IndyStrToInt(Copy(LBuf,1,2), 0);
Result := LHi + (LLo / 100);
end;
{This only adds Value to strs if it is not zero}
procedure AddValueToStrings(strs : TStrings; Value : String);
begin
if Length(Value) > 0 then begin
strs.Add(Value);
end; // if Legnth ( Value ) then
end;
{This parses a delinated string into a TStrings}
procedure ParseDelimiterToStrings(strs : TStrings; str : String; const Delimiter : Char = ','); {Do not Localize}
begin
while str <> '' do begin {Do not Localize}
AddValueToStrings(strs, Fetch(str, Delimiter));
end;
end;
{This parses time stamp from DateString and returns it as TDateTime
Per RFC 2425 Section 5.8.4:
date = date-fullyear ["-"] date-month ["-"] date-mday
date-fullyear = 4 DIGIT
date-month = 2 DIGIT ;01-12
date-mday = 2 DIGIT ;01-28, 01-29, 01-30, 01-31
;based on month/year
time = time-hour [":"] time-minute [":"] time-second [time-secfrac] [time-zone]
time-hour = 2 DIGIT ;00-23
time-minute = 2 DIGIT ;00-59
time-second = 2 DIGIT ;00-60 (leap second)
time-secfrac = "," 1*DIGIT
time-zone = "Z" / time-numzone
time-numzome = sign time-hour [":"] time-minute
"date", "time", and "date-time": Each of these value types is based
on a subset of the definitions in ISO 8601 standard. Profiles MAY
place further restrictions on "date" and "time" values. Multiple
"date" and "time" values can be specified using the comma-separated
notation, unless restricted by a profile.
Examples for "date":
1985-04-12
1996-08-05,1996-11-11
19850412
Examples for "time":
10:22:00
102200
10:22:00.33
10:22:00.33Z
10:22:33,11:22:00
10:22:00-08:00
Examples for "date-time":
1996-10-22T14:00:00Z
1996-08-11T12:34:56Z
19960811T123456Z
1996-10-22T14:00:00Z,1996-08-11T12:34:56Z
Per RFC 2426 Section 4:
date-value = <A single date value as defined in [MIME-DIR]>
time-value = <A single time value as defined in [MIME-DIR]>
date-time-value = <A single date-time value as defined in [MIME-DIR]
[MIME-DIR] Howes, T., Smith, M., and F. Dawson, "A MIME Content-
Type for Directory Information", RFC 2425, September
1998.
Per RFC 6350 Section 4.3:
"date", "time", "date-time", "date-and-or-time", and "timestamp":
Each of these value types is based on the definitions in
[ISO.8601.2004]. Multiple such values can be specified using the
comma-separated notation.
Only the basic format is supported.
4.3.1. DATE
A calendar date as specified in [ISO.8601.2004], Section 4.1.2.
Reduced accuracy, as specified in [ISO.8601.2004], Sections 4.1.2.3
a) and b), but not c), is permitted.
Expanded representation, as specified in [ISO.8601.2004], Section
4.1.4, is forbidden.
Truncated representation, as specified in [ISO.8601.2000], Sections
5.2.1.3 d), e), and f), is permitted.
Examples for "date":
19850412
1985-04
1985
--0412
---12
Note the use of YYYY-MM in the second example above. YYYYMM is
disallowed to prevent confusion with YYMMDD. Note also that
YYYY-MM-DD is disallowed since we are using the basic format instead
of the extended format.
4.3.2. TIME
A time of day as specified in [ISO.8601.2004], Section 4.2.
Reduced accuracy, as specified in [ISO.8601.2004], Section 4.2.2.3,
is permitted.
Representation with decimal fraction, as specified in
[ISO.8601.2004], Section 4.2.2.4, is forbidden.
The midnight hour is always represented by 00, never 24 (see
[ISO.8601.2004], Section 4.2.3).
Truncated representation, as specified in [ISO.8601.2000], Sections
5.3.1.4 a), b), and c), is permitted.
Examples for "time":
102200
1022
10
-2200
--00
102200Z
102200-0800
4.3.3. DATE-TIME
A date and time of day combination as specified in [ISO.8601.2004],
Section 4.3.
Truncation of the date part, as specified in [ISO.8601.2000], Section
5.4.2 c), is permitted.
Examples for "date-time":
19961022T140000
--1022T1400
---22T14
4.3.4. DATE-AND-OR-TIME
Either a DATE-TIME, a DATE, or a TIME value. To allow unambiguous
interpretation, a stand-alone TIME value is always preceded by a "T".
Examples for "date-and-or-time":
19961022T140000
--1022T1400
---22T14
19850412
1985-04
1985
--0412
---12
T102200
T1022
T10
T-2200
T--00
T102200Z
T102200-0800
4.3.5. TIMESTAMP
A complete date and time of day combination as specified in
[ISO.8601.2004], Section 4.3.2.
Examples for "timestamp":
19961022T140000
19961022T140000Z
19961022T140000-05
19961022T140000-0500
}
function ParseISO8601Date(const DateString: string; var VDate: TIdISO8601DateComps): Boolean;
var
Year, Month, Day: UInt16;
Len: Integer;
begin
// TODO: move this logic into IdGlobalProtocols.RawStrInternetToDateTime().ParseISO8601()
Result := False;
VDate.Year := 0;
VDate.Month := 0;
VDate.Day := 0;
Len := Length(DateString);
if (Len >= 10) and
IsNumeric(DateString, 4, 1) and CharEquals(DateString, 5, '-') and
IsNumeric(DateString, 2, 6) and CharEquals(DateString, 8, '-') and
IsNumeric(DateString, 2, 9) then
begin
Year := IndyStrToInt(Copy(DateString, 1, 4));
Month := IndyStrToInt(Copy(DateString, 6, 2));
Day := IndyStrToInt(Copy(DateString, 9, 2));
Dec(Len, 10);
end
else if (Len >= 8) and IsNumeric(DateString, 8, 1) then
begin
Year := IndyStrToInt(Copy(DateString, 1, 4));
Month := IndyStrToInt(Copy(DateString, 5, 2));
Day := IndyStrToInt(Copy(DateString, 7, 2));
Dec(Len, 8);
end else
begin
Day := 1;
if (Len >= 7) and
IsNumeric(DateString, 4, 1) and CharEquals(DateString, 5, '-') and
IsNumeric(DateString, 2, 6) then
begin
Year := IndyStrToInt(Copy(DateString, 1, 4));
Month := IndyStrToInt(Copy(DateString, 6, 2));
Dec(Len, 7);
end
else if (Len >= 4) and IsNumeric(DateString, 4, 1) then
begin
Month := 1;
Year := IndyStrToInt(Copy(DateString, 1, 4));
Dec(Len, 4);
end
else if (Len >= 4) and CharEquals(DateString, 1, '-') and CharEquals(DateString, 2, '-') then
begin
Year := 0;
if (Len >= 7) and IsNumeric(DateString, 2, 3) and CharEquals(DateString, 5, '-') and
IsNumeric(DateString, 2, 6) then
begin
Month := IndyStrToInt(Copy(DateString, 3, 2));
Day := IndyStrToInt(Copy(DateString, 6, 2));
Dec(Len, 7);
end
else if (Len >= 6) and IsNumeric(DateString, 4, 3) then
begin
Month := IndyStrToInt(Copy(DateString, 3, 2));
Day := IndyStrToInt(Copy(DateString, 5, 2));
Dec(Len, 6)
end
else if (Len >= 5) and CharEquals(DateString, 3, '-') and IsNumeric(DateString, 2, 4) then
begin
Month := 1;
Day := IndyStrToInt(Copy(DateString, 4, 2));
Dec(Len, 5);
end
else if (Len >= 4) and IsNumeric(DateString, 2, 3) then
begin
Month := IndyStrToInt(Copy(DateString, 3, 2));
Day := 1;
Dec(Len, 4);
end else begin
Exit;
end;
end else begin
Exit;
end;
end;
if Len > 0 then begin
Exit;
end;
VDate.Year := Year;
VDate.Month := Month;
VDate.Day := Day;
Result := True;
end;
function ParseISO8601Time(const DateString: string; var VTime: TIdISO8601TimeComps): Boolean;
type
eFracComp = (fracMin, fracSec, fracMSec);
var
Hour, Min, Sec, MSec: UInt16;
Len, Offset, TmpOffset, TmpLen, I, Numerator, Denominator: Integer;
LMultiplier: Single;
FracComp: eFracComp;
begin
// TODO: move this logic into IdGlobalProtocols.RawStrInternetToDateTime().ParseISO8601()
Result := False;
VTime.Hour := 0;
VTime.Min := 0;
VTime.Sec := 0;
VTime.MSec := 0;
VTime.UTCOffset := '';
Len := Length(DateString);
MSec := 0;
if (Len >= 8) and
IsNumeric(DateString, 2, 1) and CharEquals(DateString, 3, ':') and
IsNumeric(DateString, 2, 4) and CharEquals(DateString, 6, ':') and
IsNumeric(DateString, 2, 7) then
begin
Hour := IndyStrToInt(Copy(DateString, 1, 2));
Min := IndyStrToInt(Copy(DateString, 4, 2));
Sec := IndyStrToInt(Copy(DateString, 7, 2));
Offset := 9;
Dec(Len, 8);
FracComp := fracMSec;
end
else if (Len >= 6) and IsNumeric(DateString, 6, 1) then
begin
Hour := IndyStrToInt(Copy(DateString, 1, 2));
Min := IndyStrToInt(Copy(DateString, 3, 2));
Sec := IndyStrToInt(Copy(DateString, 5, 2));
Offset := 7;
Dec(Len, 6);
FracComp := fracMSec;
end
else begin
Sec := 0;
if (Len >= 5) and
IsNumeric(DateString, 2, 1) and CharEquals(DateString, 3, ':') and
IsNumeric(DateString, 2, 4) then
begin
Hour := IndyStrToInt(Copy(DateString, 1, 2));
Min := IndyStrToInt(Copy(DateString, 4, 2));
Offset := 6;
Dec(Len, 5);
FracComp := fracSec;
end
else if (Len >= 4) and IsNumeric(DateString, 4, 1) then
begin
Hour := IndyStrToInt(Copy(DateString, 1, 2));
Min := IndyStrToInt(Copy(DateString, 3, 2));
Offset := 5;
Dec(Len, 4);
FracComp := fracSec;
end else
begin
if (Len >= 2) and IsNumeric(DateString, 2, 1) then begin
Min := 0;
Hour := IndyStrToInt(Copy(DateString, 1, 2));
Offset := 3;
Dec(Len, 2);
FracComp := fracMin;
end
else if (Len >= 3) and CharEquals(DateString, 1, '-') then
begin
Hour := 0;
if (Len >= 6) and IsNumeric(DateString, 2, 2) and CharEquals(DateString, 4, ':') and
IsNumeric(DateString, 2, 5) then
begin
Min := IndyStrToInt(Copy(DateString, 2, 2));
Sec := IndyStrToInt(Copy(DateString, 5, 2));
Offset := 7;
Dec(Len, 6);
FracComp := fracMSec;
end
else if (Len >= 5) and IsNumeric(DateString, 4, 2) then
begin
Min := IndyStrToInt(Copy(DateString, 2, 2));
Sec := IndyStrToInt(Copy(DateString, 4, 2));
Offset := 6;
Dec(Len, 5);
FracComp := fracMSec;
end
else if (Len >= 4) and CharEquals(DateString, 2, '-') and IsNumeric(DateString, 2, 3) then
begin
Min := 0;
Sec := IndyStrToInt(Copy(DateString, 3, 2));
Offset := 5;
Dec(Len, 4);
FracComp := fracMSec;
end
else if (Len >= 3) and IsNumeric(DateString, 2, 2) then
begin
Min := IndyStrToInt(Copy(DateString, 3, 2));
Sec := 0;
Offset := 4;
Dec(Len, 3);
FracComp := fracSec;
end else begin
Exit;
end;
end else begin
Exit;
end;
end;
end;
if (Len > 0) and CharIsInSet(DateString, Offset, '.,') then
begin
Inc(Offset);
Dec(Len);
Numerator := 0;
Denominator := 1;
for I := 0 to 8 do
begin
if Len = 0 then begin
Break;
end;
if not IsNumeric(DateString[Offset]) then begin
Break;
end;
Numerator := (Numerator * 10) + (Ord(DateString[Offset]) - Ord('0'));
if Numerator < 0 then begin // overflow
Exit;
end;
Denominator := Denominator * 10;
Inc(Offset);
Dec(Len);
end;
LMultiplier := Numerator / Denominator;
case FracComp of
fracMin: begin
Min := UInt16(Trunc(60 * LMultiplier));
end;
fracSec: begin
Sec := UInt16(Trunc(60 * LMultiplier));
end;
fracMSec: begin
MSec := UInt16(Trunc(1000 * LMultiplier));
end;
end;
end;
if Len > 0 then
begin
TmpOffset := Offset;
TmpLen := Len;
if not CharIsInSet(DateString, Offset, '+-') then
begin
// TODO: parse time zones other than "Z" into offsets
if CharEquals(DateString, Offset, 'Z') then begin
Dec(Len);
end;
end else
begin
Inc(Offset);
Dec(Len);
if (Len >= 5) and
IsNumeric(DateString, 2, Offset) and CharEquals(DateString, Offset+2, ':') and
IsNumeric(DateString, 2, Offset+3) then
begin
Dec(Len, 5);
end
else if (Len >= 4) and IsNumeric(DateString, 4, Offset) then
begin
Dec(Len, 4);
end
else if (Len >= 2) and IsNumeric(DateString, 2, Offset) then
begin
Dec(Len, 2);
end
else begin
Exit;
end;
end;
if Len > 0 then begin
Exit;
end;
Offset := TmpOffset;
Len := TmpLen;
end;
VTime.Hour := Hour;
VTime.Min := Min;
VTime.Sec := Sec;
VTime.MSec := MSec;
VTime.UTCOffset := Copy(DateString, Offset, Len);
Result := True;
end;
function ParseISO8601DateTime(const DateString: string; var VDate: TIdISO8601DateComps; var VTime: TIdISO8601TimeComps): Boolean;
var
I: Integer;
begin
// TODO: move this logic into IdGlobalProtocols.RawStrInternetToDateTime().ParseISO8601()
Result := False;
VDate.Year := 0;
VDate.Month := 0;
VDate.Day := 0;
VTime.Hour := 0;
VTime.Min := 0;
VTime.Sec := 0;
VTime.MSec := 0;
VTime.UTCOffset := '';
I := Pos('T', DateString);
if I <> 0 then begin
Result := ParseISO8601Date(Copy(DateString, 1, I-1), VDate) and
ParseISO8601Time(Copy(DateString, I+1, MaxInt), VTime);
end;
end;
function ParseISO8601DateAndOrTime(const DateString: string; var VDate: TIdISO8601DateComps; var VTime: TIdISO8601TimeComps): Boolean;
var
I: Integer;
begin
// TODO: move this logic into IdGlobalProtocols.RawStrInternetToDateTime().ParseISO8601()
Result := False;
VDate.Year := 0;
VDate.Month := 0;
VDate.Day := 0;
VTime.Hour := 0;
VTime.Min := 0;
VTime.Sec := 0;
VTime.MSec := 0;
VTime.UTCOffset := '';
I := Pos('T', DateString);
if I = 0 then begin
Result := ParseISO8601Date(DateString, VDate);
Exit;
end;
if I > 1 then begin
if not ParseISO8601Date(Copy(DateString, 1, I-1), VDate) then begin
Exit;
end;
end;
if not ParseISO8601Time(Copy(DateString, I+1, MaxInt), VTime) then begin
Exit;
end;
Result := True;
end;
function ParseISO8601DateTimeStamp(const DateString: String; var VDate: TIdISO8601DateComps; var VTime: TIdISO8601TimeComps): Boolean;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
// TODO: how is TIMESTAMP different from DATE-TIME?
Result := ParseISO8601DateTime(DateString, VDate, VTime);
end;
function ParseDateTimeStamp(const DateString: string): TDateTime;
var
LDate: TIdISO8601DateComps;
LTime: TIdISO8601TimeComps;
begin
if ParseISO8601DateTimeStamp(DateString, LDate, LTime) then begin
Result := EncodeDate(LDate.Year, LDate.Month, LDate.Day) + EncodeTime(LTime.Hour, LTime.Min, LTime.Sec, LTime.MSec);
end else begin
Result := 0.0;
end;
end;
{This function returns a stringList with an item's
attributes and sets value to the value of the item}
function GetAttributesAndValue(Data : String; var Value : String) : TStringList;
var
Buff, Buff2 : String;
begin
Result := TStringList.Create;
try
if IndyPos(':', Data) <> 0 then {Do not Localize}
begin
Buff := Fetch(Data, ':'); {Do not Localize}
{This handles a VCard property attribute delimiter ","}
Buff := ReplaceAll(Buff, ',', ';'); {Do not Localize}
while Buff <> '' do begin {Do not Localize}
Buff2 := Fetch(Buff, ';'); {Do not Localize}
if Length(Buff2) > 0 then begin
Result.Add(Buff2);
end;
end;
end;
Value := Data;
except
FreeAndNil(Result);
raise;
end;
end;
{This parses the organization line from OrgString into}
procedure ParseOrg(OrgObj : TIdVCardBusinessInfo; OrgStr : String);
begin
{ Organization name }
OrgObj.Organization := Fetch(OrgStr, ';');
{ Divisions }
ParseDelimiterToStrings(OrgObj.Divisions, OrgStr, ';'); {Do not Localize}
end;
{This parses the geography latitude and longitude from GeogStr and
puts it in Geog}
procedure ParseGeography(Geog : TIdVCardGeog; GeogStr : String);
begin
{Latitude}
Geog.Latitude := IndyStrToFloat(Fetch(GeogStr, ';')); {Do not Localize}
{Longitude}
Geog.Longitude := IndyStrToFloat(Fetch(GeogStr, ';')); {Do not Localize}
end;
{This parses PhoneStr and places the attributes in PhoneObj }
procedure ParseTelephone(PhoneObj : TIdCardPhoneNumber; PhoneStr : String);
const
TelephoneTypePropertyParameter : array [0..13] of string = (
'HOME', 'MSG', 'WORK', 'PREF', 'VOICE', 'FAX', {Do not Localize}
'CELL', 'VIDEO', 'BBS', 'MODEM', 'CAR', 'ISDN', {Do not Localize}
'PCS', 'PAGER' {Do not Localize}
);
var
Value : String;
idx : Integer;
Attribs : TStringList;
begin
attribs := GetAttributesAndValue(PhoneStr, Value);
try
for idx := 0 to Attribs.Count-1 do begin
case PosInStrArray(attribs[idx], TelephoneTypePropertyParameter, False) of
{ home }
0 : Include(PhoneObj.FPhoneAttributes, tpaHome);
{ voice messaging }
1 : Include(PhoneObj.FPhoneAttributes, tpaVoiceMessaging);
{ work }
2 : Include(PhoneObj.FPhoneAttributes, tpaWork);
{ preferred }
3 : Include(PhoneObj.FPhoneAttributes, tpaPreferred);
{ Voice }
4 : Include(PhoneObj.FPhoneAttributes, tpaVoice);
{ Fax }
5 : Include(PhoneObj.FPhoneAttributes, tpaFax);
{ Cellular phone }
6 : Include(PhoneObj.FPhoneAttributes, tpaCellular);
{ Video conferancing number }
7 : Include(PhoneObj.FPhoneAttributes, tpaVideo);
{ Bulleton Board System (BBS) telephone number }
8 : Include(PhoneObj.FPhoneAttributes, tpaBBS);
{ MODEM Connection number }
9 : Include(PhoneObj.FPhoneAttributes, tpaModem);
{ Car phone number }
10 : Include(PhoneObj.FPhoneAttributes, tpaCar);
{ ISDN Service Number }
11 : Include(PhoneObj.FPhoneAttributes, tpaISDN);
{ personal communication services telephone number }
12 : Include(PhoneObj.FPhoneAttributes, tpaPCS);
{ pager }
13 : Include(PhoneObj.FPhoneAttributes, tpaPager);
end;
end;
{ default telephon number }
if Attribs.Count = 0 then begin
PhoneObj.PhoneAttributes := [tpaVoice];
end;
PhoneObj.Number := Value;
finally
FreeAndNil(attribs);
end;
end;
{This parses AddressStr and places the attributes in AddressObj }
procedure ParseAddress(AddressObj : TIdCardAddressItem; AddressStr : String);
const
AttribsArray : array[0..6] of String = (
'HOME', 'DOM', 'INTL', 'POSTAL', 'PARCEL', 'WORK', 'PREF' {Do not Localize}
);
var
Value : String;
Attribs : TStringList;
idx : Integer;
begin
Attribs := GetAttributesAndValue(AddressStr, Value);
try
for idx := 0 to Attribs.Count-1 do begin
case PosInStrArray(attribs[idx], AttribsArray, False) of
{ home }
0 : Include(AddressObj.FAddressAttributes, tatHome);
{ domestic }
1 : Include(AddressObj.FAddressAttributes, tatDomestic);
{ international }
2 : Include(AddressObj.FAddressAttributes, tatInternational);
{ Postal }
3 : Include(AddressObj.FAddressAttributes, tatPostal);
{ Parcel }
4 : Include(AddressObj.FAddressAttributes, tatParcel);
{ Work }
5 : Include(AddressObj.FAddressAttributes, tatWork);
{ Preferred }
6 : Include(AddressObj.FAddressAttributes, tatPreferred);
end;
end;
if Attribs.Count = 0 then begin
AddressObj.AddressAttributes := [tatInternational, tatPostal, tatParcel, tatWork];
end;
AddressObj.POBox := Fetch(Value, ';'); {Do not Localize}
AddressObj.ExtendedAddress := Fetch(Value, ';'); {Do not Localize}
AddressObj.StreetAddress := Fetch(Value, ';'); {Do not Localize}
AddressObj.Locality := Fetch(Value, ';'); {Do not Localize}
AddressObj.Region := Fetch (Value, ';'); {Do not Localize}
AddressObj.PostalCode := Fetch(Value, ';'); {Do not Localize}
AddressObj.Nation := Fetch (Value, ';'); {Do not Localize}
finally
FreeAndNil(Attribs);
end;
end;
{This parses LabelStr and places the attributes in TIdVCardMailingLabelItem }
procedure ParseMailingLabel(LabelObj : TIdVCardMailingLabelItem; LabelStr : String);
const
AttribsArray : array[0..6] of String = (
'HOME', 'DOM', 'INTL', 'POSTAL', 'PARCEL', 'WORK', 'PREF' {Do not Localize}
);
var
Value : String;
Attribs : TStringList;
idx : Integer;
begin
Attribs := GetAttributesAndValue(LabelStr, Value);
try
for idx := 0 to Attribs.Count-1 do begin
case PosInStrArray(attribs[idx], AttribsArray, False) of
{ home }
0 : Include(LabelObj.FAddressAttributes, tatHome);
{ domestic }
1 : Include(LabelObj.FAddressAttributes, tatDomestic);
{ international }
2 : Include(LabelObj.FAddressAttributes, tatInternational);
{ Postal }
3 : Include(LabelObj.FAddressAttributes, tatPostal);
{ Parcel }
4 : Include(LabelObj.FAddressAttributes, tatParcel);
{ Work }
5 : Include(LabelObj.FAddressAttributes, tatWork);
{ Preferred }
6 : Include(LabelObj.FAddressAttributes, tatPreferred);
end;
end;
{Default Values}
if Attribs.Count = 0 then begin
LabelObj.AddressAttributes := [tatInternational, tatPostal, tatParcel, tatWork];
end;
LabelObj.MailingLabel.Add(Value);
finally
FreeAndNil(Attribs);
end;
end;
{This parses the Name and places the name in the TIdVCardName}
procedure ParseName(NameObj : TIdVCardName; NameStr : String);
var
OtherNames : String;
begin
{ surname }
NameObj.SurName := Fetch(NameStr, ';'); {Do not Localize}
{ first name }
NameObj.FirstName := Fetch(NameStr, ';'); {Do not Localize}
{ middle and other names}
OtherNames := Fetch(NameStr, ';'); {Do not Localize}
{ Prefix }
NameObj.Prefix := Fetch(NameStr, ';'); {Do not Localize}
{ Suffix }
NameObj.Suffix := Fetch(NameStr, ';'); {Do not Localize}
OtherNames := ReplaceAll(OtherNames, ' ', ','); {Do not Localize}
ParseDelimiterToStrings(NameObj.OtherNames, OtherNames);
end;
{This parses EMailStr and places the attributes in EMailObj }
procedure ParseEMailAddress(EMailObj : TIdVCardEMailItem; EMailStr : String);
var
Value : String;
Attribs : TStringList;
idx : Integer;
{this is for testing the type so we can break out of the loop}
ps : Integer;
function IsPreferred: Boolean;
var
idx2: Integer;
begin
for idx2 := 0 to Attribs.Count-1 do begin
if TextIsSame(Attribs[idx2], 'PREF') then begin {Do not Localize}
Result := True;
Exit;
end;
end;
Result := False;
end;
begin
Attribs := GetAttributesAndValue (EMailStr, Value);
try
EMailObj.Address := Value;
EMailObj.Preferred := IsPreferred;
for idx := 0 to Attribs.Count-1 do begin
ps := PosInStrArray(Attribs[idx], EMailTypePropertyParameter);
if ps <> -1 then begin
case ps of
0 : EMailObj.EMailType := ematAOL; {America On-Line}
1 : EMailObj.EMailType := ematAppleLink; {AppleLink}
2 : EMailObj.EMailType := ematATT; { AT&T Mail }
3 : EMailObj.EMailType := ematCIS; { CompuServe Information Service }
4 : EMailObj.EMailType := emateWorld; { eWorld }
5 : EMailObj.EMailType := ematInternet; {Internet SMTP (default)}
6 : EMailObj.EMailType := ematIBMMail; { IBM Mail }
7 : EMailObj.EMailType := ematMCIMail; { Indicates MCI Mail }
8 : EMailObj.EMailType := ematPowerShare; { PowerShare }
9 : EMailObj.EMailType := ematProdigy; { Prodigy information service }
10 : EMailObj.EMailType := ematTelex; { Telex number }
11 : EMailObj.EMailType := ematX400; { X.400 service }
end;
Break;
end;
end;
finally
FreeAndNil(Attribs);
end;
end;
{ TIdVCard }
procedure TIdVCard.InitComponent;
begin
inherited InitComponent;
FPhoto := TIdVCardEmbeddedObject.Create;
FLogo := TIdVCardEmbeddedObject.Create;
FSound := TIdVCardEmbeddedObject.Create;
FKey := TIdVCardEmbeddedObject.Create;
FComments := TStringList.Create;
FCategories := TStringList.Create;
FBusinessInfo := TIdVCardBusinessInfo.Create;
FGeography := TIdVCardGeog.Create;
FFullName := TIdVCardName.Create;
FRawForm := TStringList.Create;
FEMailAddresses := TIdVCardEMailAddresses.Create(Self);
FAddresses := TIdVCardAddresses.Create(Self);
FTelephones := TIdVCardTelephones.Create(Self);
FURLs := TStringList.Create;
FMailingLabels := TIdVCardMailingLabels.Create(Self);
end;
destructor TIdVCard.Destroy;
begin
FreeAndNil(FKey);
FreeAndNil(FPhoto);
FreeAndNil(FLogo);
FreeAndNil(FSound);
FreeAndNil(FComments);
FreeAndNil(FMailingLabels);
FreeAndNil(FCategories);
FreeAndNil(FBusinessInfo);
FreeAndNil(FGeography);
FreeAndNil(FURLs);
FreeAndNil(FTelephones);
FreeAndNil(FAddresses);
FreeAndNil(FEMailAddresses);
FreeAndNil(FFullName);
FreeAndNil(FRawForm);
inherited Destroy;
end;
procedure TIdVCard.ReadFromStrings(s: TStrings);
var
idx, level : Integer;
begin
FRawForm.Clear;
{Find the begin mark and accomodate broken VCard implemntations}
level := 0;
for idx := 0 to s.Count-1 do begin
if TextIsSame(Trim(s[idx]), 'BEGIN:VCARD') then begin {Do not Localize}
Break;
end;
end;
{Keep adding until end VCard }
while idx < s.Count do begin
if Length(s[idx]) > 0 then begin
case PosInStrArray(Trim(s[idx]), ['BEGIN:VCARD', 'END:VCARD'], False) of {Do not Localize}
0: begin
// Have a new object - increment the counter & add
Inc(level);
end;
1: begin
// Have an END:
Dec(level);
end;
end;
// regardless of content, add it
FRawForm.Add(s[idx]);
if level < 1 then begin
Break;
end;
end;
Inc(idx);
end;
SetVariablesAfterRead;
end;
procedure TIdVCard.SetCategories(Value: TStrings);
begin
FCategories.Assign(Value);
end;
procedure TIdVCard.SetComments(Value: TStrings);
begin
FComments.Assign(Value);
end;
procedure TIdVCard.SetURLs(Value: TStrings);
begin
FURLs.Assign(Value);
end;
procedure TIdVCard.SetVariablesAfterRead;
var
idx : Integer;
// OrigLine : String;
Line : String;
Attribs : String;
Data : String;
Test : String;
Colon : Integer;
SColon : Integer;
ColonFind : Integer;
QPCoder : TIdDecoderQuotedPrintable;
{These subroutines increment idx to prevent unneded comparisons of folded lines}
function UnfoldLines : String;
begin
Result := ''; {Do not Localize}
Inc(idx);
while (idx < FRawForm.Count) and CharIsInSet(FRawForm[idx], 1, ' '#9) do {Do not Localize}
begin
Result := Result + Trim(FRawForm[idx]);
Inc(idx);
end; // while
{Correct for increment in the main while loop}
Dec(idx);
end;
procedure ProcessAgent;
begin
// The current idx of FRawForm could be an embedded vCard.
{ TODO : Eliminate embedded vCard }
end;
procedure ParseEmbeddedObject(EmObj : TIdVCardEmbeddedObject; StLn : String);
var
Value : String;
LAttribs : TStringList;
idx2 : Integer;
{this is for testing the type so we can break out of the loop}
begin
LAttribs := GetAttributesAndValue(StLn, Value);
try
for idx2 := 0 to LAttribs.Count-1 do begin
if PosInStrArray(LAttribs[idx2], ['ENCODING=BASE64', 'BASE64']) <> -1 then begin {Do not Localize}
emObj.Base64Encoded := True;
end
else if PosInStrArray(LAttribs[idx2], ['VALUE=URI', 'VALUE=URL', 'URI', 'URL']) = -1 then begin {Do not Localize}
emObj.ObjectType := LAttribs[idx2];
end;
end;
if (LAttribs.IndexOf('VALUE=URI') > -1) or {Do not Localize}
(LAttribs.IndexOf('VALUE=URL') > -1) or {Do not Localize}
(LAttribs.IndexOf('URI') > -1) or {Do not Localize}
(LAttribs.IndexOf('URL') > -1) then {Do not Localize}
begin
emObj.ObjectURL := Value + UnfoldLines;
end else begin
AddValueToStrings(EmObj.EmbeddedData, Value);
{Add any folded lines}
Inc(idx);
while (idx < FRawForm.Count) and CharIsInSet(FRawForm[idx], 1, ' '#9) do begin {Do not Localize}
AddValueToStrings(EmObj.EmbeddedData, Trim(FRawForm[idx]));
Inc(idx);
end;
{Correct for increment in the main while loop}
Dec(idx);
end;
finally
FreeAndNil(LAttribs);
end;
end;
function GetDateTimeValue(St: String): TDateTime;
var
LAttribs: String;
LDate: TIdISO8601DateComps;
LTime: TIdISO8601TimeComps;
begin
Result := 0.0;
// TODO: parse the attributes into a proper list
LAttribs := UpperCase(Attribs);
if IndyPos('TIMESTAMP', LAttribs) <> 0 then begin {Do not Localize}
if ParseISO8601DateTimeStamp(St, LDate, LTime) then begin
Result := EncodeDate(LDate.Year, LDate.Month, LDate.Day) + EncodeTime(LTime.Hour, LTime.Min, LTime.Sec, LTime.MSec);
// TODO: use LTime.UTCOffset if available
end;
end
else if IndyPos('DATE-AND-OR-TIME', LAttribs) <> 0 then begin {Do not Localize}
if ParseISO8601DateAndOrTime(st, LDate, LTime) then begin
if (LDate.Year <> 0) or (LDate.Month <> 0) or (LDate.Day <> 0) then begin
Result := EncodeDate(LDate.Year, LDate.Month, LDate.Day);
end;
if (LTime.Hour <> 0) or (LTime.Min <> 0) or (LTime.Sec <> 0) or (LTime.MSec <> 0) then begin
Result := Result + EncodeTime(LTime.Hour, LTime.Min, LTime.Sec, LTime.MSec);
// TODO: use LTime.UTCOffset if available
end;
end;
end
else if IndyPos('DATE-TIME', LAttribs) <> 0 then begin {Do not Localize}
if ParseISO8601DateTime(st, LDate, LTime) then begin
Result := EncodeDate(LDate.Year, LDate.Month, LDate.Day) + EncodeTime(LTime.Hour, LTime.Min, LTime.Sec, LTime.MSec);
// TODO: use LTime.UTCOffset if available
end;
end
else if IndyPos('DATE', LAttribs) <> 0 then begin {Do not Localize}
if ParseISO8601Date(st, LDate) then begin
Result := EncodeDate(LDate.Year, LDate.Month, LDate.Day);
end;
end
else if IndyPos('TIME', LAttribs) <> 0 then begin {Do not Localize}
if ParseISO8601Time(st, LTime) then begin
Result := EncodeTime(LTime.Hour, LTime.Min, LTime.Sec, LTime.MSec);
// TODO: use LTime.UTCOffset if available
end;
end else begin
if ParseISO8601DateAndOrTime(st, LDate, LTime) then begin
if (LDate.Year <> 0) or (LDate.Month <> 0) or (LDate.Day <> 0) then begin
Result := EncodeDate(LDate.Year, LDate.Month, LDate.Day);
end;
if (LTime.Hour <> 0) or (LTime.Min <> 0) or (LTime.Sec <> 0) or (LTime.MSec <> 0) then begin
Result := Result + EncodeTime(LTime.Hour, LTime.Min, LTime.Sec, LTime.MSec);
// TODO: use LTime.UTCOffset if available
end;
end;
end;
end;
begin
// At this point, FRawForm contains the entire vCard - including possible
// embedded vCards.
QPCoder := TIdDecoderQuotedPrintable.Create(Self);
try
idx := 0;
while idx < FRawForm.Count do
begin
// Grab the line
Line := FRawForm[idx];
{We separate the property name from the parameters and values here.
We have be careful because sometimes a property in a vCard is separed by a
; or : even if the RFC and standards don't permit this
- broken VCard creation tools }
Colon := IndyPos(':', Line); {Do not Localize}
// Store the property & complete attributes
// TODO: use a TStringList instead...
Attribs := Copy(Line, 1, Colon - 1);
// Must now check for Quoted-printable attribute. vCard v2.1 allows
// QP to be used in any field.
//**** Begin QP check & decode
if IndyPos('QUOTED-PRINTABLE', UpperCase(Attribs)) > 0 then begin {Do not Localize}
// First things first - make a copy of the Line.
// OrigLine := Line;
// Set Data to be the data contained on this line of the vCard
Data := Copy(Line, Colon + 1, MaxInt);
// The problem with QP-embedded objects is that the Colon character is
// not standard QP-encoded... however, it is the only reliable way to
// discover the next property. So loop here until the next property is
// found (i.e., the next line with a colon).
Inc(idx);
ColonFind := IndyPos(':', FRawForm[idx]); {Do not Localize}
while ColonFind = 0 do begin
Data := Data + TrimLeft(FRawForm[idx]);
Inc(idx);
if idx <> FRawForm.Count then begin
ColonFind := IndyPos(':', FRawForm[idx]); {Do not Localize}
end else begin
ColonFind := 1;
end;
end;
// Return idx to this property's (last) line {Do not Localize}
Dec(idx);
Data := QPCoder.DecodeString(Data);
// Now reorganise property so that it does not have a QP attribute.
ColonFind := IndyPos(';', Attribs); {Do not Localize}
Line := ''; {Do not Localize}
while ColonFind <> 0 do begin
Test := Copy(Attribs, 1, ColonFind);
if IndyPos('QUOTED-PRINTABLE', UpperCase(Test)) = 0 then begin {Do not Localize}
// Add to Line.
Line := Line + Test;
end;
Attribs := Copy(Attribs, ColonFind + 1, MaxInt);
ColonFind := IndyPos(';', Attribs); {Do not Localize}
end;
// Clean up variables
if Length(Attribs) <> 0 then begin
// Does Quoted-Printable occur in what's left? {Do not Localize}
if IndyPos('QUOTED-PRINTABLE', UpperCase(Attribs)) = 0 then begin {Do not Localize}
// Add to line
Line := Line + Attribs;
end;
end;
// Check if the last char of Line is a semi-colon. If so, remove it.
ColonFind := Length(Line);
If ColonFind > 0 then
begin
if Line[ColonFind] = ';' then begin {Do not Localize}
Line := Copy(Line, 1, ColonFind - 1);
end;
end;
Line := Line + ':' + Data; {Do not Localize}
end;
//**** End QP check & decode
Colon := IndyPos(':', Line); {Do not Localize}
SColon := IndyPos(';', Line); {Do not Localize}
if (Colon < SColon) or (SColon = 0) then begin
Line := ReplaceOnlyFirst(Line, ':', ';'); {Do not Localize}
end;
// Grab the property name
Test := Fetch(Line, ';'); {Do not Localize}
// Discover which property it is.
case PosInStrArray(Test, VCardProperties, False) of
{'FN'} {Do not Localize}
0 : FFullName.FormattedName := Line + UnfoldLines;
{'N'} {Do not Localize}
1 : ParseName(FFullName, Line + UnfoldLines);
{'NICKNAME'} {Do not Localize}
2 : ParseDelimiterToStrings(FFullName.NickNames, Line + UnfoldLines);
{'PHOTO'} {Do not Localize}
3 : ParseEmbeddedObject(FPhoto, Line);
{'BDAY'} {Do not Localize}
4 : FBirthDay := GetDateTimeValue(Line + UnfoldLines);
{'ADR'} {Do not Localize}
5 : ParseAddress(FAddresses.Add, Line + UnfoldLines);
{'LABEL'} {Do not Localize}
6 : ParseMailingLabel(FMailingLabels.Add, Line + UnfoldLines);
{'TEL'} {Do not Localize}
7 : ParseTelephone(FTelephones.Add, Line + UnfoldLines);
{'EMAIL'} {Do not Localize}
8 : ParseEMailAddress(FEMailAddresses.Add, Line + UnfoldLines);
{'MAILER'} {Do not Localize}
9 : FEMailProgram := Line + UnfoldLines;
{'TZ'} {Do not Localize}
10 : FGeography.TimeZoneStr := Line + UnfoldLines;
{'GEO'} {Do not Localize}
11 : ParseGeography(FGeography, Line + UnfoldLines);
{'TITLE'} {Do not Localize}
12 : FBusinessInfo.Title := Line + UnfoldLines;
{'ROLE'} {Do not Localize}
13 : FBusinessInfo.Role := Line + UnfoldLines;
{'LOGO'} {Do not Localize}
14 : ParseEmbeddedObject (FLogo, Line);
{'AGENT'} {Do not Localize}
15 : ProcessAgent;
{'ORG'} {Do not Localize}
16 : ParseOrg(FBusinessInfo, Line + UnfoldLines);
{'CATEGORIES'} {Do not Localize}
17 : ParseDelimiterToStrings(FCategories, Line + UnfoldLines);
{'NOTE'} {Do not Localize}
18 : FComments.Add(Line + UnfoldLines);
{'PRODID' } {Do not Localize}
19 : FProductID := Line + UnfoldLines;
{'REV'} {Do not Localize}
20 : FLastRevised := GetDateTimeValue(Line + UnfoldLines);
{'SORT-STRING'} {Do not Localize}
21 : FFullName.SortName := Line + UnfoldLines;
{'SOUND'} {Do not Localize}
22 : ParseEmbeddedObject(FSound, Line);
{'URL'} {Do not Localize}
23 : AddValueToStrings(FURLs, Line + UnfoldLines);
{'UID'} {Do not Localize}
24 : FUniqueID := Line + UnfoldLines;
{'VERSION'} {Do not Localize}
25 : FVCardVersion := IndyStrToFloat(Line + UnfoldLines);
{'CLASS'} {Do not Localize}
26 : FClassification := Line + UnfoldLines;
{'KEY'} {Do not Localize}
27 : ParseEmbeddedObject(FKey, Line);
end;
Inc(idx);
end;
finally
FreeAndNil(QPCoder);
end;
end;
{ TIdVCardEMailAddresses }
function TIdVCardEMailAddresses.Add: TIdVCardEMailItem;
begin
Result := TIdVCardEMailItem(inherited Add);
end;
constructor TIdVCardEMailAddresses.Create(AOwner : TPersistent);
begin
inherited Create(AOwner, TIdVCardEMailItem);
end;
function TIdVCardEMailAddresses.GetItem(Index: Integer): TIdVCardEMailItem;
begin
Result := TIdVCardEMailItem(inherited Items[Index]);
end;
procedure TIdVCardEMailAddresses.SetItem(Index: Integer; const Value: TIdVCardEMailItem);
begin
inherited SetItem(Index, Value);
end;
{ TIdVCardEMailItem }
procedure TIdVCardEMailItem.Assign(Source: TPersistent);
var
EMail : TIdVCardEMailItem;
begin
if Source is TIdVCardEMailItem then begin
EMail := Source as TIdVCardEMailItem;
EMailType := EMail.EMailType;
Preferred := EMail.Preferred;
Address := EMail.Address;
end else begin
inherited Assign(Source);
end;
end;
constructor TIdVCardEMailItem.Create(Collection: TCollection);
begin
inherited Create(Collection);
FEMailType := ematInternet;
end;
{ TIdVCardAddresses }
function TIdVCardAddresses.Add: TIdCardAddressItem;
begin
Result := TIdCardAddressItem(inherited Add);
end;
constructor TIdVCardAddresses.Create(AOwner : TPersistent);
begin
inherited Create(AOwner, TIdCardAddressItem);
end;
function TIdVCardAddresses.GetItem(Index: Integer): TIdCardAddressItem;
begin
Result := TIdCardAddressItem(inherited Items[Index]);
end;
procedure TIdVCardAddresses.SetItem(Index: Integer; const Value: TIdCardAddressItem);
begin
inherited SetItem(Index, Value);
end;
{ TIdVCardTelephones }
function TIdVCardTelephones.Add: TIdCardPhoneNumber;
begin
Result := TIdCardPhoneNumber(inherited Add);
end;
constructor TIdVCardTelephones.Create(AOwner : TPersistent);
begin
inherited Create(AOwner, TIdCardPhoneNumber);
end;
function TIdVCardTelephones.GetItem(Index: Integer): TIdCardPhoneNumber;
begin
Result := TIdCardPhoneNumber(inherited Items[Index]);
end;
procedure TIdVCardTelephones.SetItem(Index: Integer; const Value: TIdCardPhoneNumber);
begin
inherited SetItem(Index, Value);
end;
{ TIdVCardName }
constructor TIdVCardName.Create;
begin
inherited Create;
FOtherNames := TStringList.Create;
FNickNames := TStringList.Create;
end;
destructor TIdVCardName.Destroy;
begin
FreeAndNil(FNickNames);
FreeAndNil(FOtherNames);
inherited Destroy;
end;
procedure TIdVCardName.SetNickNames(Value: TStrings);
begin
FNickNames.Assign(Value);
end;
procedure TIdVCardName.SetOtherNames(Value: TStrings);
begin
FOtherNames.Assign(Value);
end;
{ TIdVCardBusinessInfo }
constructor TIdVCardBusinessInfo.Create;
begin
inherited Create;
FDivisions := TStringList.Create;
end;
destructor TIdVCardBusinessInfo.Destroy;
begin
FreeAndNil(FDivisions);
inherited Destroy;
end;
procedure TIdVCardBusinessInfo.SetDivisions(Value: TStrings);
begin
FDivisions.Assign(Value);
end;
{ TIdVCardMailingLabelItem }
procedure TIdVCardMailingLabelItem.Assign(Source: TPersistent);
var
lbl : TIdVCardMailingLabelItem;
begin
if Source is TIdVCardMailingLabelItem then begin
lbl := Source as TIdVCardMailingLabelItem;
AddressAttributes := lbl.AddressAttributes;
MailingLabel.Assign(lbl.MailingLabel);
end else begin
inherited Assign(Source);
end;
end;
constructor TIdVCardMailingLabelItem.Create(Collection: TCollection);
begin
inherited Create(Collection);
FMailingLabel := TStringList.Create;
end;
destructor TIdVCardMailingLabelItem.Destroy;
begin
FreeAndNil(FMailingLabel);
inherited Destroy;
end;
procedure TIdVCardMailingLabelItem.SetMailingLabel(Value: TStrings);
begin
FMailingLabel.Assign(Value);
end;
{ TIdVCardMailingLabels }
function TIdVCardMailingLabels.Add: TIdVCardMailingLabelItem;
begin
Result := TIdVCardMailingLabelItem(inherited Add);
end;
constructor TIdVCardMailingLabels.Create(AOwner: TPersistent);
begin
inherited Create(AOwner, TIdVCardMailingLabelItem);
end;
function TIdVCardMailingLabels.GetItem(Index: Integer): TIdVCardMailingLabelItem;
begin
Result := TIdVCardMailingLabelItem(inherited GetItem(Index));
end;
procedure TIdVCardMailingLabels.SetItem(Index: Integer; const Value: TIdVCardMailingLabelItem);
begin
inherited SetItem(Index, Value);
end;
{ TIdEmbeddedObject }
constructor TIdVCardEmbeddedObject.Create;
begin
inherited Create;
FEmbeddedData := TStringList.Create;
end;
destructor TIdVCardEmbeddedObject.Destroy;
begin
FreeAndNil(FEmbeddedData);
inherited Destroy;
end;
procedure TIdVCardEmbeddedObject.SetEmbeddedData(const Value: TStrings);
begin
FEmbeddedData.Assign(Value);
end;
{ TIdCardPhoneNumber }
procedure TIdCardPhoneNumber.Assign(Source: TPersistent);
var
Phone : TIdCardPhoneNumber;
begin
if Source is TIdCardPhoneNumber then begin
Phone := Source as TIdCardPhoneNumber;
PhoneAttributes := Phone.PhoneAttributes;
Number := Phone.Number;
end else begin
inherited Assign(Source);
end;
end;
{ TIdCardAddressItem }
procedure TIdCardAddressItem.Assign(Source: TPersistent);
var
LAddr : TIdCardAddressItem;
begin
if Source is TIdCardAddressItem then begin
LAddr := Source as TIdCardAddressItem;
AddressAttributes := LAddr.AddressAttributes;
POBox := LAddr.POBox;
ExtendedAddress := LAddr.ExtendedAddress;
StreetAddress := LAddr.StreetAddress;
Locality := LAddr.Locality;
Region := LAddr.Region;
PostalCode := LAddr.PostalCode;
Nation := LAddr.Nation;
end else begin
inherited Assign(Source);
end;
end;
end.