------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2003-2022, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 3, or (at your option) any -- -- later version. This library is distributed in the hope that it will be -- -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Containers.Indefinite_Ordered_Sets; with Ada.Directories; with Ada.Environment_Variables; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Text_IO; with AWS.Containers.Key_Value; with AWS.Utils; with SOAP.Types; with SOAP.Utils; with SOAP.WSDL.Name_Spaces; with SOAP.WSDL.Schema; with WSDL2AWS.WSDL.Types; with wsdl2aws_templates; pragma Unreferenced (wsdl2aws_templates); package body WSDL2AWS.Generator is use Ada; use type Templates.Tag; -- All the templates files used to generate the type code Template_Enum_Ads : constant String := "s-type-enum.tads"; Template_Enum_Adb : constant String := "s-type-enum.tadb"; Template_Enum_Types : constant String := "s-type-enum-types.tads"; Template_Derived_Ads : constant String := "s-type-derived.tads"; Template_Derived_Types : constant String := "s-type-derived-types.tads"; Template_Array_Ads : constant String := "s-type-array.tads"; Template_Array_Types : constant String := "s-type-array-types.tads"; Template_Record_Ads : constant String := "s-type-record.tads"; Template_Record_Adb : constant String := "s-type-record.tadb"; Template_Record_Types : constant String := "s-type-record-types.tads"; Template_Types_Ads : constant String := "s-types.tads"; Template_Types_Adb : constant String := "s-types.tadb"; Template_Stub_Types_Ads : constant String := "s-stub-types.tads"; Template_Main_Adb : constant String := "s-main.tadb"; Template_Root_Ads : constant String := "s-root.tads"; Template_NS_Pkg_Ads : constant String := "s-name-space-pkg.tads"; procedure Generate (O : Object; Filename : String; Template : String; Translations : Templates.Translate_Set); -- Render a template with associated translations into Filename procedure Generate (O : Object; File : Text_IO.File_Type; Template : String; Translations : Templates.Translate_Set); -- Render a template with associated translations into File procedure Insert_Types_Def (O : in out Object; Template : String; Translations : Templates.Translate_Set); -- Insert a type chunk into the global types definitions procedure Generate_Params (O : Object; N : WSDL.Parameters.P_Set; P_Decl : in out Templates.Tag; P_Name : in out Templates.Tag; P_Kind : in out Templates.Tag; P_Min : in out Templates.Tag; P_Max : in out Templates.Tag; P_Compound_Size : in out Templates.Tag; P_Type : in out Templates.Tag; P_Base_Type : in out Templates.Tag; P_Root_Type : in out Templates.Tag; P_Root_Type_Kind : in out Templates.Tag; P_Type_Name : in out Templates.Tag; P_Type_Kind : in out Templates.Tag; P_Ada_Type : in out Templates.Tag; P_Q_Name : in out Templates.Tag; P_NS_Name : in out Templates.Tag; P_NS_Value : in out Templates.Tag; P_Elt_NS_Name : in out Templates.Tag; P_Elt_NS_Value : in out Templates.Tag); -- Generate all tag information for the parameters pointed to by N function Type_Name (O : Object; N : WSDL.Parameters.P_Set) return String; -- Returns the name of the type for parameter on node N package String_Store is new Ada.Containers.Indefinite_Ordered_Sets (String); function Format_Name (O : Object; Name : String) return String; -- Returns Name formated with the Ada style if O.Ada_Style is true and -- Name unchanged otherwise. procedure Put_Types (O : in out Object; Proc : String; SOAPAction : String; Input : WSDL.Parameters.P_Set; Output : WSDL.Parameters.P_Set); -- This must be called to create the data types for composite objects function Result_Type (O : Object; Proc : String; Output : WSDL.Parameters.P_Set) return String; -- Returns the result type given the output parameters function Is_Simple_Wrapped_Parameter (O : Object; P : WSDL.Parameters.P_Set) return Boolean; -- Returns True if P is a record with a least one field and we are in -- Document style binding. function To_Unit_Name (Filename : String) return String; -- Returns the unit name given a filename following the GNAT -- naming scheme. procedure Output_Schema_Definition (O : in out Object; Key, Value : String); -- This is just a key/value pair to record schema definitions for the -- runtime. The information format is: -- -- proc.param -> type_name -- record.field -> type_name -- type_name -> type_name | @enum -- -- The special tag @enum above is to be able to differentiate between -- xsd:string and enumeration literal. -- -- And some special keys: -- -- @binding.style -> [rcp|document] -- @.encoding -> [literal/encoded] (encoding for proc name) -- @param1[:param_n] -> operation (operation for signature) function Is_String (N : WSDL.Parameters.P_Set) return Boolean; -- Returns True is N is a string S_Gen : SOAP.WSDL.Schema.Definition; -- Keep record of generated schema definitions to avoid dupliace NS_Generated : String_Store.Set; -- Keep record generated name-space renaming in types package to avoid -- duplicate. Types_Gen : String_Store.Set; -- Stub generator routines package Stub is procedure Start_Service (O : in out Object; Name : String; Root_Documentation : String; Documentation : String; Location : String); procedure End_Service (O : in out Object; Name : String); procedure New_Procedure (O : in out Object; Proc : String; Documentation : String; SOAPAction : String; Wrapper_Name : String; Namespace : SOAP.Name_Space.Object; Input : WSDL.Parameters.P_Set; Output : WSDL.Parameters.P_Set; Fault : WSDL.Parameters.P_Set); end Stub; -- Skeleton generator routines package Skel is procedure Start_Service (O : in out Object; Name : String; Root_Documentation : String; Documentation : String; Location : String); procedure End_Service (O : in out Object; Name : String); procedure New_Procedure (O : in out Object; Proc : String; Documentation : String; SOAPAction : String; Wrapper_Name : String; Namespace : SOAP.Name_Space.Object; Input : WSDL.Parameters.P_Set; Output : WSDL.Parameters.P_Set; Fault : WSDL.Parameters.P_Set); end Skel; -- Callback generator routines package CB is procedure Start_Service (O : in out Object; Name : String; Root_Documentation : String; Documentation : String; Location : String); procedure End_Service (O : in out Object; Name : String); procedure New_Procedure (O : in out Object; Proc : String; Documentation : String; SOAPAction : String; Wrapper_Name : String; Namespace : SOAP.Name_Space.Object; Input : WSDL.Parameters.P_Set; Output : WSDL.Parameters.P_Set; Fault : WSDL.Parameters.P_Set); end CB; -- Simple name set used to keep record of all generated types package Name_Set is procedure Add (Name : String); -- Add new name into the set function Exists (Name : String) return Boolean; -- Returns true if Name is in the set end Name_Set; --------------- -- Ada_Style -- --------------- procedure Ada_Style (O : in out Object) is begin O.Ada_Style := True; end Ada_Style; -------------- -- Add_TagV -- -------------- procedure Add_TagV (Set : in out Templates.Translate_Set; Assoc_Name, Tag_Name : String) is T : Templates.Tag; begin if Templates.Exists (Set, Assoc_Name) then T := Templates.Get (Templates.Get (Set, Assoc_Name)); end if; T := T & Tag_Name; Templates.Insert (Set, Templates.Assoc (Assoc_Name, T)); end Add_TagV; procedure Add_TagV (Set : in out Templates.Translate_Set; Assoc_Name : String; Value : Boolean) is T : Templates.Tag; begin if Templates.Exists (Set, Assoc_Name) then T := Templates.Get (Templates.Get (Set, Assoc_Name)); end if; T := T & Value; Templates.Insert (Set, Templates.Assoc (Assoc_Name, T)); end Add_TagV; procedure Add_TagV (Set : in out Templates.Translate_Set; Assoc_Name : String; Tag : Templates.Tag) is R : Templates.Tag; begin if Templates.Exists (Set, Assoc_Name) then declare T : constant Templates.Tag := Templates.Get (Templates.Get (Set, Assoc_Name)); begin R := T & Tag; end; else R := +Tag; end if; Templates.Insert (Set, Templates.Assoc (Assoc_Name, R)); end Add_TagV; -------- -- CB -- -------- package body CB is separate; ------------- -- CVS_Tag -- ------------- procedure CVS_Tag (O : in out Object) is begin O.CVS_Tag := True; end CVS_Tag; ----------- -- Debug -- ----------- procedure Debug (O : in out Object) is begin O.Debug := True; end Debug; ------------------------ -- Disable_Time_Stamp -- ------------------------ procedure Disable_Time_Stamp (O : in out Object) is begin O.Stamp := False; end Disable_Time_Stamp; ----------------- -- End_Service -- ----------------- overriding procedure End_Service (O : in out Object; Name : String) is begin -- Generate binding style information Output_Schema_Definition (O, Key => "@binding.style", Value => SOAP.WSDL.Schema.Binding_Style'Image (O.Style)); -- Generate the Schema information for C in WSDL.Types.Get_Schema_Definition.Iterate loop Output_Schema_Definition (O, Key => AWS.Containers.Key_Value.Key (C), Value => AWS.Containers.Key_Value.Element (C)); end loop; Generate (O, Characters.Handling.To_Lower (Format_Name (O, Name)) & "-types.ads", Template_Types_Ads, O.Type_S_Trans); Generate (O, Characters.Handling.To_Lower (Format_Name (O, Name)) & "-types.adb", Template_Types_Adb, O.Type_B_Trans); -- Stub if O.Gen_Stub then Stub.End_Service (O, Name); end if; -- Skeleton if O.Gen_Skel then Skel.End_Service (O, Name); end if; -- Callbacks if O.Gen_CB then CB.End_Service (O, Name); end if; end End_Service; -------------- -- Endpoint -- -------------- procedure Endpoint (O : in out Object; URL : String) is begin O.Endpoint := To_Unbounded_String (URL); end Endpoint; ----------------- -- Format_Name -- ----------------- function Format_Name (O : Object; Name : String) return String is function Ada_Format (Name : String) return String; -- Returns Name with the Ada style ---------------- -- Ada_Format -- ---------------- function Ada_Format (Name : String) return String is Result : Unbounded_String; begin if not O.Ada_Style then -- No need to reformat this name return Name; end if; for K in Name'Range loop if K = Name'First then Append (Result, Characters.Handling.To_Upper (Name (K))); elsif Characters.Handling.Is_Upper (Name (K)) and then not Characters.Handling.Is_Upper (Name (K - 1)) and then K > Name'First and then Name (K - 1) not in '_' | '.' | '-' and then K < Name'Last and then Name (K + 1) not in '_' | '.' | '-' then Append (Result, "_" & Name (K)); else Append (Result, Name (K)); end if; end loop; return To_String (Result); end Ada_Format; Ada_Name : constant String := Ada_Format (Name); begin if SOAP.Utils.Is_Ada_Reserved_Word (Name) then return "v_" & Ada_Name; else return Ada_Name; end if; end Format_Name; ------------ -- Gen_CB -- ------------ procedure Gen_CB (O : in out Object) is begin O.Gen_CB := True; end Gen_CB; ---------------------- -- Gen_Safe_Pointer -- ---------------------- procedure Gen_Safe_Pointer (O : in out Object) is begin O.Sp := True; end Gen_Safe_Pointer; -------------- -- Generate -- -------------- procedure Generate (O : Object; File : Text_IO.File_Type; Template : String; Translations : Templates.Translate_Set) is use type Templates.Translate_Set; use type SOAP.WSDL.Schema.Binding_Style; Template_Dir : constant String := Environment_Variables.Value ("AWS_TEMPLATE_FILES", Default => "./"); Template_File : constant String := Directories.Compose (Template_Dir, Template); Final_T : Templates.Translate_Set := Translations; begin Final_T := Final_T & Templates.Assoc ("AWS_VERSION", AWS.Version) & Templates.Assoc ("SOAP_VERSION", SOAP.Version) & Templates.Assoc ("OPTIONS", To_String (O.Options)) & Templates.Assoc ("WSDL2AWS_VERSION", WSDL2AWS.Version) & Templates.Assoc ("HTTP_VERSION", HTTP_Protocol'Image (O.HTTP_Version)) & Templates.Assoc ("HTTP_PROXY", O.Proxy) & Templates.Assoc ("HTTP_PROXY_USER", O.P_User) & Templates.Assoc ("HTTP_PROXY_PASSWORD", O.P_Pwd) & Templates.Assoc ("IS_RPC", O.Style = SOAP.WSDL.Schema.RPC) & Templates.Assoc ("DEBUG", O.Debug) & Templates.Assoc ("TRACE", O.Traces) & Templates.Assoc ("SERVICE_NAME", O.Unit) & Templates.Assoc ("SAFE_POINTER", O.Sp); if Types_Spec (O) /= "" then Add_TagV (Final_T, "USER_UNITS", Types_Spec (O, With_Clause => True)); end if; if Procs_Spec (O) /= "" and then Procs_Spec (O) /= Types_Spec (O) then Add_TagV (Final_T, "USER_UNITS", Types_Spec (O, With_Clause => True)); end if; if Directories.Exists (Template_File) then Text_IO.Put (File, Templates.Parse (Template_File, Final_T)); else Text_IO.Put (File, Templates.Parse (Template, Final_T)); end if; end Generate; procedure Generate (O : Object; Filename : String; Template : String; Translations : Templates.Translate_Set) is File : Text_IO.File_Type; begin Text_IO.Create (File, Text_IO.Out_File, Filename); Generate (O, File, Template, Translations); Text_IO.Close (File); end Generate; --------------------- -- Generate_Params -- --------------------- procedure Generate_Params (O : Object; N : WSDL.Parameters.P_Set; P_Decl : in out Templates.Tag; P_Name : in out Templates.Tag; P_Kind : in out Templates.Tag; P_Min : in out Templates.Tag; P_Max : in out Templates.Tag; P_Compound_Size : in out Templates.Tag; P_Type : in out Templates.Tag; P_Base_Type : in out Templates.Tag; P_Root_Type : in out Templates.Tag; P_Root_Type_Kind : in out Templates.Tag; P_Type_Name : in out Templates.Tag; P_Type_Kind : in out Templates.Tag; P_Ada_Type : in out Templates.Tag; P_Q_Name : in out Templates.Tag; P_NS_Name : in out Templates.Tag; P_NS_Value : in out Templates.Tag; P_Elt_NS_Name : in out Templates.Tag; P_Elt_NS_Value : in out Templates.Tag) is use type WSDL.Types.Kind; begin P_Decl := P_Decl & Format_Name (O, To_String (N.Name)); P_Name := P_Name & To_String (N.Name); P_Kind := P_Kind & WSDL.Types.Kind'Image (N.Mode); P_Min := P_Min & N.Min; P_Max := P_Max & N.Max; P_Type := P_Type & WSDL.Types.Name (N.Typ, True); P_Type_Name := P_Type_Name & Format_Name (O, WSDL.Types.Name (N.Typ, False)); P_Q_Name := P_Q_Name & SOAP.Utils.To_Name (WSDL.Types.Name (N.Typ, True)); P_Ada_Type := P_Ada_Type & Type_Name (O, N); if N.Mode = WSDL.Types.K_Simple then P_Type_Kind := P_Type_Kind & SOAP.WSDL.To_Type (WSDL.Types.Name (N.Typ))'Image; else P_Type_Kind := P_Type_Kind & ""; end if; if N.Mode /= WSDL.Types.K_Derived then P_Base_Type := P_Base_Type & ""; P_Root_Type_Kind := P_Root_Type_Kind & ""; end if; if N.Mode in WSDL.Types.Compound_Type then P_Compound_Size := P_Compound_Size & WSDL.Parameters.Length (N); else P_Compound_Size := P_Compound_Size & 0; end if; declare Def : constant WSDL.Types.Definition := WSDL.Types.Find (N.Typ); T_Name : constant String := WSDL.Types.Name (Def.Ref); begin case N.Mode is when WSDL.Types.K_Simple => P_Root_Type := P_Root_Type & SOAP.WSDL.Set_Type (SOAP.WSDL.To_Type (T_Name)); when WSDL.Types.K_Derived => P_Root_Type := P_Root_Type & SOAP.WSDL.Set_Type (SOAP.WSDL.To_Type (WSDL.Types.Root_Type_For (Def))); declare P_Name : constant String := WSDL.Types.Name (Def.Parent, True); B_Name : constant String := (if SOAP.WSDL.Is_Standard (P_Name) then WSDL.Types.Name (N.Typ, True) else SOAP.Utils.To_Name (P_Name)); begin P_Base_Type := P_Base_Type & B_Name; P_Root_Type_Kind := P_Root_Type_Kind & SOAP.WSDL.To_Type (WSDL.Types.Root_Type_For (Def))'Image; end; when WSDL.Types.K_Enumeration => P_Root_Type := P_Root_Type & "SOAP.Types.SOAP_Enumeration"; when WSDL.Types.K_Array => P_Root_Type := P_Root_Type & "SOAP.Types.SOAP_Array"; when WSDL.Types.K_Record => P_Root_Type := P_Root_Type & "SOAP.Types.SOAP_Record"; end case; end; declare NS : constant SOAP.Name_Space.Object := SOAP.WSDL.Name_Spaces.Get (SOAP.Utils.NS (To_String (N.Elmt_Name))); begin P_Elt_NS_Name := P_Elt_NS_Name & SOAP.Name_Space.Name (NS); P_Elt_NS_Value := P_Elt_NS_Value & SOAP.Name_Space.Value (NS); end; declare NS : constant SOAP.Name_Space.Object := WSDL.Types.NS (N.Typ); begin P_NS_Name := P_NS_Name & SOAP.Name_Space.Name (NS); P_NS_Value := P_NS_Value & SOAP.Name_Space.Value (NS); end; end Generate_Params; ------------------ -- HTTP_Version -- ------------------ procedure HTTP_Version (O : in out Object; Protocol_Version : HTTP_Protocol) is begin O.HTTP_Version := Protocol_Version; end HTTP_Version; ---------------------- -- Insert_Types_Def -- ---------------------- procedure Insert_Types_Def (O : in out Object; Template : String; Translations : Templates.Translate_Set) is Template_Dir : constant String := Environment_Variables.Value ("AWS_TEMPLATE_FILES", Default => "./"); Template_File : constant String := Directories.Compose (Template_Dir, Template); T_Name : constant String := Templates.Get (if Templates.Exists (Translations, "TYPE_NAME") then Templates.Get (Translations, "TYPE_NAME") else Templates.Get (Translations, "PROC")); Key : constant String := T_Name & '@' & Template; begin if not Types_Gen.Contains (Key) then if Directories.Exists (Template_File) then Add_TagV (O.Type_S_Trans, "TYPE_DECLS", Templates.Parse (Template_File, Translations)); else Add_TagV (O.Type_S_Trans, "TYPE_DECLS", Templates.Parse (Template, Translations)); end if; Types_Gen.Insert (Key); end if; end Insert_Types_Def; --------------------------------- -- Is_Simple_Wrapped_Parameter -- --------------------------------- function Is_Simple_Wrapped_Parameter (O : Object; P : WSDL.Parameters.P_Set) return Boolean is use type SOAP.WSDL.Schema.Binding_Style; use type WSDL.Parameters.P_Set; use type WSDL.Types.Kind; begin return P /= null and then P.Mode = WSDL.Types.K_Record and then O.Style = SOAP.WSDL.Schema.Document and then WSDL.Parameters.Length (P.P) >= 1; end Is_Simple_Wrapped_Parameter; --------------- -- Is_String -- --------------- function Is_String (N : WSDL.Parameters.P_Set) return Boolean is use all type SOAP.WSDL.Parameter_Type; use type WSDL.Types.Kind; begin return N.Mode = WSDL.Types.K_Simple and then SOAP.WSDL.To_Type (WSDL.Types.Name (N.Typ)) = P_String; end Is_String; ---------- -- Main -- ---------- procedure Main (O : in out Object; Name : String) is begin O.Main := To_Unbounded_String (Name); end Main; -------------- -- Name_Set -- -------------- package body Name_Set is separate; ------------------- -- New_Procedure -- ------------------- overriding procedure New_Procedure (O : in out Object; Proc : String; Documentation : String; SOAPAction : String; Wrapper_Name : String; Namespace : SOAP.Name_Space.Object; Input : WSDL.Parameters.P_Set; Output : WSDL.Parameters.P_Set; Fault : WSDL.Parameters.P_Set) is use type SOAP.WSDL.Schema.Binding_Style; use type WSDL.Parameters.P_Set; procedure Generate_Call_Signature (P : WSDL.Parameters.P_Set); -- Generate a call signature for Proc. This is needed to be able to map -- this signature to the corresponding SOAP operation when using the -- Document style binding. The signature is the key with the following -- format: '@' & & [:] procedure Generate_Schema (Prefix : String; P : WSDL.Parameters.P_Set); -- Generate the fully qualified name for the parameters. This is needed -- for the document/literal binding to match the payload with the -- corresponding data type. procedure Add_Proc_Tag (Tag_Name : String; Value : String); procedure Add_Proc_Tag (Tag_Name : String; Value : Boolean); procedure Add_Proc_Tag (Tag_Name : String; Value : Templates.Tag); -- Add a tag for all procedure templates procedure Generate_Input_Params (O : in out Object; Input : WSDL.Parameters.P_Set); -- Generate the input parameters NAME / TYPE procedure Generate_Output_Params (O : in out Object; Proc : String; Output : WSDL.Parameters.P_Set); -- Output procedure header into File. The terminating ';' or -- 'is' is outputed depending on Spec value. If Mode is in -- Con_Stub_Header the connection based spec is generated, -- otherwise it is the endpoint based. ------------------ -- Add_Proc_Tag -- ------------------ procedure Add_Proc_Tag (Tag_Name : String; Value : String) is begin Add_TagV (O.Stub_S_Trans, Tag_Name, Value); Add_TagV (O.Stub_B_Trans, Tag_Name, Value); Add_TagV (O.Skel_S_Trans, Tag_Name, Value); Add_TagV (O.Skel_B_Trans, Tag_Name, Value); end Add_Proc_Tag; procedure Add_Proc_Tag (Tag_Name : String; Value : Boolean) is begin Add_TagV (O.Stub_S_Trans, Tag_Name, Value); Add_TagV (O.Stub_B_Trans, Tag_Name, Value); Add_TagV (O.Skel_S_Trans, Tag_Name, Value); Add_TagV (O.Skel_B_Trans, Tag_Name, Value); end Add_Proc_Tag; procedure Add_Proc_Tag (Tag_Name : String; Value : Templates.Tag) is begin Add_TagV (O.Stub_S_Trans, Tag_Name, Value); Add_TagV (O.Stub_B_Trans, Tag_Name, Value); Add_TagV (O.Skel_S_Trans, Tag_Name, Value); Add_TagV (O.Skel_B_Trans, Tag_Name, Value); end Add_Proc_Tag; ----------------------------- -- Generate_Call_Signature -- ----------------------------- procedure Generate_Call_Signature (P : WSDL.Parameters.P_Set) is Sig : Unbounded_String; N : WSDL.Parameters.P_Set := P; begin while N /= null loop if Sig = Null_Unbounded_String then Append (Sig, "@"); else Append (Sig, ":"); end if; Append (Sig, SOAP.Utils.No_NS (To_String (N.Elmt_Name))); N := N.Next; end loop; Output_Schema_Definition (O, To_String (Sig), To_String (O.Prefix) & Proc); end Generate_Call_Signature; --------------------------- -- Generate_Input_Params -- --------------------------- procedure Generate_Input_Params (O : in out Object; Input : WSDL.Parameters.P_Set) is use type WSDL.Types.Kind; Parameter_Name : Templates.Tag; Parameter_Type : Templates.Tag; P_Decl : Templates.Tag; P_Name : Templates.Tag; P_Kind : Templates.Tag; P_Min : Templates.Tag; P_Max : Templates.Tag; P_Compound_Size : Templates.Tag; P_Type : Templates.Tag; P_Base_Type : Templates.Tag; P_Root_Type : Templates.Tag; P_Root_Type_Kind : Templates.Tag; P_Type_Name : Templates.Tag; P_Type_Kind : Templates.Tag; P_Ada_Type : Templates.Tag; P_Q_Name : Templates.Tag; P_NS_Name : Templates.Tag; P_NS_Value : Templates.Tag; P_Elt_NS_Name : Templates.Tag; P_Elt_NS_Value : Templates.Tag; N : WSDL.Parameters.P_Set; begin if Is_Simple_Wrapped_Parameter (O, Input) then N := Input.P; else N := Input; end if; while N /= null loop declare Q_Name : constant String := SOAP.Utils.To_Name (WSDL.Types.Name (N.Typ, NS => True)); T_Name : constant String := WSDL.Types.Name (N.Typ); begin Parameter_Name := Parameter_Name & Format_Name (O, To_String (N.Name)); case N.Mode is when WSDL.Types.K_Simple => Parameter_Type := Parameter_Type & SOAP.WSDL.To_Ada (SOAP.WSDL.To_Type (T_Name)); when WSDL.Types.K_Enumeration => Parameter_Type := Parameter_Type & (T_Name & "_Type"); when WSDL.Types.K_Derived => Parameter_Type := Parameter_Type & (Q_Name & "_Type"); when WSDL.Types.K_Array => Parameter_Type := Parameter_Type & (Format_Name (O, T_Name) & "_Type"); when WSDL.Types.K_Record => Parameter_Type := Parameter_Type & (Format_Name (O, T_Name) & "_Type"); end case; N := N.Next; end; end loop; Add_Proc_Tag ("PARAMETER_NAME", Parameter_Name); Add_Proc_Tag ("PARAMETER_TYPE", Parameter_Type); -- Parameters N := Input; while N /= null loop Generate_Params (O, N, P_Decl, P_Name, P_Kind, P_Min, P_Max, P_Compound_Size, P_Type, P_Base_Type, P_Root_Type, P_Root_Type_Kind, P_Type_Name, P_Type_Kind, P_Ada_Type, P_Q_Name, P_NS_Name, P_NS_Value, P_Elt_NS_Name, P_Elt_NS_Value); N := N.Next; end loop; Add_TagV (O.Stub_B_Trans, "IP_DECL_NAME", P_Decl); Add_TagV (O.Stub_B_Trans, "IP_NAME", P_Name); Add_TagV (O.Stub_B_Trans, "IP_KIND", P_Kind); Add_TagV (O.Stub_B_Trans, "IP_MIN", P_Min); Add_TagV (O.Stub_B_Trans, "IP_MAX", P_Max); Add_TagV (O.Stub_B_Trans, "IP_COMPOUND_SIZE", P_Compound_Size); Add_TagV (O.Stub_B_Trans, "IP_TYPE", P_Type); Add_TagV (O.Stub_B_Trans, "IP_BASE_TYPE", P_Base_Type); Add_TagV (O.Stub_B_Trans, "IP_ROOT_TYPE", P_Root_Type); Add_TagV (O.Stub_B_Trans, "IP_ROOT_TYPE_KIND", P_Root_Type_Kind); Add_TagV (O.Stub_B_Trans, "IP_TYPE_NAME", P_Type_Name); Add_TagV (O.Stub_B_Trans, "IP_TYPE_KIND", P_Type_Kind); Add_TagV (O.Stub_B_Trans, "IP_ADA_TYPE", P_Ada_Type); Add_TagV (O.Stub_B_Trans, "IP_Q_NAME", P_Q_Name); Add_TagV (O.Stub_B_Trans, "IP_NS_NAME", P_NS_Name); Add_TagV (O.Stub_B_Trans, "IP_NS_VALUE", P_NS_Value); Add_TagV (O.Stub_B_Trans, "IP_ELT_NS_NAME", P_Elt_NS_Name); Add_TagV (O.Stub_B_Trans, "IP_ELT_NS_VALUE", P_Elt_NS_Value); Add_TagV (O.Skel_B_Trans, "IP_DECL_NAME", P_Decl); Add_TagV (O.Skel_B_Trans, "IP_NAME", P_Name); Add_TagV (O.Skel_B_Trans, "IP_KIND", P_Kind); Add_TagV (O.Skel_B_Trans, "IP_MIN", P_Min); Add_TagV (O.Skel_B_Trans, "IP_MAX", P_Max); Add_TagV (O.Skel_B_Trans, "IP_COMPOUND_SIZE", P_Compound_Size); Add_TagV (O.Skel_B_Trans, "IP_TYPE", P_Type); Add_TagV (O.Skel_B_Trans, "IP_BASE_TYPE", P_Base_Type); Add_TagV (O.Skel_B_Trans, "IP_ROOT_TYPE", P_Root_Type); Add_TagV (O.Skel_B_Trans, "IP_ROOT_TYPE_KIND", P_Root_Type_Kind); Add_TagV (O.Skel_B_Trans, "IP_TYPE_NAME", P_Type_Name); Add_TagV (O.Skel_B_Trans, "IP_TYPE_KIND", P_Type_Kind); Add_TagV (O.Skel_B_Trans, "IP_ADA_TYPE", P_Ada_Type); Add_TagV (O.Skel_B_Trans, "IP_Q_NAME", P_Q_Name); Add_TagV (O.Skel_B_Trans, "IP_NS_NAME", P_NS_Name); Add_TagV (O.Skel_B_Trans, "IP_NS_VALUE", P_NS_Value); Add_TagV (O.Skel_B_Trans, "IP_ELT_NS_NAME", P_Elt_NS_Name); Add_TagV (O.Skel_B_Trans, "IP_ELT_NS_VALUE", P_Elt_NS_Value); end Generate_Input_Params; ---------------------------- -- Generate_Output_Params -- ---------------------------- procedure Generate_Output_Params (O : in out Object; Proc : String; Output : WSDL.Parameters.P_Set) is use type WSDL2AWS.WSDL.Types.Kind; N : WSDL.Parameters.P_Set; Proc_S_Return_Type : Templates.Tag; Proc_B_Return_Type : Templates.Tag; P_Decl : Templates.Tag; P_Name : Templates.Tag; P_Kind : Templates.Tag; P_Min : Templates.Tag; P_Max : Templates.Tag; P_Compound_Size : Templates.Tag; P_Type : Templates.Tag; P_Base_Type : Templates.Tag; P_Root_Type : Templates.Tag; P_Root_Type_Kind : Templates.Tag; P_Type_Name : Templates.Tag; P_Type_Kind : Templates.Tag; P_Ada_Type : Templates.Tag; P_Q_Name : Templates.Tag; P_NS_Name : Templates.Tag; P_NS_Value : Templates.Tag; P_Elt_NS_Name : Templates.Tag; P_Elt_NS_Value : Templates.Tag; begin if Is_Simple_Wrapped_Parameter (O, Output) then N := Output.P; else N := Output; end if; if N /= null then if Is_Simple_Wrapped_Parameter (O, Output) and then N.Mode = WSDL.Types.K_Record then -- A record inside a record in Document style binding Proc_S_Return_Type := Proc_S_Return_Type & (Format_Name (O, WSDL.Types.Name (N.Typ) & "_Type")); else Proc_S_Return_Type := Proc_S_Return_Type & (Result_Type (O, Proc, N)); end if; else Proc_S_Return_Type := Proc_S_Return_Type & "Not_A_Function"; end if; -- Only done once, ???? can probably be removed after clean-up Add_TagV (O.Stub_S_Trans, "PROC_RETURN_TYPE", Proc_S_Return_Type); Add_TagV (O.Stub_B_Trans, "PROC_RETURN_TYPE", Proc_S_Return_Type); Add_TagV (O.Skel_S_Trans, "PROC_RETURN_TYPE", Proc_S_Return_Type); Add_TagV (O.Skel_B_Trans, "PROC_RETURN_TYPE", Proc_S_Return_Type); N := Output; if N /= null then if Is_Simple_Wrapped_Parameter (O, Output) and then N.Mode = WSDL.Types.K_Record then -- A record inside a record in Document style binding Proc_B_Return_Type := Proc_B_Return_Type & (Format_Name (O, WSDL.Types.Name (N.Typ) & "_Type")); else Proc_B_Return_Type := Proc_B_Return_Type & (Result_Type (O, Proc, N)); end if; else Proc_B_Return_Type := Proc_B_Return_Type & "Not_A_Function"; end if; Add_TagV (O.Stub_B_Trans, "PROC_CB_RETURN_TYPE", Proc_B_Return_Type); Add_TagV (O.Skel_B_Trans, "PROC_CB_RETURN_TYPE", Proc_S_Return_Type); if Output = null then Add_TagV (O.Skel_B_Trans, "SINGLE_OUT_PARAMETER", False); Add_TagV (O.Stub_B_Trans, "SINGLE_OUT_PARAMETER", False); Add_TagV (O.Skel_B_Trans, "RETURN_TYPE_KIND", "NONE"); else if Is_Simple_Wrapped_Parameter (O, Output) and then Is_String (Output.P) then Add_TagV (O.Skel_B_Trans, "RETURN_TYPE_KIND", "P_STRING"); else Add_TagV (O.Skel_B_Trans, "RETURN_TYPE_KIND", "NONE"); end if; if Output.Next = null then Add_TagV (O.Skel_B_Trans, "SINGLE_OUT_PARAMETER", True); Add_TagV (O.Stub_B_Trans, "SINGLE_OUT_PARAMETER", True); else Add_TagV (O.Skel_B_Trans, "SINGLE_OUT_PARAMETER", False); Add_TagV (O.Stub_B_Trans, "SINGLE_OUT_PARAMETER", False); end if; end if; -- Output parameters if Output /= null and then Output.Next = null then Generate_Params (O, Output, P_Decl, P_Name, P_Kind, P_Min, P_Max, P_Compound_Size, P_Type, P_Base_Type, P_Root_Type, P_Root_Type_Kind, P_Type_Name, P_Type_Kind, P_Ada_Type, P_Q_Name, P_NS_Name, P_NS_Value, P_Elt_NS_Name, P_Elt_NS_Value); end if; Add_TagV (O.Skel_B_Trans, "OP_DECL_NAME", P_Decl); Add_TagV (O.Skel_B_Trans, "OP_NAME", P_Name); Add_TagV (O.Skel_B_Trans, "OP_KIND", P_Kind); Add_TagV (O.Skel_B_Trans, "OP_MIN", P_Min); Add_TagV (O.Skel_B_Trans, "OP_MAX", P_Max); Add_TagV (O.Skel_B_Trans, "OP_COMPOUND_SIZE", P_Compound_Size); Add_TagV (O.Skel_B_Trans, "OP_TYPE", P_Type); Add_TagV (O.Skel_B_Trans, "OP_BASE_TYPE", P_Base_Type); Add_TagV (O.Skel_B_Trans, "OP_ROOT_TYPE", P_Root_Type); Add_TagV (O.Skel_B_Trans, "OP_ROOT_TYPE_KIND", P_Root_Type_Kind); Add_TagV (O.Skel_B_Trans, "OP_TYPE_NAME", P_Type_Name); Add_TagV (O.Skel_B_Trans, "OP_TYPE_KIND", P_Type_Kind); Add_TagV (O.Skel_B_Trans, "OP_ADA_TYPE", P_Ada_Type); Add_TagV (O.Skel_B_Trans, "OP_Q_NAME", P_Q_Name); Add_TagV (O.Skel_B_Trans, "OP_NS_NAME", P_NS_Name); Add_TagV (O.Skel_B_Trans, "OP_NS_VALUE", P_NS_Value); Add_TagV (O.Skel_B_Trans, "OP_ELT_NS_NAME", P_Elt_NS_Name); Add_TagV (O.Skel_B_Trans, "OP_ELT_NS_VALUE", P_Elt_NS_Value); Add_TagV (O.Stub_B_Trans, "OP_DECL_NAME", P_Decl); Add_TagV (O.Stub_B_Trans, "OP_NAME", P_Name); Add_TagV (O.Stub_B_Trans, "OP_KIND", P_Kind); Add_TagV (O.Stub_B_Trans, "OP_MIN", P_Min); Add_TagV (O.Stub_B_Trans, "OP_MAX", P_Max); Add_TagV (O.Stub_B_Trans, "OP_COMPOUND_SIZE", P_Compound_Size); Add_TagV (O.Stub_B_Trans, "OP_TYPE", P_Type); Add_TagV (O.Stub_B_Trans, "OP_BASE_TYPE", P_Base_Type); Add_TagV (O.Stub_B_Trans, "OP_ROOT_TYPE", P_Root_Type); Add_TagV (O.Stub_B_Trans, "OP_ROOT_TYPE_KIND", P_Root_Type_Kind); Add_TagV (O.Stub_B_Trans, "OP_TYPE_NAME", P_Type_Name); Add_TagV (O.Stub_B_Trans, "OP_TYPE_KIND", P_Type_Kind); Add_TagV (O.Stub_B_Trans, "OP_ADA_TYPE", P_Ada_Type); Add_TagV (O.Stub_B_Trans, "OP_Q_NAME", P_Q_Name); Add_TagV (O.Stub_B_Trans, "OP_NS_NAME", P_NS_Name); Add_TagV (O.Stub_B_Trans, "OP_NS_VALUE", P_NS_Value); Add_TagV (O.Stub_B_Trans, "OP_ELT_NS_NAME", P_Elt_NS_Name); Add_TagV (O.Stub_B_Trans, "OP_ELT_NS_VALUE", P_Elt_NS_Value); end Generate_Output_Params; --------------------- -- Generate_Schema -- --------------------- procedure Generate_Schema (Prefix : String; P : WSDL.Parameters.P_Set) is procedure Generate_Wrapper (Name : String; P : WSDL.Parameters.P_Set); -- Handles top-level wrapper procedure Generate_Array (Name : String; P : WSDL.Parameters.P_Set); -- Handles arrays procedure Generate_Record (Name : String; P : WSDL.Parameters.P_Set); -- Handlers records procedure Generate_Type (Name : String; P : WSDL.Parameters.P_Set); -- Handles types -------------------- -- Generate_Array -- -------------------- procedure Generate_Array (Name : String; P : WSDL.Parameters.P_Set) is Def : constant WSDL.Types.Definition := WSDL.Types.Find (P.Typ); E_Name : constant String := To_String (Def.E_Name); Q_Name : constant String := Name & (if E_Name = "" then "" else '.' & E_Name); begin if E_Name = "" then -- This is a set and not an array, inside we have a record Output_Schema_Definition (O, Name & "@is_a", "@record"); else Output_Schema_Definition (O, Name & "@is_a", "@array"); end if; if P.P /= null then Output_Schema_Definition (O, Q_Name, WSDL.Types.Name (P.P.Typ)); Generate_Wrapper (Q_Name, P.P); end if; end Generate_Array; --------------------- -- Generate_Record -- --------------------- procedure Generate_Record (Name : String; P : WSDL.Parameters.P_Set) is E : WSDL.Parameters.P_Set := P.P; begin Output_Schema_Definition (O, Name & "@is_a", "@record"); while E /= null loop Generate_Wrapper (Name & '.' & To_String (E.Name), E); E := E.Next; end loop; end Generate_Record; --------------------- -- Generate_Type -- --------------------- procedure Generate_Type (Name : String; P : WSDL.Parameters.P_Set) is begin Output_Schema_Definition (O, Name & "@is_a", WSDL.Types.Name (P.Typ, True)); Output_Schema_Definition (O, Name & "@is_a", WSDL.Types.Name (P.Typ, False)); end Generate_Type; ---------------------- -- Generate_Wrapper -- ---------------------- procedure Generate_Wrapper (Name : String; P : WSDL.Parameters.P_Set) is use all type WSDL.Types.Kind; begin case P.Mode is when K_Array => Generate_Array (Name, P); when K_Record => Generate_Record (Name, P); when K_Enumeration | K_Derived | K_Simple => Generate_Type (Name, P); end case; end Generate_Wrapper; N : WSDL.Parameters.P_Set := P; begin while N /= null loop Generate_Wrapper (Prefix & SOAP.Utils.No_NS (To_String (N.Name)), N); N := N.Next; end loop; end Generate_Schema; L_Proc : constant String := Format_Name (O, Proc); W_Name : constant String := (if O.Style = SOAP.WSDL.Schema.Document then Wrapper_Name else Proc); begin if not O.Quiet then Text_IO.Put_Line (" > " & Proc); end if; Put_Types (O, Proc, Wrapper_Name, Input, Output); Generate_Input_Params (O, Input); Generate_Output_Params (O, Proc, Output); Add_Proc_Tag ("HAS_INPUT", Input /= null); Add_Proc_Tag ("HAS_OUTPUT", Output /= null); Add_Proc_Tag ("PROC", L_Proc); Add_Proc_Tag ("DOCUMENTATION", Documentation); Add_Proc_Tag ("SOAP_ACTION", To_String (O.Prefix) & SOAPAction); Add_TagV (O.Stub_B_Trans, "SOAP_PROC", To_String (O.Prefix) & W_Name); Add_TagV (O.Skel_B_Trans, "SOAP_PROC", To_String (O.Prefix) & Proc); Add_Proc_Tag ("SIMPLE_WRAPPED_IN_PARAMETER", Is_Simple_Wrapped_Parameter (O, Input)); Add_Proc_Tag ("SIMPLE_WRAPPED_OUT_PARAMETER", Is_Simple_Wrapped_Parameter (O, Output)); if O.Gen_Stub then Stub.New_Procedure (O, Proc, Documentation, SOAPAction, Wrapper_Name, Namespace, Input, Output, Fault); end if; if O.Gen_Skel then Skel.New_Procedure (O, Proc, Documentation, SOAPAction, Wrapper_Name, Namespace, Input, Output, Fault); end if; Generate_Call_Signature (Input); Generate_Call_Signature (Output); -- Then generate schema (fully prefixed for document/literal) Generate_Schema ((if O.Style = SOAP.WSDL.Schema.Document then "" else Proc & '.'), Input); Generate_Schema ((if O.Style = SOAP.WSDL.Schema.Document then "" else Proc & "Response."), Output); -- Skip line after procedure signatures if O.Gen_CB then CB.New_Procedure (O, Proc, Documentation, SOAPAction, Wrapper_Name, Namespace, Input, Output, Fault); end if; end New_Procedure; ------------- -- No_Skel -- ------------- procedure No_Skel (O : in out Object) is begin O.Gen_Skel := False; end No_Skel; ------------- -- No_Stub -- ------------- procedure No_Stub (O : in out Object) is begin O.Gen_Stub := False; end No_Stub; ------------- -- Options -- ------------- procedure Options (O : in out Object; Options : String) is begin O.Options := To_Unbounded_String (Options); end Options; ------------------------------ -- Output_Schema_Definition -- ------------------------------ procedure Output_Schema_Definition (O : in out Object; Key, Value : String) is begin if not S_Gen.Contains (Key) then S_Gen.Insert (Key, Value); Add_TagV (O.Type_B_Trans, "SCHEMA_DECLS_KEY", Key); Add_TagV (O.Type_B_Trans, "SCHEMA_DECLS_VALUE", Value); end if; end Output_Schema_Definition; --------------- -- Overwrite -- --------------- procedure Overwrite (O : in out Object) is begin O.Force := True; end Overwrite; ---------------- -- Procs_Spec -- ---------------- function Procs_Spec (O : Object; With_Clause : Boolean := False) return String is Prefix : constant String := (if With_Clause then "" else "Standard."); begin if O.Spec /= Null_Unbounded_String then return Prefix & To_String (O.Spec); elsif O.Types_Spec /= Null_Unbounded_String then return Prefix & To_String (O.Types_Spec); else return ""; end if; end Procs_Spec; --------------- -- Put_Types -- --------------- procedure Put_Types (O : in out Object; Proc : String; SOAPAction : String; Input : WSDL.Parameters.P_Set; Output : WSDL.Parameters.P_Set) is use Characters.Handling; use type AWS.Templates.Translate_Set; use type WSDL.Parameters.P_Set; use type WSDL.Types.Kind; use type SOAP.WSDL.Schema.Binding_Style; W_Name : constant String := (if O.Style = SOAP.WSDL.Schema.Document then SOAPAction else Proc); D_Gen : String_Store.Set; procedure Generate_Record (Name : String; Suffix : String; P : WSDL.Parameters.P_Set; Is_Output : Boolean := False); -- Output record definitions (type and routine conversion). Note that -- this routine also handles choice records. The current implementation -- only handles single occurence of a choice. procedure Generate_Array (Name : String; P : WSDL.Parameters.P_Set; Regen : Boolean); -- Generate array definitions (type and routine conversion) procedure Generate_Derived (Name : String; Def : WSDL.Types.Definition; P : WSDL.Parameters.P_Set); -- Generate derived type definition procedure Generate_Enumeration (Name : String; P : WSDL.Parameters.P_Set); -- Generate enumeration type definition function Generate_Namespace (NS : SOAP.Name_Space.Object; Create : Boolean) return String; -- Generate the namespace package from NS procedure Get_References (Unit_List : in out AWS.Templates.Tag; P : WSDL.Parameters.P_Set; For_Derived : Boolean := False); -- Add unit to be with/use into List procedure Initialize_Types_Package (Translations : in out Templates.Translate_Set; P : WSDL.Parameters.P_Set; Name : String; Output : Boolean; Prefix : out Unbounded_String; Def : WSDL.Types.Definition := WSDL.Types.No_Definition; Regen : Boolean := False); -- Creates the full namespaces if needed and return it in Prefix. -- Creates also the package hierarchy. Returns a spec and body file -- descriptor. procedure Output_Types (P : WSDL.Parameters.P_Set); -- Output types conversion routines function Get_Routine (P : WSDL.Parameters.P_Set) return String; -- Returns the Get routine for the given type function Set_Routine (P : WSDL.Parameters.P_Set) return String; -- Returns the constructor routine for the given type function Is_Inside_Record (Name : String) return Boolean; -- Returns True if Name is defined inside a record in the Input -- or Output parameter list. -------------------- -- Generate_Array -- -------------------- procedure Generate_Array (Name : String; P : WSDL.Parameters.P_Set; Regen : Boolean) is use type WSDL.Types.Definition; function To_Ada_Type (Name : String) return String; -- Returns the Ada corresponding type (for array element) function Set_Type (Def : WSDL.Types.Definition) return String; -- Returns the SOAP type for Name -------------- -- Set_Type -- -------------- function Set_Type (Def : WSDL.Types.Definition) return String is Name : constant String := WSDL.Types.Name (Def.Ref); begin if SOAP.WSDL.Is_Standard (Name) then return SOAP.WSDL.Set_Type (SOAP.WSDL.To_Type (Name)); else if Def.Mode = WSDL.Types.K_Derived then return Set_Type (WSDL.Types.Find (Def.Parent)); elsif Def.Mode = WSDL.Types.K_Enumeration then return "SOAP.Types.SOAP_Enumeration"; else return "SOAP.Types.SOAP_Record"; end if; end if; end Set_Type; ----------------- -- To_Ada_Type -- ----------------- function To_Ada_Type (Name : String) return String is begin if SOAP.WSDL.Is_Standard (Name) then return SOAP.WSDL.To_Ada (SOAP.WSDL.To_Type (Name), Constrained => True); else return Format_Name (O, Name) & "_Type"; end if; end To_Ada_Type; S_Name : constant String := Name (Name'First .. Name'Last - 5); -- Simple name without the ending _Type Def : constant WSDL.Types.Definition := WSDL.Types.Find (P.Typ); NS : constant SOAP.Name_Space.Object := WSDL.Types.NS (P.Typ); Pck_NS : constant String := To_Unit_Name (Generate_Namespace (NS, False)); F_Name : constant String := Format_Name (O, Name); E_Type : constant WSDL.Types.Definition := WSDL.Types.Find (if Def = WSDL.Types.No_Definition then P.Typ else Def.E_Type); Q_Name : constant String := (WSDL.Types.Name (E_Type.Ref, NS => E_Type.Mode = WSDL.Types.K_Derived)); T_Name : constant String := (if WSDL.Types.Is_Character (E_Type) then SOAP.Utils.No_NS (Q_Name) else SOAP.Utils.To_Name (Q_Name)); -- Array's element type name ET_Name : constant String := (if Def = WSDL.Types.No_Definition then WSDL.Types.Name (P.P.Typ, True) else WSDL.Types.Name (Def.E_Type, True)); Prefix : Unbounded_String; Translations : Templates.Translate_Set; begin Initialize_Types_Package (Translations, P, F_Name, False, Prefix, Regen => Regen); Translations := Translations & Templates.Assoc ("TYPE_NAME", F_Name) & Templates.Assoc ("NAME_SPACE", SOAP.Name_Space.Name (NS)) & Templates.Assoc ("LENGTH", P.Length) & Templates.Assoc ("INSIDE_RECORD", Is_Inside_Record (S_Name)) & Templates.Assoc ("QUALIFIED_NAME", Q_Name) & Templates.Assoc ("ELEMENT_TYPE", To_Ada_Type (T_Name)) & Templates.Assoc ("ELEMENT_NAME", To_String (Def.E_Name)) & Templates.Assoc ("QUALIFIED_ELEMENT_TYPE", ET_Name) & Templates.Assoc ("SET_TYPE", Set_Type (WSDL.Types.Find (Def.E_Type))) & Templates.Assoc ("SET_ROUTINE", Set_Routine (P)) & Templates.Assoc ("GET_ROUTINE", Get_Routine (P)) & Templates.Assoc ("TYPE_REF", WSDL.Types.Name (P.Typ)) & Templates.Assoc ("DOCUMENTATION", P.Doc); if not NS_Generated.Contains (SOAP.Name_Space.Name (NS)) then Translations := Translations & Templates.Assoc ("NAME_SPACE_PACKAGE", Pck_NS); NS_Generated.Insert (SOAP.Name_Space.Name (NS)); end if; Generate (O, To_Lower (To_String (Prefix)) & ".ads", Template_Array_Ads, Translations); Insert_Types_Def (O, Template_Array_Types, Translations); end Generate_Array; ---------------------- -- Generate_Derived -- ---------------------- procedure Generate_Derived (Name : String; Def : WSDL.Types.Definition; P : WSDL.Parameters.P_Set) is U_Name : constant String := SOAP.Utils.No_NS (Name) & "_Type"; -- Unit name must not have a namespace Q_Name : constant String := SOAP.Utils.To_Name (Name); F_Name : constant String := Format_Name (O, SOAP.Utils.To_Name (Name) & "_Type"); P_Name : constant String := WSDL.Types.Name (Def.Parent, True); B_Name : constant String := SOAP.Utils.To_Name ((if SOAP.WSDL.Is_Standard (P_Name) then SOAP.WSDL.To_Ada (SOAP.WSDL.To_Type (P_Name), not WSDL.Types.Is_Constrained (Def) and then Types_Spec (O) = "") else P_Name & "_Type")); Prefix : Unbounded_String; L_Range, U_Range : Unbounded_String; Is_Range : Boolean := True; Predicate_Kind : Templates.Tag; Predicate : Templates.Tag; Translations : Templates.Translate_Set; begin Initialize_Types_Package (Translations, P, U_Name, False, Prefix, Def); -- Is types are to be reused from an Ada spec ? Translations := Translations & Templates.Assoc ("TYPE_NAME", F_Name) & Templates.Assoc ("BASE_NAME", B_Name) & Templates.Assoc ("QUALIFIED_NAME", Q_Name) & Templates.Assoc ("PARENT_NAME", SOAP.Utils.No_NS (P_Name)) & Templates.Assoc ("DOCUMENTATION", P.Doc); if not D_Gen.Contains (B_Name) then D_Gen.Insert (B_Name); Translations := Translations & Templates.Assoc ("UNIQ_DERIVED", True); end if; -- For array support Translations := Translations & Templates.Assoc ("FROM_SOAP", WSDL.Types.From_SOAP (Def, Object => "O")) & Templates.Assoc ("TO_SOAP", WSDL.Types.To_SOAP (Def, Object => "D", Name => "Name", Type_Name => "Type_Name", Name_Kind => WSDL.Types.Both_Var, NS => "NS")) & Templates.Assoc ("SET_TYPE", SOAP.WSDL.Set_Type (SOAP.WSDL.To_Type (WSDL.Types.Root_Type_For (Def)))); if Types_Spec (O) = "" then declare use type SOAP.WSDL.Parameter_Type; Root_Type : constant SOAP.WSDL.Parameter_Type := SOAP.WSDL.To_Type (WSDL.Types.Root_Type_For (Def)); Constraints : WSDL.Types.Constraints_Def; begin -- Get constraints from parent types. Note that we do not want -- the constraint of the first parent only, but the constraints -- from the whole derived hierarchy. WSDL.Types.Get_Constraints (Def, Constraints); -- Check if we have to build a regexp if Root_Type = SOAP.WSDL.P_String and then Constraints.Pattern /= Null_Unbounded_String then Translations := Translations & Templates.Assoc ("CONSTRAINT_PATTERN", To_String (Constraints.Pattern)); end if; -- Generate constraints if any. We first get the root type to -- know if the constraints are on integers, floats or strings. -- -- * on integers and floats we generate a range: -- -- range .. -- -- where or could the base type 'First or -- 'Last. -- -- * on static strings we generate: -- -- (1 .. ) -- Dynamic_Preficate => Match (, ); -- -- * on variable length strings we generate aspects: -- -- Dynamic_Predicate => -- Length (Unbounded_String ()) >= -- and then Length (Unbounded_String ()) <= -- and then Match (To_String (), ) case Root_Type is when SOAP.WSDL.P_Float => declare Lower, Upper : Float; L_Set, U_Set : Boolean; begin Lower := Float'First; Upper := Float'Last; -- Get constraints from the WSDL definition WSDL.Types.Get_Constraint_Float (Constraints, Lower, L_Set, Upper, U_Set); -- If constraints are found, write them if L_Set or U_Set then L_Range := To_Unbounded_String ((if not L_Set or else Lower < 0.0 then " " else "") & (if L_Set then Float'Image (Lower) else " " & B_Name & "'First")); U_Range := To_Unbounded_String ((if not U_Set or else Upper < 0.0 then " " else "") & (if L_Set then Float'Image (Upper) else " " & B_Name & "'Last")); end if; end; when SOAP.WSDL.P_Double => declare Lower, Upper : Long_Float; L_Set, U_Set : Boolean; begin Lower := Long_Float'First; Upper := Long_Float'Last; -- Get constraints from the WSDL definition WSDL.Types.Get_Constraint_Double (Constraints, Lower, L_Set, Upper, U_Set); -- If constraints are found, write them if L_Set or U_Set then L_Range := To_Unbounded_String ((if not L_Set or else Lower < 0.0 then " " else "") & (if L_Set then Long_Float'Image (Lower) else B_Name & "'First")); U_Range := To_Unbounded_String ((if not U_Set or else Upper < 0.0 then " " else "") & (if U_Set then Long_Float'Image (Upper) else B_Name & "'Last")); end if; end; when SOAP.WSDL.P_String => if WSDL.Types.Is_Constrained (Def) then L_Range := To_Unbounded_String ("1"); U_Range := To_Unbounded_String (Natural'Image (Constraints.Length)); Is_Range := False; else declare Unset : Integer renames WSDL.Types.Unset; Empty : Unbounded_String renames Null_Unbounded_String; begin if Constraints.Min_Length /= WSDL.Types.Unset or else Constraints.Max_Length /= WSDL.Types.Unset or else Constraints.Pattern /= Empty then if Constraints.Min_Length /= Unset then Predicate_Kind := Predicate_Kind & "MIN"; Predicate := Predicate & Constraints.Min_Length; end if; if Constraints.Max_Length /= Unset then Predicate_Kind := Predicate_Kind & "MAX"; Predicate := Predicate & Constraints.Max_Length; end if; if Constraints.Pattern /= Empty then Predicate_Kind := Predicate_Kind & "PATTERN"; Predicate := Predicate & "PATTERN"; end if; end if; end; end if; when SOAP.WSDL.P_Character => null; when SOAP.WSDL.P_Any_Type | SOAP.WSDL.P_B64 => null; when others => declare use SOAP; Lower, Upper : Long_Long_Integer; L_Set, U_Set : Boolean; begin -- Set min/max depending on the type case Root_Type is when SOAP.WSDL.P_Byte => Lower := Long_Long_Integer (Types.Byte'First); Upper := Long_Long_Integer (Types.Byte'Last); when SOAP.WSDL.P_Short => Lower := Long_Long_Integer (Types.Short'First); Upper := Long_Long_Integer (Types.Short'Last); when SOAP.WSDL.P_Integer => Lower := Long_Long_Integer (Integer'First); Upper := Long_Long_Integer (Integer'Last); when SOAP.WSDL.P_Long => Lower := Long_Long_Integer (Types.Long'First); Upper := Long_Long_Integer (Types.Long'Last); when SOAP.WSDL.P_Unsigned_Byte => Lower := 0; Upper := Long_Long_Integer (Types.Byte'Last); when SOAP.WSDL.P_Unsigned_Short => Lower := 0; Upper := Long_Long_Integer (Types.Short'Last); when SOAP.WSDL.P_Unsigned_Int => Lower := 0; Upper := Long_Long_Integer (Integer'Last); when SOAP.WSDL.P_Unsigned_Long => Lower := 0; Upper := Long_Long_Integer (Types.Long'Last); when others => null; end case; -- Get constraints from the WSDL definition WSDL.Types.Get_Constraint_Integer (Constraints, Lower, L_Set, Upper, U_Set); -- If constraints are found, write them if L_Set or U_Set then L_Range := To_Unbounded_String ((if L_Set then Long_Long_Integer'Image (Lower) else " " & B_Name & "'First")); U_Range := To_Unbounded_String ((if U_Set then Long_Long_Integer'Image (Upper) else " " & B_Name & "'Last")); end if; end; end case; end; Translations := Translations & Templates.Assoc ("LOWER_RANGE", L_Range) & Templates.Assoc ("UPPER_RANGE", U_Range) & Templates.Assoc ("PREDICATE_KIND", Predicate_Kind) & Templates.Assoc ("PREDICATE", Predicate) & Templates.Assoc ("IS_RANGE", Is_Range); -- Routine to convert to base type if SOAP.WSDL.Is_Standard (P_Name) then Translations := Translations & Templates.Assoc ("ROUTINE_NAME", SOAP.Utils.No_NS (P_Name) & "_Type"); else Translations := Translations & Templates.Assoc ("ROUTINE_NAME", B_Name); end if; -- For Types child package if SOAP.WSDL.Is_Standard (P_Name) then Translations := Translations & Templates.Assoc ("ALIAS_ROUTINE_NAME", SOAP.Utils.No_NS (Name)); end if; else Translations := Translations & Templates.Assoc ("TYPE_REF", SOAP.Utils.No_NS (Name)); if SOAP.WSDL.Is_Standard (P_Name) then Translations := Translations & Templates.Assoc ("ALIAS_ROUTINE_NAME", SOAP.Utils.No_NS (P_Name)); end if; end if; Generate (O, To_Lower (To_String (Prefix)) & ".ads", Template_Derived_Ads, Translations); Insert_Types_Def (O, Template_Derived_Types, Translations); end Generate_Derived; -------------------------- -- Generate_Enumeration -- -------------------------- procedure Generate_Enumeration (Name : String; P : WSDL.Parameters.P_Set) is use type WSDL.Types.E_Node_Access; F_Name : constant String := Format_Name (O, Name); Def : constant WSDL.Types.Definition := WSDL.Types.Find (P.Typ); N : WSDL.Types.E_Node_Access := Def.E_Def; Prefix : Unbounded_String; Translations : Templates.Translate_Set := Templates.Null_Set & Templates.Assoc ("TYPE_REF", WSDL.Types.Name (Def.Ref)) & Templates.Assoc ("TYPE_NAME", F_Name); E_Name : Templates.Tag; E_Value : Templates.Tag; begin Initialize_Types_Package (Translations, P, F_Name, False, Prefix); while N /= null loop E_Name := E_Name & Format_Name (O, To_String (N.Value)); E_Value := E_Value & To_String (N.Value); N := N.Next; end loop; Translations := Translations & Templates.Assoc ("E_NAME", E_Name) & Templates.Assoc ("E_VALUE", E_Value); Generate (O, To_Lower (To_String (Prefix)) & ".ads", Template_Enum_Ads, Translations); Generate (O, To_Lower (To_String (Prefix)) & ".adb", Template_Enum_Adb, Translations); Insert_Types_Def (O, Template_Enum_Types, Translations); end Generate_Enumeration; ------------------------ -- Generate_Namespace -- ------------------------ function Generate_Namespace (NS : SOAP.Name_Space.Object; Create : Boolean) return String is use type SOAP.Name_Space.Object; function Gen_Dir (Prefix, Name : String) return String; -- Generate a set of directory for each value in Prefix using :, / -- and . as directory separator. function Gen_Package (Prefix, Name : String; Leaf : Boolean) return String; -- Generate a packge for Name. If Leaf is true, this is a leaf -- package and we do generate the Name_Space variable for this -- hierarchy. ------------- -- Gen_Dir -- ------------- function Gen_Dir (Prefix, Name : String) return String is F : constant Natural := Name'First; L : Natural; begin L := Strings.Fixed.Index (Name (F .. Name'Last), Strings.Maps.To_Set (":/.")); if L = 0 then return Gen_Package (Prefix, Name (F .. Name'Last), Leaf => True); else return Gen_Dir (Gen_Package (Prefix, Name (F .. L - 1), Leaf => False), Name (L + 1 .. Name'Last)); end if; end Gen_Dir; ----------------- -- Gen_Package -- ----------------- function Gen_Package (Prefix, Name : String; Leaf : Boolean) return String is function Get_Prefix return String; -- Retruns Prefix & '-' if prefix is not empty function Get_Name (Name : String) return String; -- Returns Name if a valid identifier, prefix with 'n' if number, -- and Ada reserved word or some AWS package names. This is to -- avoid name clashes. -------------- -- Get_Name -- -------------- function Get_Name (Name : String) return String is N : constant String := Format_Name (O, Name); begin if Strings.Fixed.Count (Name, Strings.Maps.Constants.Decimal_Digit_Set) = Name'Length or else SOAP.Utils.Is_Ada_Reserved_Word (Name) or else Name = "soap" or else Name = "aws" then return 'n' & N; else return N; end if; end Get_Name; ---------------- -- Get_Prefix -- ---------------- function Get_Prefix return String is begin if Prefix = "" then return ""; else return Prefix & '-'; end if; end Get_Prefix; N : constant String := Get_Prefix & Get_Name (Strings.Fixed.Translate (Name, Strings.Maps.To_Mapping ("./:-", "____"))); T : Templates.Translate_Set; begin if Create then T := T & Templates.Assoc ("UNIT_NAME", To_Unit_Name (N)); if Leaf then T := T & Templates.Assoc ("NS_NAME", SOAP.Name_Space.Name (NS)) & Templates.Assoc ("NS_VALUE", SOAP.Name_Space.Value (NS)); end if; Generate (O, To_Lower (N) & ".ads", Template_NS_Pkg_Ads, T); end if; return N; end Gen_Package; begin if NS = SOAP.Name_Space.No_Name_Space or else SOAP.Name_Space.Value (NS) = "" then return Generate_Namespace (SOAP.Name_Space.AWS, True); else declare -- If we have forced the AWS name-space (-n option), use it V : constant String := (if SOAP.Name_Space.Is_Default_AWS_NS then SOAP.Name_Space.Value (NS) else SOAP.Name_Space.Value (SOAP.Name_Space.AWS)); First : Positive := V'First; Last : Positive := V'Last; K : Natural; begin -- Remove http:// prefix if present if V (V'First .. V'First + 6) = "http://" then First := First + 7; end if; -- Remove trailing / if present while V (Last) = '/' loop Last := Last - 1; end loop; K := Strings.Fixed.Index (V (First .. Last), "/", Strings.Backward); if K = 0 then return Gen_Dir ("", V (First .. Last)); else return Gen_Package (Prefix => Gen_Dir ("", V (First .. K - 1)), Name => V (K + 1 .. Last), Leaf => True); end if; end; end if; end Generate_Namespace; --------------------- -- Generate_Record -- --------------------- procedure Generate_Record (Name : String; Suffix : String; P : WSDL.Parameters.P_Set; Is_Output : Boolean := False) is F_Name : constant String := Format_Name (O, SOAP.Utils.No_NS (Name) & Suffix); Def : constant WSDL.Types.Definition := WSDL.Types.Find (P.Typ); Is_Choice : constant Boolean := Def.Mode = WSDL.Types.K_Record and then Def.Is_Choice; NS : constant SOAP.Name_Space.Object := WSDL.Types.NS (P.Typ); Pck_NS : constant String := To_Unit_Name (Generate_Namespace (NS, False)); R : WSDL.Parameters.P_Set; N : WSDL.Parameters.P_Set; Count : Natural := 0; Prefix : Unbounded_String; Translations : Templates.Translate_Set; Field_Number : Templates.Tag; Field_Comment : Templates.Tag; Field_Array_First : Templates.Tag; Field_Array_Last : Templates.Tag; Field_Array_Length : Templates.Tag; R_Decl : Templates.Tag; R_Name : Templates.Tag; R_Kind : Templates.Tag; R_Min : Templates.Tag; R_Max : Templates.Tag; R_Compound_Size : Templates.Tag; R_Type : Templates.Tag; R_Base_Type : Templates.Tag; R_Root_Type : Templates.Tag; R_Root_Type_Kind : Templates.Tag; R_Type_Name : Templates.Tag; R_Type_Kind : Templates.Tag; R_Ada_Type : Templates.Tag; R_Q_Name : Templates.Tag; R_NS_Name : Templates.Tag; R_NS_Value : Templates.Tag; R_Elt_NS_Name : Templates.Tag; R_Elt_NS_Value : Templates.Tag; begin Initialize_Types_Package (Translations, P, F_Name, Is_Output, Prefix); if Is_Output then R := P; else R := P.P; end if; N := R; while N /= null loop Generate_Params (O, N, R_Decl, R_Name, R_Kind, R_Min, R_Max, R_Compound_Size, R_Type, R_Base_Type, R_Root_Type, R_Root_Type_Kind, R_Type_Name, R_Type_Kind, R_Ada_Type, R_Q_Name, R_NS_Name, R_NS_Value, R_Elt_NS_Name, R_Elt_NS_Value); Count := Count + 1; Field_Number := Field_Number & Count; Field_Comment := Field_Comment & N.Doc; if N.Mode = WSDL.Types.K_Array then Field_Array_First := Field_Array_First & N.Min; Field_Array_Last := Field_Array_Last & N.Max; Field_Array_Length := Field_Array_Length & (if N.Max = Positive'Last then N.Max else 1 + N.Max - N.Min); else Field_Array_First := Field_Array_First & ""; Field_Array_Last := Field_Array_Last & ""; Field_Array_Length := Field_Array_Length & ""; end if; N := N.Next; end loop; Translations := Translations & Templates.Assoc ("TYPE_NAME", F_Name) & Templates.Assoc ("IS_CHOICE", Is_Choice) & Templates.Assoc ("FIELD_COUNT", Count) & Templates.Assoc ("FIELD_COMMENT", Field_Comment) & Templates.Assoc ("FIELD_NUMBER", Field_Number) & Templates.Assoc ("FIELD_ARRAY_FIRST", Field_Array_First) & Templates.Assoc ("FIELD_ARRAY_LAST", Field_Array_Last) & Templates.Assoc ("FIELD_ARRAY_LENGTH", Field_Array_Length) & Templates.Assoc ("NAME_SPACE", SOAP.Name_Space.Name (NS)) & Templates.Assoc ("TYPE_REF", WSDL.Types.Name (P.Typ)) & Templates.Assoc ("DOCUMENTATION", P.Doc) & Templates.Assoc ("RF_DECL_NAME", R_Decl) & Templates.Assoc ("RF_NAME", R_Name) & Templates.Assoc ("RF_KIND", R_Kind) & Templates.Assoc ("RF_MIN", R_Min) & Templates.Assoc ("RF_MAX", R_Max) & Templates.Assoc ("RF_COMPOUND_SIZE", R_Compound_Size) & Templates.Assoc ("RF_TYPE", R_Type) & Templates.Assoc ("RF_BASE_TYPE", R_Base_Type) & Templates.Assoc ("RF_ROOT_TYPE", R_Root_Type) & Templates.Assoc ("RF_ROOT_TYPE_KIND", R_Root_Type_Kind) & Templates.Assoc ("RF_TYPE_NAME", R_Type_Name) & Templates.Assoc ("RF_TYPE_KIND", R_Type_Kind) & Templates.Assoc ("RF_ADA_TYPE", R_Ada_Type) & Templates.Assoc ("RF_Q_NAME", R_Q_Name) & Templates.Assoc ("RF_NS_NAME", R_NS_Name) & Templates.Assoc ("RF_NS_VALUE", R_NS_Value) & Templates.Assoc ("RF_ELT_NS_NAME", R_Elt_NS_Name) & Templates.Assoc ("RF_ELT_NS_VALUE", R_Elt_NS_Value); -- Is types are to be reused from an Ada spec ? if Types_Spec (O) = "" or else (Is_Simple_Wrapped_Parameter (O, Input) and then P = Input) or else (Is_Simple_Wrapped_Parameter (O, Output) and then P = Output) then Translations := Translations & Templates.Assoc ("SIMPLE_WRAPPED_PARAMETER", True); else Translations := Translations & Templates.Assoc ("SIMPLE_WRAPPED_PARAMETER", False); end if; if not NS_Generated.Contains (SOAP.Name_Space.Name (NS)) then Translations := Translations & Templates.Assoc ("NAME_SPACE_PACKAGE", Pck_NS); NS_Generated.Insert (SOAP.Name_Space.Name (NS)); end if; Generate (O, To_Lower (To_String (Prefix)) & ".ads", Template_Record_Ads, Translations); Generate (O, To_Lower (To_String (Prefix)) & ".adb", Template_Record_Adb, Translations); Insert_Types_Def (O, Template_Record_Types, Translations); end Generate_Record; --------------------- -- Get_References -- --------------------- procedure Get_References (Unit_List : in out AWS.Templates.Tag; P : WSDL.Parameters.P_Set; For_Derived : Boolean := False) is procedure Output_Refs (Def : WSDL.Types.Definition; Gen : Boolean); -- Recursivelly record with/use clauses for derived types Generated : String_Store.Set; -- We must ensure that we do not generate the same with clause twice. -- This can happen with derived types on a record. ----------------- -- Output_Refs -- ----------------- procedure Output_Refs (Def : WSDL.Types.Definition; Gen : Boolean) is Q_Name : constant String := WSDL.Types.Name (Def.Ref, NS => True); F_Name : constant String := Format_Name (O, WSDL.Types.Name (Def.Ref)); Prefix : constant String := Generate_Namespace (WSDL.Types.NS (Def.Ref), False); begin -- For array we want to output references even for standard types -- as we have the generated safe-access circuitry. if Gen and then not Generated.Contains (Q_Name) then if SOAP.WSDL.Is_Standard (WSDL.Types.Name (Def.Ref)) then -- We want here to add a reference to the standard type but -- also generate the corresponding root-package with the -- needed name-space. Unit_List := Unit_List & To_Unit_Name (Generate_Namespace (WSDL.Types.NS (Def.Ref), True)); else Unit_List := Unit_List & (To_Unit_Name (Prefix) & '.' & F_Name & "_Type_Pkg"); end if; Generated.Insert (Q_Name); end if; if Def.Mode = WSDL.Types.K_Derived and then not SOAP.WSDL.Is_Standard (WSDL.Types.Name (Def.Parent)) then Output_Refs (WSDL.Types.Find (Def.Parent), True); end if; end Output_Refs; N : WSDL.Parameters.P_Set := P; begin while N /= null loop Output_Refs (WSDL.Types.Find (N.Typ), not For_Derived); -- If we are not handling a compound type, only reference the root -- type. exit when For_Derived; N := N.Next; end loop; end Get_References; ----------------- -- Get_Routine -- ----------------- function Get_Routine (P : WSDL.Parameters.P_Set) return String is Def : constant WSDL.Types.Definition := WSDL.Types.Find (P.Typ); T_Name : constant String := WSDL.Types.Name (P.Typ); begin case P.Mode is when WSDL.Types.K_Simple => return SOAP.WSDL.Get_Routine (SOAP.WSDL.To_Type (T_Name)); when WSDL.Types.K_Derived => return SOAP.WSDL.Get_Routine (SOAP.WSDL.To_Type (T_Name)); when WSDL.Types.K_Enumeration => return SOAP.WSDL.Get_Routine (SOAP.WSDL.P_String); when WSDL.Types.K_Array => declare E_Ref : constant WSDL.Types.Definition := WSDL.Types.Find (Def.E_Type); E_Type : constant String := WSDL.Types.Name (Def.E_Type); Q_Type : constant String := SOAP.Utils.To_Name (WSDL.Types.Name (Def.E_Type, True)); begin if SOAP.WSDL.Is_Standard (E_Type) then return SOAP.WSDL.Get_Routine (SOAP.WSDL.To_Type (E_Type), Constrained => True); elsif E_Ref.Mode = WSDL.Types.K_Derived then return "To_" & Format_Name (O, Q_Type) & "_Type"; else return "To_" & Format_Name (O, E_Type) & "_Type"; end if; end; when WSDL.Types.K_Record => return "To_" & Type_Name (O, P); end case; end Get_Routine; ------------------------------ -- Initialize_Types_Package -- ------------------------------ procedure Initialize_Types_Package (Translations : in out Templates.Translate_Set; P : WSDL.Parameters.P_Set; Name : String; Output : Boolean; Prefix : out Unbounded_String; Def : WSDL.Types.Definition := WSDL.Types.No_Definition; Regen : Boolean := False) is use type WSDL.Types.Definition; use WSDL.Parameters; F_Name : constant String := Name & "_Pkg"; Q_Type_Name : Unbounded_String; Unit_List : Templates.Tag; begin Prefix := To_Unbounded_String (Generate_Namespace (WSDL.Types.NS (if Def = WSDL.Types.No_Definition then P.Typ else Def.Ref), True) & '-' & F_Name); -- Add references into the main types package if not Regen then Add_TagV (O.Type_S_Trans, "WITHED_UNITS", To_Unit_Name (To_String (Prefix))); end if; if Def.Mode /= WSDL.Types.K_Simple then Q_Type_Name := To_Unbounded_String (WSDL.Types.Name ((if Def = WSDL.Types.No_Definition then P.Typ else Def.Ref), NS => True)); end if; -- Either a compound type or an anonymous returned compound type if Output then Get_References (Unit_List, P); elsif P.Mode in WSDL.Types.Compound_Type then Get_References (Unit_List, P.P); end if; if Def.Mode = WSDL.Types.K_Derived then if SOAP.WSDL.Is_Standard (WSDL.Types.Name (Def.Parent)) then Unit_List := Unit_List & To_Unit_Name (Generate_Namespace (WSDL.Types.NS (Def.Parent), True)); else Unit_List := Unit_List & (To_Unit_Name (Generate_Namespace (WSDL.Types.NS (Def.Parent), False)) & '.' & WSDL.Types.Name (Def.Parent) & "_Type_Pkg"); end if; end if; Translations := Translations & Templates.Assoc ("TYPE_SPEC", Types_Spec (O)) & Templates.Assoc ("UNIT_NAME", To_Unit_Name (To_String (Prefix))) & Templates.Assoc ("Q_TYPE_NAME", Q_Type_Name) & Templates.Assoc ("WITHED_UNITS", Unit_List); end Initialize_Types_Package; ---------------------- -- Is_Inside_Record -- ---------------------- function Is_Inside_Record (Name : String) return Boolean is In_Record : Boolean := False; procedure Check_Record (P_Set : WSDL.Parameters.P_Set; Mode : in out Boolean); -- Checks all record fields for Name procedure Check_Parameters (P_Set : WSDL.Parameters.P_Set); -- Checks P_Set for Name declared inside a record ---------------------- -- Check_Parameters -- ---------------------- procedure Check_Parameters (P_Set : WSDL.Parameters.P_Set) is P : WSDL.Parameters.P_Set := P_Set; begin while P /= null loop if P.Mode = WSDL.Types.K_Record then Check_Record (P.P, In_Record); elsif P.Mode = WSDL.Types.K_Array then -- Recursively check for every array parameters. This is -- to handle the case where an array has a parameter which -- is a record containing the type Name. Check_Parameters (P.P); end if; P := P.Next; end loop; end Check_Parameters; ------------------ -- Check_Record -- ------------------ procedure Check_Record (P_Set : WSDL.Parameters.P_Set; Mode : in out Boolean) is P : WSDL.Parameters.P_Set := P_Set; begin while P /= null loop if P.Mode = WSDL.Types.K_Array and then WSDL.Types.Name (P.Typ) = Name then Mode := True; return; end if; if P.Mode in WSDL.Types.Compound_Type then Check_Record (P.P, Mode); end if; P := P.Next; end loop; end Check_Record; begin Check_Parameters (Input); Check_Parameters (Output); return In_Record; end Is_Inside_Record; ------------------ -- Output_Types -- ------------------ procedure Output_Types (P : WSDL.Parameters.P_Set) is N : WSDL.Parameters.P_Set := P; begin while N /= null loop declare T_Name : constant String := WSDL.Types.Name (N.Typ); begin case N.Mode is when WSDL.Types.K_Simple => null; when WSDL.Types.K_Derived => declare procedure Generate (Def : WSDL.Types.Definition); -- Generate all definitions for the derived types in -- the right order of reference. -------------- -- Generate -- -------------- procedure Generate (Def : WSDL.Types.Definition) is use type SOAP.Name_Space.Object; T_Name : constant String := WSDL.Types.Name (Def.Ref, True); begin if WSDL.Types.NS (Def.Ref) /= SOAP.Name_Space.XSD then Generate (WSDL.Types.Find (Def.Parent)); if not Name_Set.Exists (T_Name) then Name_Set.Add (T_Name); Generate_Derived (T_Name, Def, N); end if; end if; end Generate; begin Generate (WSDL.Types.Find (N.Typ)); end; when WSDL.Types.K_Enumeration => if not Name_Set.Exists (T_Name) then Name_Set.Add (T_Name); Generate_Enumeration (T_Name & "_Type", N); end if; when WSDL.Types.K_Array => Output_Types (N.P); declare Regen : Boolean; begin if not Name_Set.Exists (T_Name) or else Is_Inside_Record (T_Name) then if Name_Set.Exists (T_Name) and then Is_Inside_Record (T_Name) then -- We force the regeneration of the array -- definition when it is inside a record to -- be sure that we have a safe access generated. Regen := True; else Regen := False; Name_Set.Add (T_Name); end if; Generate_Array (T_Name & "_Type", N, Regen); end if; end; when WSDL.Types.K_Record => Output_Types (N.P); if not Name_Set.Exists (T_Name) then Name_Set.Add (T_Name); Generate_Record (WSDL.Types.Name (N.Typ, True), "_Type", N); end if; end case; end; N := N.Next; end loop; end Output_Types; ----------------- -- Set_Routine -- ----------------- function Set_Routine (P : WSDL.Parameters.P_Set) return String is Def : constant WSDL.Types.Definition := WSDL.Types.Find (P.Typ); T_Name : constant String := WSDL.Types.Name (P.Typ); begin case P.Mode is when WSDL.Types.K_Simple => return SOAP.WSDL.Set_Routine (SOAP.WSDL.To_Type (T_Name), Constrained => True); when WSDL.Types.K_Derived => return SOAP.WSDL.Set_Routine (WSDL.Types.Name (Def.Parent), Constrained => True); when WSDL.Types.K_Enumeration => return SOAP.WSDL.Set_Routine (SOAP.WSDL.P_String, Constrained => True); when WSDL.Types.K_Array => declare E_Type : constant String := WSDL.Types.Name (Def.E_Type); begin if SOAP.WSDL.Is_Standard (E_Type) then return SOAP.WSDL.Set_Routine (SOAP.WSDL.To_Type (E_Type), Constrained => True); else return "To_SOAP_Object"; end if; end; when WSDL.Types.K_Record => return "To_SOAP_Object"; end case; end Set_Routine; L_Proc : constant String := Format_Name (O, Proc); begin Output_Types (Input); Output_Types (Output); Output_Schema_Definition (O, Key => '@' & To_String (O.Prefix) & W_Name & ".encoding", Value => SOAP.Types.Encoding_Style'Image (O.Encoding (WSDL.Parser.Input))); Output_Schema_Definition (O, Key => '@' & To_String (O.Prefix) & W_Name & "Response.encoding", Value => SOAP.Types.Encoding_Style'Image (O.Encoding (WSDL.Parser.Output))); Output_Schema_Definition (O, Key => '@' & To_String (O.Prefix) & SOAP.Utils.No_NS (W_Name) & ".encoding", Value => SOAP.Types.Encoding_Style'Image (O.Encoding (WSDL.Parser.Input))); Output_Schema_Definition (O, Key => '@' & To_String (O.Prefix) & SOAP.Utils.No_NS (W_Name) & "Response.encoding", Value => SOAP.Types.Encoding_Style'Image (O.Encoding (WSDL.Parser.Output))); if Output /= null then -- Something in the SOAP procedure output Output_Schema_Definition (O, Key => '@' & To_String (Output.Name) & ".encoding", Value => SOAP.Types.Encoding_Style'Image (O.Encoding (WSDL.Parser.Output))); if Output.Next = null then -- A single parameter if Output.Mode /= WSDL.Types.K_Simple then declare Def : constant WSDL.Types.Definition := WSDL.Types.Find (Output.Typ, False); T : Templates.Translate_Set; begin T := T & Templates.Assoc ("PROC", L_Proc) & Templates.Assoc ("QUALIFIED_NAME", Format_Name (O, SOAP.Utils.To_Name (WSDL.Types.Name (Output.Typ, Def.Mode = WSDL.Types.K_Derived)))) & Templates.Assoc ("RESULT_IS_ARRAY", Output.Mode = WSDL.Types.K_Array); Insert_Types_Def (O, Template_Stub_Types_Ads, T); end; end if; else -- Multiple parameters in the output, generate a record in this -- case. Generate_Record (L_Proc, "_Result", Output, Is_Output => True); end if; end if; end Put_Types; ----------- -- Quiet -- ----------- procedure Quiet (O : in out Object) is begin O.Quiet := True; end Quiet; ----------------- -- Result_Type -- ----------------- function Result_Type (O : Object; Proc : String; Output : WSDL.Parameters.P_Set) return String is use type WSDL.Types.Kind; L_Proc : constant String := Format_Name (O, Proc); begin if WSDL.Parameters.Length (Output) = 1 and then Output.Mode = WSDL.Types.K_Simple then return SOAP.WSDL.To_Ada (SOAP.WSDL.To_Type (WSDL.Types.Name (Output.Typ))); else return L_Proc & "_Result"; end if; end Result_Type; ---------------- -- Set_Prefix -- ---------------- procedure Set_Prefix (O : in out Object; Prefix : String) is begin O.Prefix := To_Unbounded_String (Prefix); end Set_Prefix; --------------- -- Set_Proxy -- --------------- procedure Set_Proxy (O : in out Object; Proxy, User, Password : String) is begin O.Proxy := To_Unbounded_String (Proxy); O.P_User := To_Unbounded_String (User); O.P_Pwd := To_Unbounded_String (Password); end Set_Proxy; ------------------ -- Set_Timeouts -- ------------------ procedure Set_Timeouts (O : in out Object; Timeouts : Client.Timeouts_Values) is begin O.Timeouts := Timeouts; end Set_Timeouts; ---------- -- Skel -- ---------- package body Skel is separate; ---------------- -- Specs_From -- ---------------- procedure Specs_From (O : in out Object; Spec : String) is begin O.Spec := To_Unbounded_String (Spec); end Specs_From; ------------------- -- Start_Service -- ------------------- overriding procedure Start_Service (O : in out Object; Name : String; Root_Documentation : String; Documentation : String; Location : String) is use type Client.Timeouts_Values; use type Templates.Translate_Set; U_Name : constant String := To_Unit_Name (Format_Name (O, Name)); procedure Generate_Main (Filename : String); -- Generate the main server's procedure. Either the file exists and is -- a template use it to generate the main otherwise just generate a -- standard main procedure. function Timeout_Image (Timeout : Duration) return String; ------------------- -- Generate_Main -- ------------------- procedure Generate_Main (Filename : String) is L_Filename : constant String := Characters.Handling.To_Lower (Filename); begin declare T : Templates.Translate_Set; begin T := T & Templates.Assoc ("SOAP_SERVICE", U_Name) & Templates.Assoc ("UNIT_NAME", To_Unit_Name (Filename)); Generate (O, L_Filename & ".adb", Template_Main_Adb, T); end; end Generate_Main; ------------------- -- Timeout_Image -- ------------------- function Timeout_Image (Timeout : Duration) return String is begin if Timeout = Duration'Last then return "Duration'Last"; else return AWS.Utils.Significant_Image (Timeout, 3); end if; end Timeout_Image; LL_Name : constant String := Characters.Handling.To_Lower (Format_Name (O, Name)); begin O.Type_S_Trans := O.Type_S_Trans & Templates.Assoc ("UNIT_NAME", U_Name); O.Type_B_Trans := O.Type_B_Trans & Templates.Assoc ("UNIT_NAME", U_Name); O.Root_S_Trans := O.Root_S_Trans & Templates.Assoc ("UNIT_NAME", U_Name) & Templates.Assoc ("ROOT_DOCUMENTATION", Root_Documentation); O.Stub_S_Trans := O.Stub_S_Trans & Templates.Assoc ("ROOT_DOCUMENTATION", Root_Documentation); O.Skel_S_Trans := O.Skel_S_Trans & Templates.Assoc ("ROOT_DOCUMENTATION", Root_Documentation); O.Location := To_Unbounded_String (Get_Endpoint (O, Location)); Validate_Location : declare Loc : constant String := To_String (O.Location); begin -- Validate location if Loc'Length < 8 or else (Loc (Loc'First .. Loc'First + 6) /= "http://" and then Loc (Loc'First .. Loc'First + 7) /= "https://") then raise WSDL.Parser.WSDL_Error with "location is not a valid end-point, " & "consider using option -e"; end if; end Validate_Location; if not O.Quiet then Text_IO.New_Line; Text_IO.Put_Line ("Service " & Name); Text_IO.Put_Line (" " & Root_Documentation); end if; if O.Timeouts /= Client.No_Timeout then O.Root_S_Trans := O.Root_S_Trans & Templates.Assoc ("CONNECT_TIMEOUT", Timeout_Image (Client.Connect_Timeout (O.Timeouts))) & Templates.Assoc ("SEND_TIMEOUT", Timeout_Image (Client.Send_Timeout (O.Timeouts))) & Templates.Assoc ("RECEIVE_TIMEOUT", Timeout_Image (Client.Receive_Timeout (O.Timeouts))) & Templates.Assoc ("RESPONSE_TIMEOUT", Timeout_Image (Client.Response_Timeout (O.Timeouts))); end if; O.Root_S_Trans := O.Root_S_Trans & Templates.Assoc ("END_POINT", Get_Endpoint (O, Location)); -- Add namespaces in schema Output_Schema_Definition (O, Key => SOAP.Name_Space.Value (O.xsd), Value => SOAP.Utils.No_NS (SOAP.Name_Space.Name (O.xsd))); Output_Schema_Definition (O, Key => SOAP.Name_Space.Value (O.xsi), Value => SOAP.Utils.No_NS (SOAP.Name_Space.Name (O.xsi))); Output_Schema_Definition (O, Key => SOAP.Name_Space.Value (O.env), Value => SOAP.Utils.No_NS (SOAP.Name_Space.Name (O.env))); Output_Schema_Definition (O, Key => SOAP.Name_Space.Value (O.enc), Value => SOAP.Utils.No_NS (SOAP.Name_Space.Name (O.enc))); -- Then the user's name-spaces declare procedure Write_NS (Key, Value : String); -------------- -- Write_NS -- -------------- procedure Write_NS (Key, Value : String) is begin Output_Schema_Definition (O, Key, Value); end Write_NS; begin SOAP.WSDL.Name_Spaces.Iterate (Write_NS'Access); end; -- The WSDL document if O.WSDL_File /= Null_Unbounded_String then declare File : Text_IO.File_Type; Buffer : String (1 .. 1_024); Last : Natural; begin Text_IO.Open (File, Text_IO.In_File, To_String (O.WSDL_File)); while not Text_IO.End_Of_File (File) loop Text_IO.Get_Line (File, Buffer, Last); Add_TagV (O.Root_S_Trans, "WSDL", Buffer (1 .. Last)); end loop; end; end if; Generate (O, LL_Name & ".ads", Template_Root_Ads, O.Root_S_Trans); O.Unit := To_Unbounded_String (U_Name); -- Stubs if O.Gen_Stub then Stub.Start_Service (O, Name, Root_Documentation, Documentation, Location); end if; -- Skeletons if O.Gen_Skel then Skel.Start_Service (O, Name, Root_Documentation, Documentation, Location); end if; -- Callbacks if O.Gen_CB then CB.Start_Service (O, Name, Root_Documentation, Documentation, Location); end if; -- Main if O.Main /= Null_Unbounded_String then Generate_Main (To_String (O.Main)); end if; end Start_Service; ---------- -- Stub -- ---------- package body Stub is separate; ------------------ -- To_Unit_Name -- ------------------ function To_Unit_Name (Filename : String) return String is begin return Strings.Fixed.Translate (Filename, Strings.Maps.To_Mapping ("-", ".")); end To_Unit_Name; ------------ -- Traces -- ------------ procedure Traces (O : in out Object) is begin O.Traces := True; end Traces; --------------- -- Type_Name -- --------------- function Type_Name (O : Object; N : WSDL.Parameters.P_Set) return String is T_Name : constant String := WSDL.Types.Name (N.Typ); Q_Name : constant String := SOAP.Utils.To_Name (WSDL.Types.Name (N.Typ, True)); begin case N.Mode is when WSDL.Types.K_Simple => -- This routine is called only for SOAP object in records -- or arrays. return SOAP.WSDL.To_Ada (SOAP.WSDL.To_Type (T_Name), Constrained => True); when WSDL.Types.K_Derived => return Format_Name (O, Q_Name) & "_Type"; when WSDL.Types.K_Enumeration => return Format_Name (O, T_Name) & "_Type"; when WSDL.Types.K_Array => if O.Sp then return Format_Name (O, T_Name) & "_Type_Safe_Access"; else return Format_Name (O, T_Name) & "_Type"; end if; when WSDL.Types.K_Record => return Format_Name (O, T_Name) & "_Type"; end case; end Type_Name; ---------------- -- Types_From -- ---------------- procedure Types_From (O : in out Object; Spec : String) is begin O.Types_Spec := To_Unbounded_String (To_Unit_Name (Spec)); end Types_From; ---------------- -- Types_Spec -- ---------------- function Types_Spec (O : Object; With_Clause : Boolean := False) return String is Prefix : constant String := (if With_Clause then "" else "Standard."); begin if O.Types_Spec /= Null_Unbounded_String then return Prefix & To_String (O.Types_Spec); elsif O.Spec /= Null_Unbounded_String then return Prefix & To_String (O.Spec); else return ""; end if; end Types_Spec; --------------- -- WSDL_File -- --------------- procedure WSDL_File (O : in out Object; Filename : String) is begin O.WSDL_File := To_Unbounded_String (Filename); end WSDL_File; end WSDL2AWS.Generator;