home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Rtl / Corba / ORBPAS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  15.5 KB  |  399 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Runtime Library                  }
  5. {                                                       }
  6. {       Copyright (C) 1999 Inprise Corporation          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ORBPAS;
  11.  
  12. interface
  13.  
  14. uses Windows, ActiveX, SysUtils;
  15.  
  16. type
  17.   ICorbaObj = interface;
  18.   IMarshalInBuffer = interface;
  19.   IMarshalOutBuffer = interface;
  20.   ISkeleton = interface;
  21.   IStub = interface;
  22.   IBOA = interface;
  23.   IORB = interface;
  24.   ISkeletonObject = interface;
  25.   IStubObject = interface;
  26.  
  27.   CorbaBoolean = ByteBool;
  28.   CorbaULong = Integer;
  29.   PCorbaAny = type Pointer;
  30.   PCorbaObject = type Pointer;
  31.   PCorbaOrb = type Pointer;
  32.   PCorbaInterfaceDef = type Pointer;
  33.   PMarshalInbuffer = type Pointer;
  34.   PMarshalOutbuffer = type Pointer;
  35.   PUserExceptionProxy = type Pointer;
  36.   PExceptionDescription = type Pointer;
  37.  
  38.   TArgv = array of string;
  39.  
  40.   ICorbaObj = interface
  41.     ['{47E946E1-BEA1-11D1-AA8A-00C04FB16F42}']
  42.     function CorbaObject: PCorbaObject; stdcall;
  43.     function IsLocal: CorbaBoolean; stdcall;
  44.   end;
  45.  
  46.   IMarshalInBuffer = interface
  47.     ['{47E946E2-BEA1-11D1-AA8A-00C04FB16F42}']
  48.     function Buffer: PMarshalInbuffer; stdcall;
  49.     function GetText: PChar; stdcall;
  50.     function GetChar: Shortint; stdcall;
  51.     function GetUnsignedChar: Byte; stdcall;
  52.     function GetShort: Smallint; stdcall;
  53.     function GetUnsignedShort: Word; stdcall;
  54.     function GetLong: Integer; stdcall;
  55.     function GetUnsignedLong: UINT; stdcall;
  56.     function GetFloat: Single; stdcall;
  57.     function GetDouble: Double; stdcall;
  58.     function GetWideText: PWideChar; stdcall;
  59.     function GetWidechar: Word; stdcall;
  60.     function GetAny: PCorbaAny; stdcall;
  61.     procedure GetObject(out Obj: ICorbaObj; ref_cnt: CorbaBoolean = True); stdcall;
  62.   end;
  63.  
  64.   IMarshalOutBuffer = interface
  65.     ['{47E946E3-BEA1-11D1-AA8A-00C04FB16F42}']
  66.     function Buffer: PMarshalOutbuffer; stdcall;
  67.     procedure PutText(Value: PChar); stdcall;
  68.     procedure PutChar(Value: Shortint); stdcall;
  69.     procedure PutUnsignedChar(Value: Byte); stdcall;
  70.     procedure PutShort(Value: Smallint); stdcall;
  71.     procedure PutUnsignedShort(Value: Word); stdcall;
  72.     procedure PutLong(Value: Integer); stdcall;
  73.     procedure PutUnsignedLong(Value: UINT); stdcall;
  74.     procedure PutFloat(Value: Single); stdcall;
  75.     procedure PutDouble(Value: Double); stdcall;
  76.     procedure PutWideText(Value: PWideChar); stdcall;
  77.     procedure PutWidechar(Value: Word); stdcall;
  78.     procedure PutAny(Value: PCorbaAny); stdcall;
  79.     procedure PutObject(const Value: ICorbaObj); stdcall;
  80.   end;
  81.  
  82.   ISkeleton = interface(ICorbaObj)
  83.     ['{47E946E4-BEA1-11D1-AA8A-00C04FB16F42}']
  84.     procedure GetImplementation(out Impl: IUnknown); stdcall;
  85.     procedure GetReplyBuffer(cookie: Pointer; out Outbuf: IMarshalOutBuffer); stdcall;
  86.   end;
  87.  
  88.   PCallDesc = ^TCallDesc;
  89.   TCallDesc = packed record
  90.     CallType: Byte;
  91.     ArgCount: Byte;
  92.     NamedArgCount: Byte;
  93.     ArgTypes: array[0..255] of Byte;
  94.   end;
  95.  
  96.   IStub = interface(ICorbaObj)
  97.     ['{47E946E5-BEA1-11D1-AA8A-00C04FB16F42}']
  98.     procedure CreateRequest(Operation: PChar; ResponseExpected: CorbaBoolean; out Outbuf: IMarshalOutBuffer); stdcall;
  99.     procedure Invoke(const Outbuf: IMarshalOutBuffer; out Inbuf: IMarshalInBuffer); stdcall;
  100.     function GetInterface: PCorbaInterfaceDef; stdcall;
  101.     function NonExistent: CorbaBoolean; stdcall;
  102.     function Hash(Maximum: CorbaULong): CorbaULong; stdcall;
  103.     function IsA(LogicalTypeId: PChar): CorbaBoolean; stdcall;
  104.     procedure SetPrincipal(Bytes: Pointer; Length: CorbaULong); stdcall;
  105.     function RepositoryID: PChar; stdcall;
  106.     function Dispatch(CallDesc: PCallDesc; Params: Pointer; out Result: Variant): Integer; stdcall;
  107.   end;
  108.  
  109.   TCKind = (tk_null, tk_void, tk_short, tk_long, tk_ushort, tk_ulong, tk_float,
  110.     tk_double, tk_boolean, tk_char, tk_octet, tk_any, tk_TypeCode, tk_Principal,
  111.     tk_objref, tk_struct, tk_union, tk_enum, tk_string, tk_sequence, tk_array,
  112.     tk_alias, tk_except, tk_longlong, tk_ulonglong, tk_longdouble, tk_wchar,
  113.     tk_wstring, tk_fixed);
  114.  
  115.   ITypeCode = interface
  116.     ['{D3D381F7-D944-11D1-AAEC-00C04FB17A72}']
  117.     function Kind: TCKind; stdcall;
  118.     procedure ContentType(out tc: ITypeCode); stdcall;
  119.     function DefaultIndex: Integer; stdcall;
  120.     procedure DiscriminatorType(out tc: ITypeCode); stdcall;
  121.     function Equal(const tc: ITypeCode): CorbaBoolean; stdcall;
  122.     function Id: PChar; stdcall;
  123.     function Length: CorbaULong; stdcall;
  124.     function MemberCount: CorbaULong; stdcall;
  125.     function MemberLabel(index: CorbaULong): PCorbaAny; stdcall;
  126.     function MemberName(index: CorbaULong): PChar; stdcall;
  127.     procedure MemberType(index: CorbaULong; out tc: ITypeCode); stdcall;
  128.     function Name: PChar; stdcall;
  129.     function Parameter(index: Integer): PCorbaAny; stdcall;
  130.     function ParameterCount: Integer; stdcall;
  131.   end;
  132.  
  133.   IBOA = interface
  134.     ['{47E946E6-BEA1-11D1-AA8A-00C04FB16F42}']
  135.     procedure ObjIsReady(const Skeleton: ISkeleton); stdcall;
  136.     procedure ImplIsReady; stdcall;
  137.     procedure Deactivate(const Skeleton: ISkeleton); stdcall;
  138.     function GetPrincipalLength(Skeleton: ISkeleton): Integer; stdcall;
  139.     function GetPrincipal(Skeleton: ISkeleton; Bytes: Pointer): Integer; stdcall;
  140.   end;
  141.  
  142.   TStructMember = record
  143.     Name: string;
  144.     TC: ITypeCode;
  145.   end;
  146.  
  147.   TStructMembers = array of TStructMember;
  148.  
  149.   IORB = interface
  150.     ['{47E946E7-BEA1-11D1-AA8A-00C04FB16F42}']
  151.     function Orb: PCorbaOrb stdcall;
  152.     procedure BOAInit(Argc: Integer; const Argv: TArgv; out BOA: IBOA); stdcall;
  153.     function ObjectToString(const Obj: IStub): PChar; stdcall;
  154.     procedure StringToObject(Str: PChar; out Obj: IStub); stdcall;
  155.     procedure Shutdown; stdcall;
  156.     procedure FindRepositoryTC(RepID: PChar; out TC: ITypeCode); stdcall;
  157.     procedure CreateTC(Kind: TCKind; out TC: ITypeCode); stdcall;
  158.     procedure CreateArrayTC(Bound: CorbaULong; const TC: ITypeCode;
  159.       out Result: ITypeCode); stdcall;
  160.     procedure CreateSequenceTC(Bound: CorbaULong; const TC: ITypeCode;
  161.       out Result: ITypeCode); stdcall;
  162.     function MakeAny(const TC: ITypeCode; VS: array of Variant): PCorbaAny; stdcall;
  163.     function DispatchStruct(Any: PCorbaAny; CallDesc: PCallDesc; Params: Pointer;
  164.       out Result: Variant): Integer; stdcall;
  165.     procedure CreateAliasTC(RepID: PChar; TypeName: PChar; const TC: ITypeCode; out Result: ITypeCode); stdcall;
  166.     procedure CreateStructTC(Kind: TCKind; RepId, Name: PChar; Members: TStructMembers; nMember: Integer; out Result: ITypeCode); stdcall;
  167.     procedure CreateObjRefTC(RepId, Name: PChar; out Result: ITypeCode); stdcall;
  168.   end;
  169.  
  170.   ISkeletonObject = interface
  171.     ['{47E946E8-BEA1-11D1-AA8A-00C04FB16F42}']
  172.     procedure GetSkeleton(out Skeleton: ISkeleton); stdcall;
  173.     procedure GetImplementation(out Impl: IUnknown); stdcall;
  174.     function Execute(Operation: PChar; const Strm: IMarshalInBuffer;
  175.       Cookie: Pointer): CorbaBoolean; stdcall;
  176.   end;
  177.  
  178.   IStubObject = interface
  179.     ['{47E946E9-BEA1-11D1-AA8A-00C04FB16F42}']
  180.     procedure GetStub(out stub :IStub); stdcall;
  181.   end;
  182.  
  183. type
  184.   TCopyUserExceptionProc = procedure (const InBuf: IMarshalInBuffer) of object; register;
  185.   TThrowUserExceptionProc = procedure of object; register;
  186.   TUserExceptionFactoryProc = function : PUserExceptionProxy; cdecl;
  187.  
  188. procedure InitORB(const Argv: TArgv; out Orb: IORB);
  189. procedure CorbaStringFree(Str: PChar);
  190. procedure CorbaWStringFree(Str: PWideChar);
  191. function CorbaDuplicateAny(Any: PCorbaAny): PCorbaAny;
  192. procedure CorbaReleaseAny(Any: PCorbaAny);
  193. procedure CorbaAnyType(Any: PCorbaAny; out TypeCode: ITypeCode);
  194. procedure CreateSkeleton(InterfaceName: PChar;
  195.   const DelphiObject: ISkeletonObject; Serialize: CorbaBoolean;
  196.   InstanceName, RepositoryID: PChar; ClientRefCount: CorbaBoolean;
  197.   out Skeleton: ISkeleton);
  198. procedure BindStub(RepositoryID, InstanceName, HostName: PChar; const Orb: IORB;
  199.   RefCountServer: CorbaBoolean; out Stub: IStub);
  200. function VariantToAny(Value: PVariant): PCorbaAny;
  201. function AnyToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
  202. function SequenceToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
  203. function CreateUserException(copy: TCopyUserExceptionProc; throw: TThrowUserExceptionProc): PUserExceptionProxy;
  204. function RegisterUserException(Name, RepositoryID: PChar; Factory: TUserExceptionFactoryProc): PExceptionDescription;
  205. procedure UnRegisterUserException(Description: PExceptionDescription);
  206.  
  207. implementation
  208.  
  209. uses CorbCnst;
  210.  
  211. var
  212.   OrbDll: THandle = 0;
  213.  
  214. type
  215.   TInitOrbProc = procedure(Argc: Integer; const Argv: TArgv; out Orb: IORB); stdcall;
  216.   TCorbaStringFreeProc = procedure(Str: PChar); stdcall;
  217.   TCorbaWStringFreeProc = procedure(Str: PWideChar); stdcall;
  218.   TCorbaDuplicateAnyProc = function(Any: PCorbaAny): PCorbaAny; stdcall;
  219.   TCorbaReleaseAnyProc = procedure(Any: PCorbaAny); stdcall;
  220.   TCorbaAnyTypeProc = procedure (Any: PCorbaAny; out TypeCode: ITypeCode); stdcall;
  221.   TCreateSkeletonProc = procedure(InterfaceName: PChar;
  222.     const DelphiObject: ISkeletonObject; Serialize: CorbaBoolean;
  223.     InstanceName, RepositoryID: PChar; ClientRefCount: CorbaBoolean;
  224.     out Skeleton: ISkeleton); stdcall;
  225.   TBindStubProc = procedure(RepositoryID, InstanceID, HostName: PChar; const Orb: IORB;
  226.     RefCountServer: CorbaBoolean; out Stub: IStub); stdcall;
  227.   TVariantToAnyProc = function(Value: PVariant): PCorbaAny; stdcall;
  228.   TAnyToVariantProc = function(Value: PCorbaAny; OV: PVariant): WordBool; stdcall;
  229.   TPascalClearVariantProc = procedure (var V: Variant); stdcall;
  230.   TPascalChangeTypeProc = function (var Dest, Source: Variant; VTCode: Integer): WordBool; stdcall;
  231.   TInitAnyCallbacks = procedure (pcv: TPascalClearVariantProc; pct: TPascalChangeTypeProc); stdcall;
  232.   TCreateUserExceptionProc = function (copy: TCopyUserExceptionProc; throw: TThrowUserExceptionProc): PUserExceptionProxy; stdcall;
  233.   TRegisterUserExceptionProc = function (Name, RepositoryID: PChar; Factory: TUserExceptionFactoryProc): PExceptionDescription; stdcall;
  234.   TUnRegisterUserExceptionProc = procedure (Description: PExceptionDescription); stdcall;
  235.  
  236. procedure PascalClearVariantImpl(var V: Variant); stdcall;
  237. begin
  238.   V := Unassigned;
  239. end;
  240.  
  241. function PascalChangeTypeImpl(var Dest, Source: Variant; VTCode: Integer): WordBool; stdcall;
  242. begin
  243.   Result := True;
  244.   try
  245.     Dest := VarAsType(Source, VTCode);
  246.   except
  247.     Result := False;
  248.   end;
  249. end;
  250.  
  251. var
  252.   InitOrbProc: TInitOrbProc;
  253.   CorbaStringFreeProc: TCorbaStringFreeProc;
  254.   CorbaWStringFreeProc: TCorbaWStringFreeProc;
  255.   CorbaReleaseAnyProc: TCorbaReleaseAnyProc;
  256.   CorbaAnyTypeProc: TCorbaAnyTypeProc;
  257.   CorbaDuplicateAnyProc: TCorbaDuplicateAnyProc;
  258.   CreateSkeletonProc: TCreateSkeletonProc;
  259.   BindStubProc: TBindStubProc;
  260.   VariantToAnyProc: TVariantToAnyProc;
  261.   AnyToVariantProc: TAnyToVariantProc;
  262.   SequenceToVariantProc: TAnyToVariantProc;
  263.   CreateUserExceptionProc: TCreateUserExceptionProc;
  264.   RegisterUserExceptionProc: TRegisterUserExceptionProc;
  265.   UnRegisterUserExceptionProc: TUnRegisterUserExceptionProc;
  266.  
  267. procedure LoadOrbProcs;
  268. const
  269.   orbpas = 'orbpas50.dll';
  270. var
  271.   InitAnyCallbacks: TInitAnyCallbacks;
  272. begin
  273.   if OrbDll > HINSTANCE_ERROR then Exit;
  274.   OrbDll := LoadLibrary(PChar(orbpas));
  275.   if OrbDll <= HINSTANCE_ERROR then
  276.     raise Exception.CreateFmt('%s: %s', [SysErrorMessage(GetLastError), orbpas]);
  277.   @InitORBProc := GetProcAddress(OrbDll, 'ORB_init');
  278.   @CorbaStringFreeProc := GetProcAddress(OrbDll, 'String_Free');
  279.   @CorbaWStringFreeProc := GetProcAddress(OrbDll, 'WString_Free');
  280.   @CorbaDuplicateAnyProc := GetProcAddress(OrbDll, 'DuplicateAny');
  281.   @CorbaReleaseAnyProc := GetProcAddress(OrbDll, 'ReleaseAny');
  282.   @CorbaAnyTypeProc := GetProcAddress(OrbDll, 'AnyType');
  283.   @CreateSkeletonProc := GetProcAddress(OrbDll, 'DelphiServant_Create');
  284.   @BindStubProc := GetProcAddress(OrbDll, 'DelphiStub_Bind');
  285.   @VariantToAnyProc := GetProcAddress(OrbDll, 'VariantToAny');
  286.   @AnyToVariantProc := GetProcAddress(OrbDll, 'Any2Variant');
  287.   @SequenceToVariantProc := GetProcAddress(OrbDll, 'Sequence2Variant');
  288.   @InitAnyCallbacks := GetProcAddress(OrbDll, 'InitAnyCallbacks');
  289.   if Assigned(InitAnyCallbacks) then
  290.     InitAnyCallbacks(PascalClearVariantImpl, PascalChangeTypeImpl);
  291.   @CreateUserExceptionProc := GetProcAddress(OrbDll, 'CreateDelphiException');
  292.   @RegisterUserExceptionProc := GetProcAddress(OrbDll, 'RegisterDelphiException');
  293.   @UnRegisterUserExceptionProc := GetProcAddress(OrbDll, 'UnRegisterDelphiException');
  294. end;
  295.  
  296. procedure ValidateProc(var Proc);
  297. begin
  298.   if Pointer(Proc) = nil then raise Exception.CreateRes(@sCorbaNotInitialized);
  299. end;
  300.  
  301. procedure InitORB(const Argv: TArgv; out Orb: IORB);
  302. begin
  303.   LoadOrbProcs;
  304.   ValidateProc(InitORBProc);
  305.   InitORBProc(Length(Argv), Argv, Orb);
  306. end;
  307.  
  308. procedure CorbaStringFree(Str: PChar);
  309. begin
  310.   ValidateProc(CorbaStringFreeProc);
  311.   CorbaStringFreeProc(Str);
  312. end;
  313.  
  314. procedure CorbaWStringFree(Str: PWideChar);
  315. begin
  316.   ValidateProc(CorbaWStringFreeProc);
  317.   CorbaWStringFreeProc(Str);
  318. end;
  319.  
  320. function CorbaDuplicateAny(Any: PCorbaAny): PCorbaAny;
  321. begin
  322.   ValidateProc(CorbaDuplicateAnyProc);
  323.   Result := CorbaDuplicateAnyProc(Any);
  324. end;
  325.  
  326. procedure CorbaReleaseAny(Any: PCorbaAny);
  327. begin
  328.   ValidateProc(CorbaReleaseAnyProc);
  329.   CorbaReleaseAnyProc(Any);
  330. end;
  331.  
  332. procedure CorbaAnyType(Any: PCorbaAny; out TypeCode: ITypeCode);
  333. begin
  334.   ValidateProc(CorbaAnyTypeProc);
  335.   CorbaAnyTypeProc(Any, TypeCode);
  336. end;
  337.  
  338. procedure CreateSkeleton(InterfaceName: PChar;
  339.   const DelphiObject: ISkeletonObject; Serialize: CorbaBoolean;
  340.   InstanceName, RepositoryID: PChar; ClientRefCount: CorbaBoolean;
  341.   out Skeleton: ISkeleton);
  342. begin
  343.   ValidateProc(CreateSkeletonProc);
  344.   CreateSkeletonProc(InterfaceName, DelphiObject, Serialize, InstanceName,
  345.     RepositoryID, ClientRefCount, Skeleton);
  346. end;
  347.  
  348. procedure BindStub(RepositoryID, InstanceName, HostName: PChar; const Orb: IORB;
  349.   RefCountServer: CorbaBoolean; out Stub: IStub);
  350. begin
  351.   ValidateProc(BindStubProc);
  352.   BindStubProc(RepositoryID, InstanceName, HostName, Orb, RefCountServer, Stub);
  353. end;
  354.  
  355. function VariantToAny(Value: PVariant): PCorbaAny;
  356. begin
  357.   ValidateProc(VariantToAnyProc);
  358.   Result := VariantToAnyProc(Value);
  359. end;
  360.  
  361. function AnyToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
  362. begin
  363.   ValidateProc(AnyToVariantProc);
  364.   Result := AnyToVariantProc(Value, OV);
  365. end;
  366.  
  367. function SequenceToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
  368. begin
  369.   ValidateProc(SequenceToVariantProc);
  370.   Result := SequenceToVariantProc(Value, OV);
  371. end;
  372.  
  373. function CreateUserException(copy: TCopyUserExceptionProc; throw: TThrowUserExceptionProc): PUserExceptionProxy;
  374. begin
  375.   ValidateProc(CreateUserExceptionProc);
  376.   Result := CreateUserExceptionProc(copy, throw);
  377. end;
  378.  
  379. function RegisterUserException(Name, RepositoryID: PChar; Factory: TUserExceptionFactoryProc): PExceptionDescription;
  380. begin
  381.   ValidateProc(RegisterUserExceptionProc);
  382.   Result := RegisterUserExceptionProc(Name, RepositoryID, Factory);
  383. end;
  384.  
  385. procedure UnRegisterUserException(Description: PExceptionDescription);
  386. begin
  387.   ValidateProc(UnRegisterUserExceptionProc);
  388.   UnRegisterUserExceptionProc(Description);
  389. end;
  390.  
  391. initialization
  392.  
  393. finalization
  394.   // jmt.  Do not unload because threads created by orb_br.dll
  395.   // may be active. 
  396.   // if OrbDll > HINSTANCE_ERROR then FreeLibrary(OrbDll);
  397.  
  398. end.
  399.