Articles
Contact us |
|
Option Explicit On Module Web2Wap ' Copyright 2000-2004 ' http://network.programming-in.net Public Function ConvertToWML(ByRef HTML As String, Optional ByRef ReRoute As String = Nothing, Optional ByRef MaxSize As Int32 = Nothing) As String Dim firstchar As String Dim NextScrap As Int32 Dim ParsedHTMl As String Dim LastOpenTag As Int32 Dim LastCloseTag As Int32 Dim CutHTML As String Dim NearSpace As Int32 Dim Neartag As Int32 Dim afterchar As String Dim z As Int32 Dim OK As Boolean Dim offset As Int32 Dim Entity As Int32 Dim i As Int32 Dim HTMlpart As String() Dim rtags As String() Dim recognized As String Dim PossibleError As String ' Remove Scripting 'On Error GoTo ThrowException HTML = Replace(HTML, ">>", ">") PossibleError = "Failed to remove <script>" HTML = RemoveEnclosure(HTML, "<script", "</script>") PossibleError = "Failed to remove <!-- .. -->" HTML = RemoveEnclosure(HTML, "<!--", "-->") PossibleError = "Failed to remove <STYLE>" HTML = RemoveEnclosure(HTML, "<STYLE", "</STYLE>") ' Remove Unrecognized tags PossibleError = "Failed to seperate tags" recognized = "br,form,input,a,meta http-equiv=""refresh""" rtags = Split(recognized, ",") HTMlpart = Split(HTML, "&") For i = 1 To UBound(HTMlpart) Entity = InStr(HTMlpart(i), ";") If Entity > 0 And Entity < 8 Then HTMlpart(i) = Mid(HTMlpart(i), Entity + 1) Next HTML = Join(HTMlpart, "") HTMlpart = Split(HTML, "<") For i = 0 To UBound(HTMlpart) If Left(HTMlpart(i), 1) = "/" Then offset = 2 Else offset = 1 End If OK = False For z = 0 To UBound(rtags) afterchar = Mid(HTMlpart(i), offset + Len(rtags(z)), 1) If LCase(Mid(HTMlpart(i), offset, Len(rtags(z)))) = rtags(z) And (afterchar = " " Or afterchar = ">" Or afterchar = Chr(13)) Then OK = True : Exit For End If Next If Not OK Then Neartag = InStr(HTMlpart(i), ">") NearSpace = InStr(HTMlpart(i), " ") If NearSpace > Neartag Or NearSpace = 0 Then NearSpace = Neartag If Neartag * NearSpace = 0 Then GoTo SkipTag HTMlpart(i) = Mid(HTMlpart(i), Neartag + 1) Else HTMlpart(i) = "<" + HTMlpart(i) End If SkipTag: Next PossibleError = "Failed to convert to lowercase" HTML = Join(HTMlpart, "") HTML = LCaseTags(HTML) HTML = Replace(HTML, "<br>", "<br/>") HTML = Replace(HTML, "<br clear=""all"">", "<br/>") HTML = Replace(HTML, " ", "") HTML = LCaseTags(HTML)
If Not IsNothing(MaxSize) Then CutHTML = Left(HTML, MaxSize) LastCloseTag = InStr(StrReverse(CutHTML), ">") LastOpenTag = InStr(StrReverse(CutHTML), "<") If LastCloseTag = 0 Then LastCloseTag = MaxSize * 2 If LastOpenTag = 0 Then LastOpenTag = MaxSize * 2 If LastCloseTag > LastOpenTag Then CutHTML = Left(CutHTML, (MaxSize - LastOpenTag) - 1) HTML = CutHTML End If
HTML = MatchUP(HTML, "a", "href") HTML = Replace(HTML, "$", "$$") PossibleError = "Failed to Parse Form" If IsNothing(ReRoute) Then ParsedHTMl = WMLFORM(HTML) Else ParsedHTMl = WMLFORM(HTML, ReRoute) End If ParsedHTMl = Replace(ParsedHTMl, """""", """") ' clean up tag scraps Do NextScrap = InStr(NextScrap + 1, ParsedHTMl, "<") If NextScrap = 0 Then Exit Do firstchar = Mid(ParsedHTMl, NextScrap + 1, 1) If (firstchar < "a" Or firstchar > "z") And firstchar <> "/" Then ParsedHTMl = Replace(ParsedHTMl, "<" & firstchar, "") End If Loop ConvertToWML = "<?xml version=""1.0"" encoding=""ISO-8859-1""?>" & vbCrLf & "<wml><card><p align=""left"">" & vbCrLf & ParsedHTMl & vbCrLf & "</p></card></wml>" Exit Function ThrowException: ConvertToWML = "<?xml version=""1.0"" encoding=""ISO-8859-1""?>" & vbCrLf & "<wml><card><p align=""left"">" & vbCrLf & "ERR:" & PossibleError & vbCrLf & Err.Description & vbCrLf & "</p></card></wml>" End Function Public Function UrlEncode(ByRef PlainText As String) As String Dim HexPart As String Dim z As Int32 Dim OK As Boolean Dim i As Int32 Dim rtags As String() Dim recognised As String recognised = "*,+,-,.,0,1,2,3,4,5,6,7,8,9,_," & "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z," & "a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z" ' the symbol / was removed from the recognised list. rtags = Split(recognised, ",") Dim Ptags(Len(PlainText)) As String For i = 1 To Len(PlainText) Ptags(i) = Mid(PlainText, i, 1) OK = False For z = 0 To UBound(rtags) If Ptags(i) = rtags(z) Then OK = True : Exit For End If Next If Not OK Then HexPart = Hex(Asc(Ptags(i))) If Len(HexPart) = 1 Then HexPart = "0" + HexPart Ptags(i) = "%" + HexPart End If Next UrlEncode = Join(Ptags, "") End Function Function GetParam(ByRef Rawtext As String, ByRef After As Int32) As String Dim FirstEdge As Int32 Dim FirstSpace As Int32 Dim lastic As Int32 Dim firstic As Int32 Dim ic As String Dim start As Int32 start = InStr(1, Rawtext, After, CompareMethod.Text) If start = 0 Then Exit Function If InStr(start, Rawtext, """") = 0 Then ic = "'" If InStr(start, Rawtext, "'") = 0 Then ic = """" If ic = "" And InStr(start, Rawtext, "'") < InStr(start, Rawtext, """") Then ic = "'" ' check for un-bracketed param firstic = InStr(start, Rawtext, ic) lastic = InStr(firstic + 1, Rawtext, ic) FirstSpace = InStr(start, Rawtext, " ") FirstEdge = InStr(start, Rawtext, ">") If FirstSpace = 0 Then FirstSpace = Len(Rawtext) * 2 If FirstEdge = 0 Then FirstEdge = Len(Rawtext) * 2 If firstic = 0 Then firstic = Len(Rawtext) * 2 If lastic = 0 Then lastic = Len(Rawtext) * 2 If FirstEdge < FirstSpace Then FirstSpace = FirstEdge If FirstSpace < firstic Or ic = "" Then lastic = FirstSpace firstic = InStr(start, Rawtext, "=") End If If firstic > lastic Then GetParam = "" : Exit Function End If If Mid(Rawtext, firstic + 1, 1) = """" Then firstic = firstic + 1 lastic = InStr(firstic + 1, Rawtext, """") End If GetParam = Mid(Rawtext, firstic + 1, lastic - firstic - 1) End Function Function WMLFORM(ByRef HTML As String, Optional ByRef ReRoute As String = Nothing) As String Dim wml As String Dim FormString As String Dim Paramstring As String Dim refid As Int32 Dim SubmitLine As String Dim submitlabel As String Dim corrected As String Dim InputTag As String Dim Nextinput As Int32 Dim cpos As Int32 Dim storedform As String Dim cgi As String Dim postform As String Dim startformline As String Dim endform As Int32 Dim startform As Int32 Dim killinputs As Boolean Dim RedirectWML As String Dim toURL As String Dim TimeToLoad As Int32 Dim EndOfline As Int32 Dim content As String Dim Redirectpos As Int32 Dim ic As String Dim nl As String Dim vbcrf As Int32 'On Error GoTo 0 nl = vbcrf ic = """" Redirectpos = InStr(1, HTML, "<meta http-equiv=""refresh""", CompareMethod.Text) If Redirectpos Then content = GetParam(Mid(HTML, Redirectpos), "content") EndOfline = InStr(Redirectpos, HTML, ">") HTML = Replace(HTML, Mid(HTML, Redirectpos, EndOfline - Redirectpos + 1), "") TimeToLoad = Val(content) toURL = Mid(content, InStr(1, content, "URL=", CompareMethod.Text) + 4) If Not IsNothing(ReRoute) Then ' Reroute is in the format: http://server/Gateway?URL=docroot/ If InStr(toURL, "//") Then toURL = Left(ReRoute, InStr(ReRoute, "=") + 1) & UrlEncode(toURL) Else toURL = ReRoute & UrlEncode(toURL) End If End If ' How do I redirect to same page in WML?, i.e. if ToUrl="" RedirectWML = "<onevent type=""ontimer"">" & vbCrLf & " <go href=""" + toURL + """/>" & vbCrLf & "</onevent>" & vbCrLf & "<timer value=""" & TimeToLoad & """/>" & vbCrLf End If killinputs = False Do startform = InStr(startform + 1, HTML, "<form", CompareMethod.Text) endform = InStr(endform + 1, HTML, "</form>", CompareMethod.Text) If endform = 0 Then endform = Len(HTML) killinputs = True If startform <> 0 Then startformline = Mid(HTML, startform, InStr(startform, HTML, ">") - startform + 1) HTML = Replace(HTML, startformline, "") End If Exit Do End If If LCase(GetParam(Mid(HTML, startform), "method")) = "post" Then postform = True startformline = Mid(HTML, startform, InStr(startform, HTML, ">") - startform + 1) cgi = GetParam(startformline, "action") If cgi <> "" Then Exit Do HTML = Replace(HTML, startformline, "", , 1) HTML = Replace(HTML, "</form>", "", , 1, CompareMethod.Text) Loop If Not killinputs Then storedform = Mid(HTML, startform, endform - startform) & "</form>" HTML = RemoveEnclosure(HTML, "<form", "</form>") HTML = Left(HTML, startform) & storedform & Mid(HTML, startform) If Not IsNothing(ReRoute) Then If InStr(cgi, "//") Then cgi = Left(ReRoute, InStr(ReRoute, "=")) & UrlEncode(cgi) Else cgi = ReRoute & UrlEncode(cgi) End If End If End If cpos = startform Do Nextinput = InStr(cpos + 1, HTML, "<input", CompareMethod.Text) If Nextinput = 0 Or Nextinput > endform Then Exit Do InputTag = Mid(HTML, Nextinput) InputTag = Left(InputTag, InStr(InputTag, ">")) If killinputs Then HTML = Replace(HTML, InputTag, "") Else If LCase(GetParam(InputTag, "type")) = "submit" Then corrected = InputTag submitlabel = GetParam(Mid(HTML, Nextinput), "value") If submitlabel = "" Then submitlabel = "Submit" EndOfline = InStr(Nextinput, HTML, ">") SubmitLine = Mid(HTML, Nextinput, EndOfline - Nextinput + 1) Else refid = GetParam(Mid(HTML, Nextinput), "name") If refid <> "" Then corrected = "<input name=""" & refid & """/>" Else corrected = "" End If If refid <> "" Then If postform Then Paramstring = Paramstring + "<postfield name=""" + refid + """ value=""$(" + refid + ")""/>" + vbCrLf Else Paramstring = Paramstring + UrlEncode(refid) + "=$(" + refid + ")&" End If End If End If HTML = Replace(HTML, InputTag, corrected) End If cpos = Nextinput Loop If killinputs Then WMLFORM = RedirectWML + HTML Else If Not postform Then Paramstring = Left(Paramstring, Len(Paramstring) - 1) HTML = Replace(HTML, startformline, "") HTML = Replace(HTML, SubmitLine, "") wml = FormString + vbCrLf If submitlabel = "" Then submitlabel = "submit" wml = wml + "<do type=" + ic + "accept" + ic + " label=" + ic + submitlabel + ic + ">" + vbCrLf If postform Then wml = wml + "<go href=""" + cgi + """ method=""Post"">" + vbCrLf wml = wml + Paramstring wml = wml + "</go>" Else wml = wml + " <go href=" + ic + cgi + "?" + Paramstring + ic + "/>" + vbCrLf End If wml = wml + "</do>" + vbCrLf WMLFORM = RedirectWML + Replace(HTML, "</form>", wml, , , CompareMethod.Text) End If End Function Private Function LCaseTags(ByRef HTML As String) As String Dim NewHTML As String Dim Char_Renamed As String Dim i As Int32 Dim Intag As Boolean Intag = False For i = 1 To Len(HTML) Char_Renamed = Mid(HTML, i, 1) If Char_Renamed = "<" Then Intag = True If Char_Renamed = ">" Then Intag = False If Intag Then Char_Renamed = LCase(Char_Renamed) NewHTML = NewHTML + Char_Renamed Next LCaseTags = NewHTML End Function Public Function RemoveEnclosure(ByRef HTML As String, ByRef StartTag As String, ByRef EndTag As String) As String Dim ScriptEnd As Int32 Dim ScriptStart As Int32 Do ScriptStart = InStr(1, HTML, StartTag, CompareMethod.Text) ScriptEnd = InStr(1, HTML, EndTag, CompareMethod.Text) If ScriptStart * ScriptEnd = 0 Then Exit Do If ScriptEnd > ScriptStart Then HTML = Left(HTML, ScriptStart - 1) & Mid(HTML, ScriptEnd + Len(EndTag)) Else Exit Do End If Loop RemoveEnclosure = HTML End Function
Public Function MatchUP(ByRef HTML As String, ByRef Tag As String, Optional ByRef PreserveParam As String = Nothing) As String Dim Preserved As Boolean Dim theLink As String Dim NextTag As Int32 Dim Char_Renamed As String Dim i As Int32 Dim State As String State = "/" Do i = InStr(i + 1, HTML, "<") If i = 0 Then Exit Do Char_Renamed = LCase(Mid(HTML, i, Len(Tag) + 2)) If Left(Char_Renamed, 2) = "<" & Tag Then If State = "A" Then NextTag = InStr(i, HTML, ">") HTML = Left(HTML, i - 1) & Mid(HTML, NextTag + 1) i = i - 1 Else If Not IsNothing(PreserveParam) Then theLink = GetParam(Mid(HTML, i), PreserveParam) Preserved = " " & PreserveParam & "=""" & theLink & """" End If NextTag = InStr(i, HTML, ">") HTML = Left(HTML, i - 1) & "<" & Tag & Preserved & ">" & Mid(HTML, NextTag + 1) State = "A" End If End If If Char_Renamed = "</" & Tag Then If State = "/" Then NextTag = InStr(i, HTML, ">") HTML = Left(HTML, i - 1) & Mid(HTML, NextTag + 1) i = i - 1 End If State = "/" End If Loop If State = "A" Then HTML = HTML & "</" & Tag & ">" MatchUP = HTML End Function End Module Copyright 2012 Open Merchant Account Ltd. 
|
