Adapter.p

/*------------------------------------------------------------------------
  File:               Adapter.P
  Description:        Builds the WebService procedure adapter for the 
                      procedures defined in temp-tables generated by 
                      procInfo.p, using the specified template.
  Input Parameters:   ttProcedure      Procedures.                    
                      ttMethod         Internal procedures and Functions 
                                       to include.                
                      ttParam          Procedure Parameters.                                         
                      ttTable          Temp-tables used by the procedures.                  
                      ttField          Temp-tables Fields.                           
                      ichProgramFile   Path to the generated adapter.
                      ichTemplate      Path to the generated adapter.                                          
                      ichNameSpace     The name of the web service.     
  Output Parameters:  ochResult        Error message or "" if there 
                                       isn't any
  Author:             Lic. Edgar Medrano Pérez 
                      edgarmedrano@gmail.com
  Created:            2005.06.18
  Company:            Open 4GL webservices project
                      http://o4glws.sourceforge.net
  Notes:              
------------------------------------------------------------------------*/
{o4glws/procInfo.i}

&SCOPED-DEFINE WRITE-CODE PUT STREAM strFile UNFORMATTED

DEFINE INPUT PARAMETER TABLE FOR ttProcedure.
DEFINE INPUT PARAMETER TABLE FOR ttMethod.
DEFINE INPUT PARAMETER TABLE FOR ttParam.
DEFINE INPUT PARAMETER TABLE FOR ttTable.
DEFINE INPUT PARAMETER TABLE FOR ttField.
DEFINE INPUT PARAMETER ichProgramFile   AS CHARACTER    NO-UNDO.
DEFINE INPUT PARAMETER ichTemplateFile  AS CHARACTER    NO-UNDO.
DEFINE INPUT PARAMETER ichNameSpace     AS CHARACTER    NO-UNDO.
DEFINE INPUT PARAMETER ichSecurity      AS CHARACTER    NO-UNDO.
DEFINE OUTPUT PARAMETER ochResult       AS CHARACTER    NO-UNDO.

DEFINE VARIABLE vchrBuffer   AS CHARACTER NO-UNDO.
DEFINE VARIABLE vchrComma    AS CHARACTER  NO-UNDO.
DEFINE STREAM strTemplate.
DEFINE STREAM strFile.

  IF ichProgramFile = "" OR ichProgramFile = ? THEN
  DO:
      ochResult = SUBSTITUTE("Unable to use WSDL File: [&1]", ichProgramFile).
      RETURN.
  END.
  
  IF ichNameSpace = "" OR ichNameSpace = ? THEN
  DO:
      ochResult = ochResult + "~n" + SUBSTITUTE("Unable to use Namespace: [&1]", ichNameSpace).
      RETURN.                  
  END.

	OUTPUT STREAM strFile TO VALUE(ichProgramFile).
	
	/*Codigo previo a la identificacion*/
  IF ichTemplateFile MATCHES "*.htm*" THEN
  DO:
    {&WRITE-CODE} "<script language=""SpeedScript"">~n".
  END.
	
	INPUT STREAM strTemplate FROM VALUE(ichTemplateFile).
	REPEAT:
	  IMPORT STREAM strTemplate UNFORMATTED vchrBuffer.
      {&WRITE-CODE} vchrBuffer "~n".
	END.
	INPUT STREAM strTemplate CLOSE.

  /** Definir handles para super-procedures**/
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "/*Declarar handles para super-procedures*/~n".
  FOR EACH ttProcedure
    NO-LOCK:
    {&WRITE-CODE} SUBSTITUTE("DEFINE VARIABLE vhnd&1 AS HANDLE     NO-UNDO.~n", ichNameSpace + STRING(ttProcedure.iProcId)).
  END.
	
  /** Definir el procedimiento PROCESS-REQUEST **/
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "PROCEDURE PROCESS-REQUEST:~n".
  {&WRITE-CODE} "  DEFINE INPUT  PARAMETER vhndRequestDoc  AS HANDLE     NO-UNDO.~n".
  {&WRITE-CODE} "  DEFINE OUTPUT PARAMETER vhndResponseDoc AS HANDLE     NO-UNDO.~n".
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vintI AS INTEGER    NO-UNDO.~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vchrMessage         AS CHARACTER  NO-UNDO.~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndRequestEnv      AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndResponseEnv     AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndRequestHead     AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndResponseHead    AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndRequestBody     AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndResponseBody    AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndRequestMessage  AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vhndResponseMessage AS HANDLE    NO-UNDO. ~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vchrEnvelopeNS      AS CHARACTER  NO-UNDO INITIAL ""s"".~n".
  {&WRITE-CODE} "  DEFINE VARIABLE vchrMessageNS       AS CHARACTER  NO-UNDO INITIAL ""n"".~n".
  {&WRITE-CODE} SUBSTITUTE("  DEFINE VARIABLE vchrWebService      AS CHARACTER  NO-UNDO INITIAL ""&1"".~n",ichNameSpace).
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "  vhndRequestEnv = findChild(vhndRequestDoc,""Envelope"").~n".
  {&WRITE-CODE} "  vhndRequestHead = findChild(vhndRequestEnv,""Header"").~n".
  {&WRITE-CODE} "  vhndRequestBody = findChild(vhndRequestEnv,""Body"").~n".
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "  vhndResponseDoc = createResponse(vchrEnvelopeNS).~n".
  {&WRITE-CODE} "  vhndResponseEnv = findChild(vhndResponseDoc,""Envelope"").~n".
  {&WRITE-CODE} "  vhndResponseHead = findChild(vhndResponseDoc,""Header"").~n".
  {&WRITE-CODE} "  vhndResponseBody = findChild(vhndResponseEnv,""Body"").~n".
  {&WRITE-CODE} "~n".

  IF ichSecurity <> "" THEN
  DO:
    {&WRITE-CODE} SUBSTITUTE("  IF NOT SECURITY-TEST(vhndRequestHead,""&1"") THEN~n", ichSecurity).
    {&WRITE-CODE} "  DO:~n".
    {&WRITE-CODE} "    vhndResponseMessage = createFault(vhndResponseBody,""soap:Server.SecurityFault"",""The supplied parameters didn't pass the security test."",THIS-PROCEDURE:FILE-NAME,vchrEnvelopeNS).~n".
    {&WRITE-CODE} "    RETURN.~n".
    {&WRITE-CODE} "  END.~n".
    {&WRITE-CODE} "~n".
  END.

  {&WRITE-CODE} "  /*Buscar todas las llamadas*/~n".
  {&WRITE-CODE} "  CREATE X-NODEREF vhndRequestMessage.~n".
  {&WRITE-CODE} "  DO vintI = 1 TO vhndRequestBody:NUM-CHILDREN:~n".
  {&WRITE-CODE} "      IF vhndRequestBody:GET-CHILD(vhndRequestMessage,vintI) THEN~n".
  {&WRITE-CODE} "      DO:~n".
  {&WRITE-CODE} "        IF vhndRequestMessage:SUBTYPE = ""ELEMENT"" THEN~n".
  {&WRITE-CODE} "        DO:~n".
  {&WRITE-CODE} "          /*Indentificar el metodo que sera llamado*/~n".
  {&WRITE-CODE} "          vchrMessage = ~n".
  {&WRITE-CODE} "             IF vhndRequestMessage:LOCAL-NAME = """" THEN ~n".
  {&WRITE-CODE} "               vhndRequestMessage:NAME~n".
  {&WRITE-CODE} "             ELSE~n".
  {&WRITE-CODE} "               vhndRequestMessage:LOCAL-NAME.~n".
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "          CASE vchrMessage:~n".

  
  FOR EACH ttProcedure
    NO-LOCK:
    FOR EACH ttMethod
      WHERE ttMethod.iProcId = ttProcedure.iProcId
      NO-LOCK:
    	{&WRITE-CODE} SUBSTITUTE(
    				  "            WHEN ""&1"" THEN~n"
    				+ "            DO:~n" 
    				+ "              vhndResponseMessage = createChild(vhndResponseBody,""&1Response"",vchrMessageNS).~n"
    				+ "              vhndResponseMessage:SET-ATTRIBUTE(""xmlns:"" + vchrMessageNS,vchrWebService).~n"
    				+ "              RUN &1Adapter(vhndRequestMessage,vhndResponseMessage) NO-ERROR.~n"
            + "              DELETE PROCEDURE vhnd&2 NO-ERROR.~n"
    				+ "            END.~n"
    				, ttProcedure.cName + (IF ttMethod.cName = "" THEN "" ELSE "_") + ttMethod.cName
                    , ichNameSpace + STRING(ttMethod.iProcId)).
    END. /** for each ttmethod **/
  END. /** for each ttProcedure **/

  /*Discard unknown methods and nodes*/
  {&WRITE-CODE} "            WHEN ""multiRef"" THEN~n".
  {&WRITE-CODE} "            DO:~n". 
  {&WRITE-CODE} "              /*IGNORE*/~n".
  {&WRITE-CODE} "            END.~n".
  {&WRITE-CODE} "            OTHERWISE~n".
  {&WRITE-CODE} "            DO:~n". 
  {&WRITE-CODE} "              vhndResponseMessage = createFault(vhndResponseBody,""soap:Server.UnknownMethod"",""The specified method is unknown."",THIS-PROCEDURE:FILE-NAME,vchrEnvelopeNS).~n".
  {&WRITE-CODE} "            END.~n".
  {&WRITE-CODE} "          END CASE.~n".
  {&WRITE-CODE} "        END.~n".
  {&WRITE-CODE} "      END.~n".
  {&WRITE-CODE} "  END.~n".
  {&WRITE-CODE} "~n".
  {&WRITE-CODE} "  DELETE OBJECT vhndRequestDoc. ~n".
  {&WRITE-CODE} "END.~n".
  {&WRITE-CODE} "~n".

  /** First Create any Complex Types used for temp-tables **/
	IF CAN-FIND(FIRST ttTable) THEN
	DO:
		{&WRITE-CODE} "/*Declarar aqui tablas temporales usadas por datos complejos*/~n".
    FOR EACH ttProcedure
      NO-LOCK:
        FOR EACH ttTable 
          WHERE ttTable.iProcId = ttProcedure.iProcId
          NO-LOCK:
            {&WRITE-CODE} SUBSTITUTE("DEFINE TEMP-TABLE &1~n", ttProcedure.cName + "_" + ttTable.cName).

            FOR EACH ttField 
              WHERE ttField.iProcId = ttTable.iProcId
                AND ttField.cTableName = ttTable.cName
              NO-LOCK
              BY ttField.iSeq:
                {&WRITE-CODE} SUBSTITUTE("    FIELD &1 AS &2~n", ttField.cName, ttField.cDataType).
            END. /** for each ttfield **/                            
            {&WRITE-CODE} "    .~n~n".
        END. /** for each tttable **/
    END. /** for each ttProcedure **/
	END.
        
  /** Definir adaptadores **/
  FOR EACH ttProcedure
    NO-LOCK:
      FOR EACH ttMethod
        WHERE ttMethod.iProcId = ttProcedure.iProcId
        NO-LOCK:
          {&WRITE-CODE} SUBSTITUTE("PROCEDURE &1Adapter:~n", ttProcedure.cName + (IF ttMethod.cName = "" THEN "" ELSE "_") + ttMethod.cName).
          {&WRITE-CODE} "    DEFINE  INPUT PARAMETER iphndRequestMessage  AS HANDLE     NO-UNDO.~n".
          {&WRITE-CODE} "    DEFINE  INPUT PARAMETER iphndResponseMessage AS HANDLE     NO-UNDO.~n".
          {&WRITE-CODE} "~n".

          /** Definir variables de salida **/
          IF CAN-FIND(FIRST ttParam 
              WHERE ttParam.iProcId = ttMethod.iProcId
                AND ttParam.cMethodName = ttMethod.cName
                AND ttParam.cDirection <> "INPUT"
                AND ttParam.cDataType <> "TABLE") THEN
          DO:                                    
              {&WRITE-CODE} "   /*Declarar variables de salida*/~n".

              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                  AND ttParam.cDirection  <> "INPUT"
                  AND ttParam.cDataType <> "TABLE"
                NO-LOCK
                BY ttParam.iSeq:
                  {&WRITE-CODE} SUBSTITUTE("   DEFINE VARIABLE &1 AS &2    NO-UNDO.~n", ttParam.cName, ttParam.cDataType).
              END. /** for each ttparam **/

              {&WRITE-CODE} "~n".
          END. /** can-find **/

          /** Declarar handlers para leer/escribir temporales **/
          /*
          IF CAN-FIND(FIRST ttParam 
              WHERE ttParam.iProcId = ttMethod.iProcId
                AND ttParam.cMethodName = ttMethod.cName
                AND ttParam.cDataType = "TABLE") THEN
          DO:                                    
              {&WRITE-CODE} "   /*Declarar handlers para leer/escribir temporales*/~n".

              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                  AND ttParam.cDataType = "TABLE"
                NO-LOCK
                BY ttParam.iSeq:
                  {&WRITE-CODE} SUBSTITUTE("   DEFINE VARIABLE hnd&1 AS HANDLE    NO-UNDO.~n", ttProcedure.cName + "_" + ttParam.cName).
              END. /** for each ttparam **/

              {&WRITE-CODE} "~n".
          END. /** can-find **/
          */

          /** Inicializar valores de variables de entrada/salida **/
          IF CAN-FIND(FIRST ttParam 
              WHERE ttParam.iProcId = ttMethod.iProcId
                AND ttParam.cMethodName = ttMethod.cName
                AND ttParam.cDirection = "INPUT-OUTPUT"
                AND ttParam.cDataType <> "TABLE") THEN
          DO:                                    
              {&WRITE-CODE} "   /*Inicializar valores de variables de entrada/salida*/~n".

              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                  AND ttParam.cDirection = "INPUT-OUTPUT"
                  AND ttParam.cDataType <> "TABLE"            
                NO-LOCK
                BY ttParam.iSeq:
                  {&WRITE-CODE} SUBSTITUTE("   &1 = getIn&2(iphndRequestMessage,""&3"").~n", ttParam.cName, ttParam.cDataType,  (IF ttParam.cMethodName = "" THEN ttProcedure.cName + "_" ELSE "") + ttParam.cName).
              END. /** for each ttparam **/

              {&WRITE-CODE} "~n".
          END. /** can-find **/

          /** Inicializar tablas de entrada/salida **/
          /*
          IF CAN-FIND(FIRST ttParam 
              WHERE ttParam.iProcId = ttMethod.iProcId
                AND ttParam.cMethodName = ttMethod.cName
                AND ttParam.cDataType = "TABLE") THEN
          DO:                                    
              {&WRITE-CODE} "   /*Inicializar tablas de entrada/salida*/~n".

              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                  AND ttParam.cDataType = "TABLE"
                NO-LOCK
                BY ttParam.iSeq:
                  {&WRITE-CODE} SUBSTITUTE(
                                  "   ASSIGN hnd&1 = BUFFER &1:HANDLE.~n"
                                , ttProcedure.cName + "_" + ttParam.cName).

                IF ttParam.cDirection <> "OUTPUT" THEN
                DO:
                  {&WRITE-CODE} SUBSTITUTE(
                                  "   getInTable(iphndRequestMessage,""&1Array"",hnd&1).~n"
                                , ttProcedure.cName + "_" + ttParam.cName).
                END.
              END. /** for each ttparam **/

              {&WRITE-CODE} "~n".
          END. /** can-find **/
          */
          IF CAN-FIND(FIRST ttParam 
              WHERE ttParam.iProcId = ttMethod.iProcId
                AND ttParam.cMethodName = ttMethod.cName
                AND ttParam.cDataType = "TABLE"
                AND ttParam.cDirection <> "OUTPUT") THEN
          DO:                                    
              {&WRITE-CODE} "   /*Inicializar tablas de entrada/salida*/~n".

              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                  AND ttParam.cDataType = "TABLE"
                  AND ttParam.cDirection <> "OUTPUT"
                NO-LOCK
                BY ttParam.iSeq:
                {&WRITE-CODE} SUBSTITUTE(
                                "   getInTable(iphndRequestMessage,""&1"",(BUFFER &2:HANDLE)).~n"
                              ,ttParam.cName, ttProcedure.cName + "_" + ttParam.cName).
              END. /** for each ttparam **/

              {&WRITE-CODE} "~n".
          END. /** can-find **/

          /*Llamar al procedimiento*/
          ASSIGN vchrComma = " ".
          IF ttMethod.cName <> "" THEN
          DO:
            {&WRITE-CODE} SUBSTITUTE("   RUN &1Adapter(iphndRequestMessage,iphndResponseMessage).~n",ttProcedure.cName).
            {&WRITE-CODE} SUBSTITUTE("   RUN &1 IN vhnd&2",ttMethod.cName, ichNameSpace + STRING(ttMethod.iProcId)).
          END.
          ELSE
          DO:
            {&WRITE-CODE} SUBSTITUTE("   RUN &1 PERSISTENT SET vhnd&2", ttProcedure.cPath, ichNameSpace + STRING(ttMethod.iProcId)).
          END.

          IF CAN-FIND(FIRST ttParam 
            WHERE ttParam.iProcId = ttMethod.iProcId
              AND ttParam.cMethodName = ttMethod.cName) THEN
          DO:
              {&WRITE-CODE} " (~n".
              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                NO-LOCK
                BY ttParam.iSeq:
                  IF ttParam.cDataType = "TABLE" THEN
                  DO:
                      {&WRITE-CODE} SUBSTITUTE("       &1&2 TABLE &3~n", vchrComma, ttParam.cDirection, ttProcedure.cName + "_" + ttParam.cName).
                  END.
                  ELSE
                  DO:
                      IF ttParam.cDirection = "INPUT" THEN
                      DO:
                          {&WRITE-CODE} SUBSTITUTE("       &1getIn&2(iphndRequestMessage,""&3"")~n", vchrComma, ttParam.cDataType, (IF ttParam.cMethodName = "" THEN ttProcedure.cName + "_" ELSE "") + ttParam.cName).
                      END.
                      ELSE
                      DO:
                          {&WRITE-CODE} SUBSTITUTE("       &1&2 &3~n", vchrComma, ttParam.cDirection, ttParam.cName).
                      END.
                  END.
                  ASSIGN vchrComma = ",".
              END. /** for each ttparam **/
              {&WRITE-CODE} "       )".
          END.
          {&WRITE-CODE} " NO-ERROR.~n".
          {&WRITE-CODE} "~n".

          /*Copiar los valores de las variables de salida*/
          IF CAN-FIND(FIRST ttParam 
              WHERE ttParam.iProcId = ttMethod.iProcId
                AND ttParam.cMethodName = ttMethod.cName
                AND ttParam.cDirection <> "INPUT") THEN
          DO:                                    
              {&WRITE-CODE} "   /*Copiar los valores de las variables de salida*/~n".

              FOR EACH ttParam 
                WHERE ttParam.iProcId = ttMethod.iProcId
                  AND ttParam.cMethodName = ttMethod.cName
                  AND ttParam.cDirection  <> "INPUT"
                NO-LOCK
                BY ttParam.iSeq:
                  IF ttParam.cDataType = "TABLE" THEN
                  DO:
                      /*{&WRITE-CODE} SUBSTITUTE("   setOutTable(iphndResponseMessage,""&1Array"",hnd&2).~n", (IF ttParam.cMethodName = "" THEN ttProcedure.cName + "_" ELSE "") + ttParam.cName, ttProcedure.cName + "_" + ttParam.cName).*/
                      {&WRITE-CODE} SUBSTITUTE("   setOutTable(iphndResponseMessage,""&1"",(BUFFER &2:HANDLE)).~n", ttParam.cName, ttProcedure.cName + "_" + ttParam.cName).
                  END.
                  ELSE
                  DO:
                      /*{&WRITE-CODE} SUBSTITUTE("   setOut&1(iphndResponseMessage,""&2"",&2).~n", ttParam.cDataType, ttParam.cName).*/
                      {&WRITE-CODE} SUBSTITUTE("   setOut&1(iphndResponseMessage,""&2"",&2).~n", ttParam.cDataType, (IF ttParam.cMethodName = "" THEN ttProcedure.cName + "_" ELSE "") + ttParam.cName).
                  END.
              END. /** for each ttparam **/

              {&WRITE-CODE} "~n".
          END. /** can-find **/

          /*Fin del procedimiento Adaptador*/
          {&WRITE-CODE} "END PROCEDURE.~n~n".

      END. /** for each ttmethod **/    
  END. /** for each ttprocedure **/ 
	
  IF ichTemplateFile MATCHES "*.htm*" THEN
  DO:
    {&WRITE-CODE} "</script>~n".
  END.
	
	OUTPUT STREAM strFile CLOSE.
	
RETURN.