
with Interfaces;                               use Interfaces;
with Interfaces.C;                             use Interfaces.C;
with GNATCOM.Types;                            use GNATCOM.Types;
with GNATCOM.VARIANT;                          use GNATCOM.VARIANT;
with GNATCOM.Dispinterface;                    use GNATCOM.Dispinterface;
with GWindows;                                 use GWindows;
with GWindows.Types;                           use GWindows.Types;
with GWindows.GStrings;                        use GWindows.GStrings;
with GNATCOM.BSTR;                             use GNATCOM.BSTR;

with MSHTML.IHTMLWindow2_Interface;            use MSHTML.IHTMLWindow2_Interface;
with MSHTML.IHTMLElementCollection3_Interface; use MSHTML.IHTMLElementCollection3_Interface;

package body HtmlForm is

   procedure onclick (This : HTML_Event_Type)
   is
      pHtmlForm      : Pointer_To_HtmlForm_type := This.pHtmlForm;
      oWindow        : IHTMLWindow2_Type;
      pWindow        : Pointer_To_IHTMLWindow2;
      oEventObj      : IHTMLEventObj_Type;
      pEventObj      : Pointer_To_IHTMLEventObj;
      pElement       : Pointer_To_IHTMLElement;
      oElement       : IHTMLElement_Type;
      DocumentIDisp  : Dispinterface_Type;
      pDocumentIDisp : Pointer_To_IDispatch;
      oHtmlDocument  : IHTMLDocument2_Type;
   begin
      if pHtmlForm.m_pOnClickEvents = null then
	 return;
      end if;
      pDocumentIDisp := Get_Document(pHtmlForm.all.m_oHtmlControl);
      Attach(DocumentIDisp, pDocumentIDisp);
      MSHTML.IHTMLDocument2_Interface.Query(
					    oHtmlDocument,
					    DocumentIDisp
                                           );
      pWindow := Get_parentWindow(oHtmlDocument);
      Attach(oWindow, pWindow);
      pEventObj := Get_event(oWindow);
      Attach(oEventObj, pEventObj);
      pElement := Get_srcElement(oEventObj);
      Attach(oElement, pElement);
      declare
	 sFiredId : GString := To_GString_From_BSTR(Get_id(oElement));
      begin
	 for J in pHtmlForm.m_pOnClickEvents.all'Range loop
	    declare
	       sEntryId : GString := To_GString_From_Unbounded(pHtmlForm.m_pOnClickEvents.all(J).m_usElementName);
	    begin
	       if sFiredId = sEntryId then
		  pHtmlForm.m_pOnClickEvents.all(J).m_pOnEventProc(oEventObj);
		  return;
	       end if;
	    end;
	 end loop;
      end;
   end onclick;

   function Get_title(This : HtmlForm_type) return GString
   is
      DocumentIDisp  : Dispinterface_Type;
      pDocumentIDisp : Pointer_To_IDispatch;
      oHtmlDocument  : IHTMLDocument2_Type;
   begin
      pDocumentIDisp := Get_Document(This.m_oHtmlControl);
      Attach(DocumentIDisp, pDocumentIDisp);
      MSHTML.IHTMLDocument2_Interface.Query(
					    oHtmlDocument,
					    DocumentIDisp
                                           );
      return To_GString_From_BSTR(Get_title(oHtmlDocument));
   end Get_title;

   procedure Create(
		    This           : in out HtmlForm_type;
                    pActivXControl : ActiveX_Access;
		    oHtmlControl   : IWebBrowser2_Type;
		    pOnClickEvents : Pointer_To_Event_Descriptors := null
		   )
   is
      DocumentIDisp  : Dispinterface_Type;
      pDocumentIDisp : Pointer_To_IDispatch;
   begin
      This.m_pActivXControl := pActivXControl;
      This.m_oHtmlControl := oHtmlControl;
      AddRef(This.m_oHtmlControl);
      pDocumentIDisp := Get_Document(This.m_oHtmlControl);
      Attach(DocumentIDisp, pDocumentIDisp);
      MSHTML.IHTMLDocument2_Interface.Query(
					    This.m_oHtmlDocument,
					    DocumentIDisp
                                           );
      AddRef(This.m_oHtmlDocument);
      This.m_pOnClickEvents := pOnClickEvents;
      This.m_HTML_Event_Object.pHtmlForm := This'Unchecked_Access;
      This.m_HTML_Event := MSHTML.HTMLDocumentEvents_Events.Create(This.m_HTML_Event_Object'Unchecked_Access);
      MSHTML.HTMLDocumentEvents_Events.Set_Events(
						  This.m_HTML_Events_CPoint,
						  For_Object      => This.m_oHtmlDocument,
						  Event_Interface => This.m_HTML_Event
						 );
   end Create;

   procedure GetElement(
			This        : in     HtmlForm_type;
			sElementId  : in     GString;
			oElement    : in out Dispinterface_Type;
			bCollection : out    Boolean
		       )
   is
      bstrElementId      : GNATCOM.Types.BSTR := To_BSTR(sElementId);
      pElement           : Pointer_To_IDispatch;
      pHtmlAll           : Pointer_To_IHTMLElementCollection;
      oHtmlAll           : IHTMLElementCollection_Type;
      oHtmlDocument      : IHTMLDocument2_Type := This.m_oHtmlDocument;
      oElementCollection : IHTMLElementCollection3_Type;
   begin
      pHtmlAll := Get_all(oHtmlDocument);
      Attach(oHtmlAll, pHtmlAll);
      Query(oElementCollection, oHtmlAll);
      pElement := namedItem(
		       oElementCollection,
                       name => bstrElementId
                      );
      Attach(oElement, pElement);
      declare
	 oCollection : IHTMLElementCollection_Type;
      begin
	 Query(oCollection, oElement);
	 bCollection := True;
      exception
	 when others =>
	    bCollection := False;
      end;
   end GetElement;

   procedure GetElement(
			This       : in     HtmlForm_type;
			sElementId : in     GString;
			oElement   : in out IHTMLElement_Type
		       )
   is
      oElementDisp : Dispinterface_Type;
      bCollection  : Boolean;
   begin
      GetElement(this, sElementId, oElementDisp, bCollection);
      pragma Assert(not bCollection);
      Query(oElement, oElementDisp);
   end GetElement;

   function GetInnerText(This : IHTMLElement_Type) return GString
   is
      bstrValue : BSTR;
   begin
      bstrValue := Get_innerText(This);
      return To_GString_From_BSTR(bstrValue);
   exception
      when others =>
	 return "";
   end GetInnerText;

   procedure SetInnerText(
			  This   : in out IHTMLElement_Type;
			  sValue : in     GString
			 )
   is
      bstrValue : BSTR := To_BSTR_From_GString(sValue);
   begin
      Put_innerText(This, bstrValue);
   end SetInnerText;

   function GetInnerHTML(This : IHTMLElement_Type) return GString
   is
      bstrValue : BSTR;
   begin
      bstrValue := Get_innerHTML(This);
      return To_GString_From_BSTR(bstrValue);
   exception
      when others =>
	 return "";
   end GetInnerHTML;

   procedure SetInnerHTML(
			  This   : in out IHTMLElement_Type;
			  sValue : in     GString
			 )
   is
      bstrValue : BSTR := To_BSTR_From_GString(sValue);
   begin
      Put_innerHTML(This, bstrValue);
   end SetInnerHTML;

   function GetInnerText(
			 This       : HtmlForm_type;
			 sElementId : GString
			) return GString
   is
      oElement : IHTMLElement_Type;
   begin
      GetElement(This, sElementId, oElement);
      return GetInnerText(oElement);
   exception
      when others =>
	 return "";
   end GetInnerText;

   procedure SetInnerText(
			  This       : in out HtmlForm_type;
			  sElementId : GString;
			  sValue     : GString
			 )
   is
      oDispInterface : Dispinterface_Type;
      bCollection    : Boolean;
      oElement       : IHTMLElement_Type;
      oCollection    : IHTMLElementCollection_Type;
      nLength        : Integer;
      pElement       : Pointer_To_IDispatch;
   begin
      GetElement(
		 This,
		 sElementId,
		 oDispInterface,
		 bCollection
		);
      if not bCollection then
	 Query(oElement, oDispInterface);
	 SetInnerText(oElement, sValue);
	 return;
      end if;
      Query(oCollection, oDispInterface);
      nLength := Integer(Get_length(oCollection));
      for J in 0 .. nLength - 1 loop
	 pElement := item(
		   oCollection,
		   index => To_VARIANT(J)
		  );
	 Attach(oDispInterface, pElement);
	 Query(oElement, oDispInterface);
	 SetInnerText(oElement, sValue);
      end loop;
   end SetInnerText;

   function GetInnerHTML(
			 This       : HtmlForm_type;
			 sElementId : GString
			) return GString
   is
      oElement : IHTMLElement_Type;
   begin
      GetElement(This, sElementId, oElement);
      return GetInnerHTML(oElement);
   exception
      when others =>
	 return "";
   end GetInnerHTML;

   procedure SetInnerHTML(
			  This       : in out HtmlForm_type;
			  sElementId : GString;
			  sValue     : GString
			 )
   is
      oDispInterface : Dispinterface_Type;
      bCollection    : Boolean;
      oElement       : IHTMLElement_Type;
      oCollection    : IHTMLElementCollection_Type;
      nLength        : Integer;
      pElement       : Pointer_To_IDispatch;
   begin
      GetElement(
		 This,
		 sElementId,
		 oDispInterface,
		 bCollection
		);
      if not bCollection then
	 Query(oElement, oDispInterface);
	 SetInnerHTML(oElement, sValue);
	 return;
      end if;
      Query(oCollection, oDispInterface);
      nLength := Integer(Get_length(oCollection));
      for J in 0 .. nLength - 1 loop
	 pElement := item(
		   oCollection,
		   index => To_VARIANT(J)
		  );
	 Attach(oDispInterface, pElement);
	 Query(oElement, oDispInterface);
	 SetInnerHTML(oElement, sValue);
      end loop;
   end SetInnerHTML;

   function GetInputValue(This : IHTMLInputElement_Type) return GString
   is
      bstrValue : BSTR;
   begin
      bstrValue := Get_value(This);
      return To_GString_From_BSTR(bstrValue);
   exception
      when others =>
	 return "";
   end GetInputValue;

   procedure SetInputValue(
			   This   : in out IHTMLInputElement_Type;
			   sValue : in     GString
			  )
   is
      bstrValue : BSTR := To_BSTR_From_GString(sValue);
   begin
      Put_value(This, bstrValue);
   end SetInputValue;

   function GetInputValue(
			  This       : HtmlForm_type;
			  sElementId : GString
			 ) return GString
   is
      oInput      : IHTMLInputElement_Type;
      bCollection : Boolean;
      oElement    : Dispinterface_Type;
   begin
      GetElement(
		 This,
		 sElementId,
		 oElement,
		 bCollection
		);
      pragma Assert(not bCollection);
      Query(oInput, oElement);
      return To_GString_From_BSTR(Get_value(oInput));
   exception
      when others =>
	 return "";
   end GetInputValue;

   procedure SetInputValue(
			   This       : in out HtmlForm_type;
			   sElementId : GString;
			   sValue     : GString
			  )
   is
      oDispInterface : Dispinterface_Type;
      bCollection    : Boolean;
      oInput         : IHTMLInputElement_Type;
      oCollection    : IHTMLElementCollection_Type;
      nLength        : Integer;
      pElement       : Pointer_To_IDispatch;
   begin
      GetElement(
		 This,
		 sElementId,
		 oDispInterface,
		 bCollection
		);
      if not bCollection then
	 Query(oInput, oDispInterface);
	 SetInputValue(oInput, sValue);
	 return;
      end if;
      Query(oCollection, oDispInterface);
      nLength := Integer(Get_length(oCollection));
      for J in 0 .. nLength - 1 loop
	 pElement := item(
		   oCollection,
		   index => To_VARIANT(J)
		  );
	 Attach(oDispInterface, pElement);
	 Query(oInput, oDispInterface);
	 SetInputValue(oInput, sValue);
      end loop;
   end SetInputValue;

   function GetImgSrc(This : IHTMLImgElement_Type) return GString
   is
      bstrValue : BSTR;
   begin
      bstrValue := Get_src(This);
      return To_GString_From_BSTR(bstrValue);
   exception
      when others =>
	 return "";
   end GetImgSrc;

   procedure SetImgSrc(
		       This   : in out IHTMLImgElement_Type;
		       sValue : in     GString
		      )
   is
      bstrValue : BSTR := To_BSTR_From_GString(sValue);
   begin
      Put_src(This, bstrValue);
   end SetImgSrc;

   function GetImgSrc(
		      This       : HtmlForm_type;
		      sElementId : GString
		     ) return GString
   is
      oImage      : IHTMLImgElement_Type;
      bCollection : Boolean;
      oElement    : Dispinterface_Type;
   begin
      GetElement(
		 This,
		 sElementId,
		 oElement,
		 bCollection
		);
      pragma Assert(not bCollection);
      Query(oImage, oElement);
      return To_GString_From_BSTR(Get_src(oImage));
   exception
      when others =>
	 return "";
   end GetImgSrc;

   procedure SetImgSrc(
		       This       : in out HtmlForm_type;
		       sElementId : GString;
		       sValue     : GString
		      )
   is
      oDispInterface : Dispinterface_Type;
      bCollection    : Boolean;
      oImage         : IHTMLImgElement_Type;
      oCollection    : IHTMLElementCollection_Type;
      nLength        : Integer;
      pElement       : Pointer_To_IDispatch;
   begin
      GetElement(
		 This,
		 sElementId,
		 oDispInterface,
		 bCollection
		);
      if not bCollection then
	 Query(oImage, oDispInterface);
	 SetImgSrc(oImage, sValue);
	 return;
      end if;
      Query(oCollection, oDispInterface);
      nLength := Integer(Get_length(oCollection));
      for J in 0 .. nLength - 1 loop
	 pElement := item(
		   oCollection,
		   index => To_VARIANT(J)
		  );
	 Attach(oDispInterface, pElement);
	 Query(oImage, oDispInterface);
	 SetImgSrc(oImage, sValue);
      end loop;
   end SetImgSrc;

   procedure DDX_DHtml_ElementInnerHtml(
					This       : in out HtmlForm_type;
					sElementId : GString;
					usValue    : in out GString_Unbounded;
					bReadOp    : Boolean
				       )
   is
      oElement : IHTMLElement_Type;
   begin
      GetElement(
		 This,
		 sElementId,
		 oElement
		);
      if bReadOp then
	 usValue := To_GString_Unbounded(GetInnerHTML(oElement));
	 return;
      end if;
      SetInnerHTML(oElement, To_GString_From_Unbounded(usValue));
   end DDX_DHtml_ElementInnerHtml;

   procedure UpdateData(
			This       : in out HtmlForm_type;
			bReadOp    : Boolean := False
		       )
   is
   begin
      null;
   end UpdateData;

   procedure DDX_DHtml_ElementInnerText(
					This       : in out HtmlForm_type;
					sElementId : GString;
					usValue    : in out GString_Unbounded;
					bReadOp    : Boolean
				       )
   is
      oElement : IHTMLElement_Type;
   begin
      GetElement(
		 This,
		 sElementId,
		 oElement
		);
      if bReadOp then
	 usValue := To_GString_Unbounded(GetInnerText(oElement));
	 return;
      end if;
      SetInnerText(oElement, To_GString_From_Unbounded(usValue));
   end DDX_DHtml_ElementInnerText;

   procedure DDX_DHtml_InputValue(
				  This       : in out HtmlForm_type;
				  sElementId : GString;
				  usValue    : in out GString_Unbounded;
				  bReadOp    : Boolean
				 )
   is
      oElement    : Dispinterface_Type;
      bCollection : Boolean;
      oInput      : IHTMLInputElement_Type;
   begin
      GetElement(
		 This,
		 sElementId,
		 oElement,
		 bCollection
		);
      pragma Assert(not bCollection);
      Query(oInput, oElement);
      if bReadOp then
	 usValue := To_GString_Unbounded(GetInputValue(oInput));
	 return;
      end if;
      SetInputValue(oInput, To_GString_From_Unbounded(usValue));
   end DDX_DHtml_InputValue;

   procedure DDX_DHtml_Img_Src(
			       This       : in out HtmlForm_type;
			       sElementId : GString;
			       usValue    : in out GString_Unbounded;
			       bReadOp    : Boolean
			      )
   is
      oElement    : Dispinterface_Type;
      bCollection : Boolean;
      oImage      : IHTMLImgElement_Type;
   begin
      GetElement(
		 This,
		 sElementId,
		 oElement,
		 bCollection
		);
      pragma Assert(not bCollection);
      Query(oImage, oElement);
      if bReadOp then
	 usValue := To_GString_Unbounded(GetImgSrc(oImage));
	 return;
      end if;
      SetImgSrc(oImage, To_GString_From_Unbounded(usValue));
   end DDX_DHtml_Img_Src;

end HtmlForm;
