xsbuiltins.pas

Delphi开发webservice的一套例子

{*******************************************************}
{                                                       }
{ Borland Delphi Visual Component Library               }
{                SOAP Support                           }
{                                                       }
{ Copyright (c) 2001 Borland Software Corporation       }
{                                                       }
{*******************************************************}
unit XSBuiltIns;

interface

uses SysUtils, InvokeRegistry;

const
  SoapTimePrefix = 'T';
  XMLDateSeparator = '-';
  XMLHourOffsetMinusMarker = '-';
  XMLHourOffsetPlusMarker = '+';
  XMLTimeSeparator = ':';
  XMLMonthPos = 6;
  XMLDayPos = 9;
  XMLYearPos = 1;
  XMLMilSecPos = 10;
  XMLDefaultYearDigits = 4;
  XMLDurationStart = 'P';
  XMLDurationYear = 'Y';
  XMLDurationMonth = 'M';
  XMLDurationDay = 'D';
  XMLDurationHour = 'H';
  XMLDurationMinute = 'M';
  XMLDurationSecond = 'S';

resourcestring
  SInvalidHour = 'Invalid hour: %d';
  SInvalidMinute = 'Invalid minute: %d';
  SInvalidSecond = 'Invalid second: %d';
  SInvalidFractionSecond = 'Invalid second: %f';
  SInvalidMillisecond = 'Invalid millisecond: %d';
  SInvalidHourOffset = 'Invalid hour offset: %d';
  SInvalidDay = 'Invalid day: %d';
  SInvalidMonth = 'Invalid month: %d';
  SInvalidDuration = 'Invalid Duration String: %s';
type

{ forward declarations }

TXSDuration = class;
TXSTime = class;
TXSDate = class;
TXSDateTime = class;

{ TXSTime }

TXSTime = class(TRemotableXS)
  private
    FHour: Word;
    FMinute: Word;
    FSecond: Word;
    FMillisecond: Word;
    FHourOffset: SmallInt;
    FMinuteOffset: SmallInt;
    function BuildHourOffset: WideString;
  protected
    function GetAsTime: TDateTime;
    procedure SetAsTime(Value: TDateTime);
    procedure SetHour(const Value: Word);
    procedure SetMinute(const Value: Word);
    procedure SetSecond(const Value: Word);
    procedure SetMillisecond(const Value: Word);
    procedure SetHourOffset(const Value: SmallInt);
    procedure SetMinuteOffset(const Value: SmallInt);
  public
    function Clone: TXSTime;
    property Hour: Word read FHour write SetHour default 0;
    property Minute: Word read FMinute write SetMinute default 0;
    property Second: Word read FSecond write SetSecond default 0;
    property Millisecond: Word read FMillisecond write SetMillisecond default 0;
    property HourOffset: SmallInt read FHourOffset write SetHourOffset default 0;
    property MinuteOffset: SmallInt read FMinuteOffset write SetMinuteOffset;
    procedure XSToNative(Value: WideString); override;
    function NativeToXS: WideString; override;
    property AsTime: TDateTime read GetAsTime write SetAsTime;
end;

{ TXSDate }

TXSDate = class(TRemotableXS)
  private
    FAdditionalYearDigits: Word;
    FMonth: Word;
    FDay: Word;
    FYear: Word;
    FMaxDay: Word;
    FMaxMonth: Word;
    FMinDay: Word;
    FMinMonth: Word;
  protected
    function GetAsDate: TDateTime;
    procedure SetAsDate(Value: TDateTime);
    procedure SetMonth(const Value: Word);
    procedure SetDay(const Value: Word);
    procedure SetYear(const Value: Word);
    property MaxDay: Word read FMaxDay write FMaxDay;
    property MaxMonth: Word read FMaxMonth write FMaxMonth;
    property MinDay: Word read FMinDay write FMinDay;
    property MinMonth: Word read FMinMonth write FMinMonth;
  public
    constructor Create; override;
    property Month: Word read FMonth write SetMonth default 0;
    property Day: Word read FDay write SetDay default 0;
    property Year: Word read FYear write SetYear default 0;
    function Clone: TXSDate;
    procedure XSToNative(Value: WideString); override;
    function NativeToXS: WideString; override;
    property AsDate: TDateTime read GetAsDate write SetAsDate;
end;

{ TXSCustomDateTime }

TXSCustomDateTime = class(TRemotableXS)
  private
    FDateParam: TXSDate;
    FTimeParam: TXSTime;
  protected
    function GetAsDateTime: TDateTime;
    function GetHour: Word;
    function GetMinute: Word;
    function GetSecond: Word;
    function GetMonth: Word;
    function GetDay: Word;
    function GetYear: Word;
    function GetMillisecond: Word;
    function GetHourOffset: SmallInt;
    function GetMinuteOffset: SmallInt;
    procedure SetAsDateTime(Value: TDateTime);
    procedure SetHour(const Value: Word); virtual;
    procedure SetMinute(const Value: Word); virtual;
    procedure SetSecond(const Value: Word); virtual;
    procedure SetMillisecond(const Value: Word); virtual;
    procedure SetHourOffset(const Value: SmallInt); virtual;
    procedure SetMinuteOffset(const Value: SmallInt); virtual;
    procedure SetMonth(const Value: Word); virtual;
    procedure SetDay(const Value: Word); virtual;
    procedure SetYear(const Value: Word); virtual;
  public
    constructor Create;  override;
    destructor Destroy; override;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property Hour: Word read GetHour write SetHour default 0;
    property Minute: Word read GetMinute write SetMinute default 0;
    property Second: Word read GetSecond write SetSecond default 0;
    property Month: Word read GetMonth write SetMonth default 0;
    property Day: Word read GetDay write SetDay default 0;
    property Year: Word read GetYear write SetYear default 0;
end;

{ TXSDateTime }

TXSDateTime = class(TXSCustomDateTime)
  private
    function ValidValue(Value, Subtract, Min, Max: Integer; var Remainder: Integer): Integer;
  public  
    function CompareDateTimeParam(const Value1, Value2: TXSDateTime): TXSDuration;
  public
    function Clone: TXSDateTime;
    property Millisecond: Word read GetMillisecond write SetMillisecond default 0;
    property HourOffset: SmallInt read GetHourOffset write SetHourOffset default 0;
    property MinuteOffset: SmallInt read GetMinuteOffset write SetMinuteOffset default 0;
    procedure XSToNative(Value: WideString); override;
    function NativeToXS: WideString; override;
end;

{ TXSDuration }

TXSDuration = class(TXSCustomDateTime)
  private
    FDecimalSecond: Double;
    function GetDecimalValue(const AParam: String; const AType: string): Double;
    function GetIntegerValue(const AParam: String; const AType: string): Integer;
    function GetNumericString(const AParam: string; const AType: String;
             const Decimals: Boolean = False): WideString;
  protected
    procedure SetDecimalSecond(const Value: Double);
  public
    constructor Create; override;
    procedure XSToNative(Value: WideString); override;
    function NativeToXS: WideString; override;
    property DecimalSecond: Double read FDecimalSecond write SetDecimalSecond;
end;

EXSDateTimeException = class(Exception);

{ TXSHexBinary }
{ Rudimentary support (strictly to handle xsd:hexBinary) for now }
TXSHexBinary = class(TRemotableXS)
  private
    FHexBinaryString: string;
  public
    procedure XSToNative(Value: WideString); override;
    function  NativeToXS: WideString; override;
    property  HexBinaryString: string read FHexBinaryString write FHexBinaryString;
end;

{ TXSDecimal }
{ Rudimentary support (strictly to handle xsd:decimal) for now }
TXSDecimal = class(TRemotableXS)
  private
    FDecimalString: string;
  public
    procedure XSToNative(Value: WideString); override;
    function  NativeToXS: WideString; override;
    property  DecimalString: string read FDecimalString write FDecimalString;
end;


{ Utility function }

function DateTimeToXSDateTime(Value: TDateTime; CalcLocalBias: Boolean = False): TXSDateTime;

implementation

uses SOAPConst, {$IFDEF MSWINDOWS}Windows{$ENDIF}{$IFDEF LINUX}Libc, Types{$ENDIF}, DateUtils;

{ exception routines }

procedure SoapDateTimeError(const Message: string); local;
begin
  raise EXSDateTimeException.Create(Message);
end;

procedure SoapDateTimeErrorFmt(const Message: string; const Args: array of const); local;
begin
  SoapDateTimeError(Format(Message,Args));
end;

{ Utility functions }

procedure AddUTCBias(var DateTime: TXSDateTime);
{$IFDEF MSWINDOWS}
var
  Info: TTimeZoneInformation;
  Status: DWORD;
{$ENDIF}
begin
{$IFDEF MSWINDOWS}
  Status := GetTimeZoneInformation(Info);
  if (Status = TIME_ZONE_ID_UNKNOWN) or (Status = TIME_ZONE_ID_INVALID) then
    SoapDateTimeError(SInvalidTimeZone);
  DateTime.HourOffset := Info.Bias div 60;
  DateTime.MinuteOffset := Info.Bias - (DateTime.HourOffset * 60);
{$ENDIF}
end;

function DateTimeToXSDateTime(Value: TDateTime; CalcLocalBias: Boolean = False): TXSDateTime;
begin
  Result := TXSDateTime.Create;
  Result.AsDateTime := Value;
  if CalcLocalBias then
    AddUTCBias(Result);
end;

procedure ParseXMLDate(ADate: WideString; var Year, Month, Day: Word);
begin
  Year := StrToInt(Copy(ADate, XMLYearPos, 4));
  Month := StrToInt(Copy(ADate, XMLMonthPos, 2));
  Day := StrToInt(Copy(ADate, XMLDayPos, 2));
end;

function XMLDateToStr(ADate: WideString; AddDigits: Word = 0): WideString;
begin
  Result := Copy(ADate, XMLMonthPos + AddDigits, 2) + DateSeparator +
            Copy(ADate, XMLDayPos + AddDigits, 2 ) +
            DateSeparator + Copy(ADate, XMLYearPos, XMLDefaultYearDigits + AddDigits);
end;

{ Get Small Int Using Digits in value, positive or negative. }
function IntFromValue(Value: WideString; Digits: Integer): SmallInt;
begin
  Result := 0;
  if Value = '' then exit;
  if Value[1] = '-' then
    Result := StrToInt(Value)
  else if Value <> '' then
    Result := StrToInt(Copy(Value, 1, Digits));
end;    

{ TXSTime }

function TXSTime.Clone: TXSTime;
begin
  Result := TXSTime.Create;
  Result.Hour := Hour;
  Result.Minute := Minute;
  Result.Second := Second;
  Result.MilliSecond := MilliSecond;
  Result.HourOffset := HourOffset;
  Result.MinuteOffset := MinuteOffset;
end;

procedure TXSTime.SetHour(const Value: Word);
begin
  if Value < HoursPerDay then
    FHour := Value
  else
    SoapDateTimeErrorFmt(SInvalidHour, [Value]);
end;

procedure TXSTime.SetMinute(const Value: Word);
begin
  if Value < 60 then
    FMinute := Value
  else
    SoapDateTimeErrorFmt(SInvalidMinute, [Value]);
end;

procedure TXSTime.SetSecond(const Value: Word);
begin
  if Value < 60 then
    FSecond := Value
  else
    SoapDateTimeErrorFmt(SInvalidSecond, [Value]);
end;

procedure TXSTime.SetMillisecond(const Value: Word);
begin
  if Value < 1000 then
    FMillisecond := Value
  else
    SoapDateTimeErrorFmt(SInvalidMillisecond, [Value]);
end;

procedure TXSTime.SetHourOffset(const Value: SmallInt);
begin
  if Abs(Value) <= (HoursPerDay div 2) then
    FHourOffset := Value
  else
    SoapDateTimeErrorFmt(SInvalidHourOffset, [Value]);
end;

procedure TXSTime.SetMinuteOffset(const Value: SmallInt);
begin
  if Abs(Value) < 60 then
    FMinuteOffset := Value
  else
    SoapDateTimeErrorFmt(SInvalidMinute, [Value]);
end;

procedure TXSTime.XSToNative(Value: WideString);
var
  TempValue: WideString;
  TempTime: TDateTime;
  HourOffsetPos: Integer;
begin
  TempValue := StringReplace(Copy(Value, 1, 8), XMLTimeSeparator, TimeSeparator, []);
  TempTime := StrToTime(TempValue);
  DecodeTime(TempTime, FHour, FMinute, FSecond, FMillisecond);
  TempValue := Copy(Value, XMLMilSecPos, 3);
  Millisecond := IntFromValue(TempValue, 3);
  HourOffsetPos := Pos(XMLHourOffsetMinusMarker, Value);
  if HourOffsetPos = 0 then
    HourOffsetPos := Pos(XMLHourOffsetPlusMarker, Value);
  if HourOffsetPos > 0 then
  begin
    TempValue := Copy(Value, HourOffsetPos + 1, 2);
    HourOffset := IntFromValue(TempValue, 2);
    TempValue := Copy(Value, HourOffsetPos + 4, 2);
    if TempValue <> '' then
      MinuteOffSet := IntFromValue(TempValue,2);
  end;  
end;

function TXSTime.BuildHourOffset: WideString;
var
  Marker: String;
begin
  if Abs(HourOffset) + MinuteOffset <> 0 then
  begin
    if HourOffset > 0 then
      Marker := XMLHourOffsetPlusMarker
    else
      Marker := XMLHourOffsetMinusMarker;
    Result := IntToStr(Abs(HourOffset));
    if Abs(HourOffset) < 10 then
      Result := '0' + Result;
    if Abs(MinuteOffSet) > 9 then
      Result := Result + XMLTimeSeparator + IntToStr(Abs(MinuteOffset))
    else if Abs(MinuteOffSet) > 0 then
      Result := Result + XMLTimeSeparator + '0' + IntToStr(Abs(MinuteOffset))
    else
      Result := Result + XMLTimeSeparator + '00';
    Result := Marker + Result;
  end;
end;

function TXSTime.NativeToXS: WideString;
var
  TempTime: TDateTime;
  FormatString: string;
begin
  if Hour + Minute + Second = 0 then exit;
  TempTime := EncodeTime(Hour, Minute, Second, Millisecond);   { Exception thrown if invalid }
  FormatString := Format('hh%snn%sss.zzz', [XMLTimeSeparator, XMLTimeSeparator]);
  Result := FormatDateTime(FormatString, TempTime) + BuildHourOffset;
end;