Import initial din SVN ROAAUTO/Trunk @HEAD

COMUN/utile/web/wwxmlhttp.prg

@@ -0,0 +1,192 @@
+#DEFINE FLAG_ICC_FORCE_CONNECTION 0x01
+*!*	http://www.mfinante.ro/contribuabili/link.jsp?body=/cod.do
+*!*	cod=1879855
+Clear 
+SET PROCEDURE TO D:\ROA_RB\ROACONT\COMUN\PROGRAME\OPROCEDURI_COMUNE.PRG ADDITIVE 
+LOCAL lcResponse, lnResponse, loMyXMLHTTP
+
+loHTTP = CREATEOBJECT("Microsoft.XMLHTTP")
+loHTTP.OPEN("POST", [http://www.mfinante.ro/contribuabili/link.jsp?body=/cod.do], .F.)
+loHTTP.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded')
+
+lcValues = "cod=18798551"
+loHTTP.SEND(lcValues)
+
+lnStatus = loHTTP.STATUS
+lcResponse =  UPPER(loHTTP.responseText)
+
+lnLinii = ALines(laLines,lcResponse)
+
+lcDenumire = laLines[670]
+lnPos1 = Rat('>',lcDenumire,3)
+lnPos2 = Rat('<',lcDenumire,2)
+lcDenumire = Substr(lcDenumire, lnPos1 + 1, lnPos2 - lnPos1 - 1)
+*MessageBox(lcDenumire)
+*!*	MESSAGEBOX(lnStatus )
+*!*	 NU EXISTA AGENT ECONOMIC CU ACEST COD
+	STRTOFILE(lcResponse,"c:\test.htm")
+	OPEN_DEFAULT_APP("c:\test.htm")
+
+DEFINE CLASS myXMLHTTP AS CUSTOM
+
+	oHTTP = NULL
+
+	cHost = ""
+	nError = 0
+	cError = ""
+
+	PROCEDURE INIT
+		LPARAMETERS tcHost
+		IF PCOUNT() = 1 AND TYPE('tcHost') = 'C' AND !EMPTY(tcHost)
+			THIS.cHost = tcHost
+		ENDIF
+*!*			THIS.oHTTP = CREATEOBJECT("Microsoft.XMLHTTP")
+		THIS.oHTTP = CREATEOBJECT("MSXML2.ServerXMLHTTP")
+
+	ENDPROC && init
+
+	FUNCTION CHECK_INTERNET
+
+		DECLARE INTEGER InternetCheckConnection IN wininet ;
+			STRING lpszUrlSTRING, INTEGER dwFlags, INTEGER dwReserved
+
+		myHost = THIS.cHost
+
+		RETURN InternetCheckConnection(myHost,FLAG_ICC_FORCE_CONNECTION,0)
+	ENDFUNC && CHECK_INTERNET
+
+	FUNCTION post
+		LPARAMETERS tcValues, tcResponse
+
+		LOCAL lcValues, loHTTP, lcResponse, lnResponse
+		LOCAL llAsincron
+		llAsincron = .T.
+		lnResponse = 1
+		tcResponse = ""
+		lcResponse = ""
+		IF .F.
+			* NU MAI VERIFIC CONEXIUNEA LA INTERNET - DACA ROUTERUL NU ARE INTERNET STA 21 SECUNDE SA VERIFICE :(
+			* POSTEZ EROAREA ASINCRON - DACA ARE INTERNET O TRIMITE
+			lnCheckInternet = THIS.CHECK_INTERNET()
+			IF lnCheckInternet <= 0
+				RETURN
+			ENDIF
+		ENDIF 	
+		IF EMPTY(THIS.cHost)
+			RETURN
+		ENDIF
+		IF TYPE('this.oHTTP') = "O"
+			loHTTP = THIS.oHTTP
+			lcHost= THIS.cHost
+
+			loHTTP.OPEN("POST", lcHost, llAsincron)
+			loHTTP.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded')
+
+			lcValues = tcValues
+			loHTTP.SEND(lcValues)
+
+			IF .F.
+				*!* DACA FOLOSESC XMLHTTP ASINCRON TREBUIE SA ASTEPT READYSTATE = 4 IN DO WHILE
+				lnStatus = loHTTP.STATUS
+				tcResponse =  UPPER(loHTTP.responseText)
+				lnResponse = IIF('SUCCES'$tcResponse,1,-1)
+			ENDIF 
+		ENDIF
+
+		RETURN lnResponse
+
+	ENDFUNC && post
+
+	FUNCTION postError
+		LPARAMETERS tcErrorMsg, tcUserName, tcProgram, tcVersion, tcDatabaseUser
+
+		LOCAL lcValues, lcError, lcUserName, lcProgram, lnResponse, lcVersion, lcDatabaseUser
+		LOCAL laVersion
+		DIMENSION laVersion[12]
+
+		lcError = ALLTRIM(TRANSFORM(tcErrorMsg))
+		lcUserName = ALLTRIM(TRANSFORM(tcUserName))
+		lcProgram = ALLTRIM(TRANSFORM(tcProgram))
+
+		IF EMPTY(tcVersion) OR TYPE('tcVersion') <> 'C'
+			lnVersion = AGETFILEVERSION(laVersion, SYS(16,0))
+			IF lnVersion >= 4
+				lcVersion = laVersion[4]
+			ELSE
+				lcVersion = ""
+			ENDIF
+		ELSE
+			lcVersion = ALLTRIM(tcVersion)
+		ENDIF
+
+		IF EMPTY(tcDatabaseUser) OR TYPE('tcDataBaseUser') <> 'C'
+*!*	modificare	ROASTART	v 2.0.29
+*!*				lcDatabaseUser = IIF(TYPE('gcs') = 'C', gcS, "")
+			lcDatabaseUser = IIF(TYPE('gcs') = 'C', gcS, IIF(TYPE('gcHost') = 'C',gcHost, ""))
+*!*	modificare	ROASTART	v 2.0.29	^
+		ELSE
+			lcDatabaseUser = tcDatabaseUser
+		ENDIF
+
+		lcError = THIS.urlencode(lcError)
+
+		lcValues = "error[errormsg]=" + lcError + "&error[username]=" + lcUserName + "&error[program]=" + lcProgram + ;
+			"&error[version]=" + lcVersion + "&error[databaseuser]=" + lcDatabaseUser
+
+		lnResponse = THIS.post(lcValues)
+
+		RETURN lnResponse
+
+	ENDFUNC && postError
+
+	PROCEDURE ERROR
+		LPARAMETERS nError,cMethod,nLine
+
+		lcErrorMsg=MESSAGE()+CHR(13)+CHR(13)
+		lcErrorMsg=lcErrorMsg+"Method:    "+cMethod
+		lcCodeLineMsg=MESSAGE(1)
+		IF BETWEEN(nLine,1,10000) AND NOT lcCodeLineMsg="..."
+			lcErrorMsg=lcErrorMsg+CHR(13)+"Line:         "+ALLTRIM(STR(nLine))
+			IF NOT EMPTY(lcCodeLineMsg)
+				lcErrorMsg=lcErrorMsg+CHR(13)+CHR(13)+lcCodeLineMsg
+			ENDIF
+		ENDIF
+
+		MESSAGEBOX(lcErrorMsg)
+
+	ENDPROC && error
+
+	FUNCTION urlencode
+		*
+		* from http://www.tek-tips.com/gviewthread.cfm/lev2/4/lev3/27/pid/184/qid/597112
+		* also http://fox.wikis.com/wc.dll?Wiki~VFPPortListener~VFP
+		* I'm confused by this code.
+		* I believe it doesn't translate spaces correctly
+		*
+		* a proper definition is in: http://www.ietf.org/rfc/rfc2396.txt
+		* starting about half way down page 5
+		* unreserved characters include all alphas, all digits and the following unreserved marks
+		* mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")"
+		*
+		LPARAMETER pcinstr
+		* ' encode Percent signs
+		* ' Double Quotes
+		* ' CarriageReturn / LineFeeds
+		LOCAL lcout, lni
+		lcout = ''
+		FOR lni = 1 TO LEN(pcinstr)
+			lcch = SUBSTR(pcinstr,lni,1)
+			DO CASE
+				CASE ISALPHA(lcch) OR ISDIGIT(lcch) OR INLIST(lcch, "-" , "_" , "." , "!" , "~" , "*" , "'" , "(" , ")")
+					* do nothing
+				CASE lcch = " "
+					lcch = "+"
+				OTHERWISE
+					lcch = '%' + RIGHT( TRANSFORM(ASC(lcch),'@0'), 2 )
+			ENDCASE
+			lcout = lcout + lcch
+		ENDFOR
+		RETURN lcout
+	ENDFUNC && UrlEncode
+
+ENDDEFINE