<% class ricoXmlResponse Public orderByRef ' use column numbers in order by clause? (true/false) Public sendDebugMsgs ' send details of sql parsing/execution in ajax response? (true/false) Public AllRowsMax ' max # of rows to send if numrows=-1 Public fmt ' xml, json, html, xl Private objDB,eof,oParse,sqltext,arParams,RowsStart,RowsEnd,SendHdg,Headings,HiddenCols,arDebugMsgs Private Sub Class_Initialize orderByRef=false if IsObject(oDB) then set objDB=oDB ' use oDB global as database connection, if it exists if objDB.Dialect="Access" or objDB.Dialect="MySQL" then orderByRef=true end if sendDebugMsgs=false SendHdg=false AllRowsMax=1999 HiddenCols=Array() redim arParams(-1) redim arDebugMsgs(-1) end sub Public Sub ProcessQuery(id,sqlselect,filters) dim offset,size,total,distinctCol,editCol,closetags,hidden,i,j,u,skip,SkipIdx fmt=trim(Request.QueryString("_fmt")) offset=trim(Request.QueryString("offset")) size=trim(Request.QueryString("page_size")) total=lcase(Request.QueryString("get_total")) distinctCol=trim(Request.QueryString("distinct")) hidden=trim(Request.QueryString("hidden")) editCol=trim(Request.QueryString("edit")) if offset="" then offset="0" if total="" then total="false" if hidden<>"" then HiddenCols=split(hidden,",") Response.clear if fmt<>"xl" then Response.CacheControl = "no-cache" Response.AddHeader "Pragma", "no-cache" Response.Expires = -1 end if select case fmt case "html": Response.ContentType="text/html" Response.write "" & vbLf closetags="" RowsStart=vbLf & "" RowsEnd=vbLf & "
" total="false" sendDebugMsgs=false SendHdg=true case "xl": Response.ContentType="application/vnd.ms-excel" Response.write "" & vbLf closetags="" RowsStart=vbLf & "" RowsEnd=vbLf & "
" total="false" sendDebugMsgs=false SendHdg=true case "json": Response.ContentType="application/json" Response.write "{" & vbLf & """id"":""" & id & """" RowsStart="," & vbLf & """update_ui"":true," & vbLf & """offset"":" & offset & "," & vbLf & """rows"":[" RowsEnd=vbLf & "]" closetags="}" case else: ' default to xml fmt="xml" Response.ContentType="text/xml" Response.write "" response.write vbLf & "" closetags="" RowsStart=vbLf & "" RowsEnd=vbLf & "" end select if id="" then ErrorResponse "No ID provided!" elseif distinctCol="" and not IsNumeric(offset) then ErrorResponse "Invalid offset!" elseif distinctCol="" and not IsNumeric(size) then ErrorResponse "Invalid size!" elseif distinctCol<>"" and not IsNumeric(distinctCol) then ErrorResponse "Invalid distinct parameter!" else if SendHdg and isArray(sqlselect) then ' populate Headings from sqlselect(9) taking into account hidden columns u=ubound(sqlselect(9)) redim Headings(u) SkipIdx=0 j=0 for i=0 to u skip=false if SkipIdx <= ubound(HiddenCols) then skip=CBool(HiddenCols(SkipIdx)=CStr(i)) if skip then SkipIdx=SkipIdx+1 end if if not skip then Headings(j)=sqlselect(9)(i) j=j+1 end if next end if objDB.DisplayErrors=false objDB.ErrMsgFmt="MULTILINE" if distinctCol<>"" and isNumeric(distinctCol) then Query2xmlDistinct sqlselect, CLng(distinctCol), 999, filters elseif editCol<>"" and isNumeric(editCol) and isArray(sqlselect) then Query2xml sqlselect(8)(CLng(editCol)),CLng(offset),CLng(size),(total<>"false"),filters else Query2xml sqlselect,CLng(offset),CLng(size),(total<>"false"),filters end if if not IsEmpty(objDB.LastErrorMsg) then ErrorResponse objDB.LastErrorMsg end if end if if sendDebugMsgs then AppendArrayResponse "debug", arDebugMsgs response.write vbLf & closetags end sub Private sub AddDebugMsg(ByVal msg) ReDim Preserve arDebugMsgs(ubound(arDebugMsgs)+1) arDebugMsgs(ubound(arDebugMsgs))=msg end sub Public Sub ErrorResponse(msg) AppendResponse "error",msg end sub Public Sub AppendResponse(tag,content) select case fmt case "html", "xl": response.write vbLf & "

" & tag & "
" & server.htmlencode(content) & "

" case "json": response.write "," & vbLf & """" & tag & """:""" & escapeJSON(content) & """" case "xml": 'response.write vbLf & "<" & tag & ">" & content & "" response.write vbLf & "<" & tag & ">" & server.htmlencode(content) & "" end select end sub Public Sub AppendArrayResponse(tag, arContent) dim item,i select case fmt case "html", "xl": response.write vbLf & "

" & tag for each item in arContent response.write "
" & server.htmlencode(item) next response.write "

" case "json": response.write "," & vbLf & """" & tag & """:[" for i=0 to ubound(arContent) if i > 0 then response.write "," response.write vbLf & """" & escapeJSON(arContent(i)) & """" next response.write "]" case "xml": for each item in arContent response.write vbLf & "<" & tag & ">" & server.htmlencode(item) & "" next end select end sub ' All Oracle and SQL Server 2005 queries *must* have an ORDER BY clause ' "as" clauses are now ok ' If numrows < 0, then retrieve all rows Public function Query2xml(sqlselect,offset,numrows,gettotal,filters) dim totcnt,version,Dialect set oParse=new sqlParse if IsArray(sqlselect) then oParse.LoadArray(sqlselect) else oParse.ParseSelect sqlselect end if ApplyQStringParms filters response.write RowsStart if numrows >= 0 then Dialect=objDB.Dialect else numrows=AllRowsMax select case Dialect case "TSQL": objDB.SingleRecordQuery "select @@VERSION",version if InStr(version,"SQL Server 2005") > 0 or InStr(version,"SQL Server 2008") > 0 then sqltext=UnparseWithRowNumber(offset,numrows+1,true) totcnt=Query2xmlRaw_Limit(sqltext,offset,numrows,1) else sqltext=oParse.UnparseSelectSkip(HiddenCols) totcnt=Query2xmlRaw_NoLimit(sqltext,offset,numrows,gettotal) end if case "Oracle": sqltext=UnparseWithRowNumber(offset,numrows+1,false) totcnt=Query2xmlRaw_Limit(sqltext,offset,numrows,1) case "MySQL": sqltext=oParse.UnparseSelectSkip(HiddenCols) & " LIMIT " & offset & "," & CStr(numrows+1) totcnt=Query2xmlRaw_Limit(sqltext,offset,numrows,0) case else: sqltext=oParse.UnparseSelectSkip(HiddenCols) totcnt=Query2xmlRaw_NoLimit(sqltext,offset,numrows,gettotal) end select response.write RowsEnd if not eof and gettotal then totcnt=getTotalRowCount if fmt="xml" or fmt="json" then if eof then AppendResponse "rowcount",totcnt end if if sendDebugMsgs then AddDebugMsg sqltext Query2xml=totcnt set oParse=Nothing end function Public sub Query2xmlDistinct(ByVal sqlselect,colnum,maxrows,filters) set oParse=new sqlParse if IsArray(sqlselect) then oParse.LoadArray(sqlselect) else oParse.ParseSelect sqlselect end if if colnum<0 or colnum>ubound(oParse.arSelList) then objDB.LastErrorMsg="Invalid column number for distinct query" exit sub end if ApplyQStringParms filters sqltext=oParse.UnparseDistinctColumn(colnum) response.write RowsStart totcnt=Query2xmlRaw_NoLimit(sqltext,0,maxrows,false) response.write RowsEnd if sendDebugMsgs then AddDebugMsg sqltext set oParse=Nothing end sub ' Tested ok with SQL Server 2005, MySQL, and Oracle Private function getTotalRowCount() dim countSql,cnt countSql="SELECT " & oParse.UnparseColumnList & " FROM " & oParse.FromClause if not IsEmpty(oParse.WhereClause) then countSql=countSql & " WHERE " & oParse.WhereClause if IsArray(oParse.arGroupBy) then if UBound(oParse.arGroupBy)>=0 then countSql=countSql & " GROUP BY " & join(oParse.arGroupBy,",") end if if not IsEmpty(oParse.HavingClause) then countSql=countSql & " HAVING " & oParse.HavingClause countSql="SELECT COUNT(*) FROM (" & countSql & ")" if objDB.Dialect<>"Oracle" then countSql=countSql & " AS rico_Main" if sendDebugMsgs then AddDebugMsg countSql if ubound(arParams) >= 0 then set rsMain = objDB.RunParamQuery(countSql,arParams) else set rsMain = objDB.RunQuery(countSql) end if getTotalRowCount=rsMain.Fields(0).Value objDB.rsClose rsMain eof=true end Function Private function UnparseWithRowNumber(offset,numrows,includeAS) dim unparseText,strOrderBy if IsArray(oParse.arOrderBy) then if UBound(oParse.arOrderBy)>=0 then strOrderBy=join(oParse.arOrderBy,",") end If if IsEmpty(strOrderBy) then ' order by clause should be included in main sql select statement ' However, if it isn't, then use primary key as sort - assuming FromClause is a simple table name strOrderBy=objDB.PrimaryKey(oParse.FromClause) end if unparseText="SELECT ROW_NUMBER() OVER (ORDER BY " & strOrderBy & ") AS rico_rownum," unparseText=unparseText & oParse.UnparseColumnListSkip(HiddenCols) & " FROM " & oParse.FromClause if not IsEmpty(oParse.WhereClause) then unparseText=unparseText & " WHERE " & oParse.WhereClause if IsArray(oParse.arGroupBy) then if UBound(oParse.arGroupBy)>=0 then unparseText=unparseText & " GROUP BY " & join(oParse.arGroupBy,",") end if if not IsEmpty(oParse.HavingClause) then unparseText=unparseText & " HAVING " & oParse.HavingClause unparseText="SELECT * FROM (" & unparseText & ")" if includeAS then unparseText=unparseText & " AS rico_Main" unparseText=unparseText & " WHERE rico_rownum > " & offset & " AND rico_rownum <= " & CStr(offset+numrows) UnparseWithRowNumber=unparseText end Function Public function Query2xmlRaw(ByVal rawsqltext, ByVal offset, ByVal numrows) Query2xmlRaw=Query2xmlRaw_NoLimit(rawsqltext,offset,numrows,true) end Function Public function Query2xmlRaw_NoLimit(ByVal rawsqltext, ByVal offset, ByVal numrows, ByVal gettotal) dim rsMain,totcnt if ubound(arParams) >= 0 then set rsMain = objDB.RunParamQuery(rawsqltext,arParams) else set rsMain = objDB.RunQuery(rawsqltext) end if totcnt=0 eof=true if rsMain is Nothing then exit function while not rsMain.eof and totcnt= 0 then set rsMain = objDB.RunParamQuery(rawsqltext,arParams) else set rsMain = objDB.RunQuery(rawsqltext) end if totcnt=offset eof=true if rsMain is Nothing then exit function select case fmt case "json": totcnt = totcnt + WriteRowsJSON(rsMain, numrows, firstcol) case else: totcnt = totcnt + WriteRowsXHTML(rsMain, numrows, firstcol) end select eof=rsMain.eof objDB.rsClose rsMain Query2xmlRaw_Limit=totcnt end function Private Function WriteRowsXHTML(rsMain, ByVal numrows, ByVal firstcol) dim colcnt,rowcnt,i,n rowcnt=0 colcnt=rsMain.fields.count on error resume next if SendHdg then response.write vbLf & "" for i=firstcol to colcnt-1 n=rsMain.fields(i).name if isArray(Headings) then if not IsEmpty(Headings(i-firstcol)) then n=Headings(i-firstcol) end if response.write XmlStringCell(n) next response.write "" end if while not rsMain.eof and rowcnt" for i=firstcol to colcnt-1 response.write XmlStringCell(FormatValue(rsMain.fields(i).value)) next response.write "" rsMain.movenext wend WriteRowsXHTML=rowcnt end function Private Function WriteRowsJSON(rsMain, ByVal numrows, ByVal firstcol) dim colcnt,rowcnt,i rowcnt=0 colcnt=rsMain.fields.count on error resume next if SendHdg=true then response.write vbLf & "[" for i=firstcol to colcnt-1 n=rsMain.fields(i).name if isArray(Headings) then if not IsEmpty(Headings(i-firstcol)) then n=Headings(i-firstcol) end if response.write """" & escapeJSON(n) & """" next response.write "]" end if while not rsMain.eof and rowcnt0 or SendHdg then response.write "," rowcnt=rowcnt+1 response.write vbLf & "[" for i=firstcol to colcnt-1 if i>firstcol then response.write "," response.write """" & escapeJSON(FormatValue(rsMain.fields(i).value)) & """" next response.write "]" rsMain.movenext wend WriteRowsJSON=rowcnt end function Private Function PadNumber(number, length) dim strNumber if IsNull(number) or IsEmpty(number) then strNumber=String(length,"-") else strNumber = Cstr(number) do while len(strNumber) < length strNumber = "0" & strNumber loop PadNumber=strNumber End Function Private Function FormatValue(s) select case vartype(s) case 11 FormatValue=lcase(s) ' boolean case 7,133,134,135: FormatValue=year(s) & "-" & PadNumber(month(s),2) & "-" & PadNumber(day(s),2) & " " & PadNumber(hour(s),2) & ":" & PadNumber(minute(s),2) & ":" & PadNumber(second(s),2) ' date/time case else FormatValue=s end select End Function Public Sub SetDbConn(dbcls) set objDB=dbcls end Sub Private sub PushParam(ByVal newvalue) ReDim Preserve arParams(ubound(arParams)+1) newvalue=cstr(newvalue) if newvalue="" then newvalue=" " ' empty string gets converted to TEXT data type instead of VARCHAR arParams(ubound(arParams))=newvalue if sendDebugMsgs then AddDebugMsg "Param " & ubound(arParams) & " type=" & typename(newvalue) & " value=" & newvalue end sub ' assumes oParse is already initialized Private sub ApplyQStringParms(filters) dim i,j,newfilter,qs,a,flen,fop,value,blank,param for each qs in Request.QueryString select case left(qs,1) ' user-invoked condition case "w","h": i=mid(qs,2) if IsNumeric(i) and isArray(filters) then i=CInt(i) if i<0 or i>ubound(filters) then exit for value=Request.QueryString(qs) newfilter=filters(i) j=InStr(1,newfilter," in (?)",1) if j>0 then a=split(value,",") for i=0 to ubound(a) PushParam a(i) a(i)="?" next newfilter=left(newfilter,j+4) & join(a,",") & mid(newfilter,j+6) elseif InStr(newfilter,"?")>0 then PushParam value end if if left(qs,1)="h" then oParse.AddHavingCondition newfilter else oParse.AddWhereCondition newfilter end if end if ' sort case "s": i=mid(qs,2) if not IsNumeric(i) then exit for i=CInt(i) if i<0 or i>ubound(oParse.arSelList) then exit for value=ucase(left(Request.QueryString(qs),4)) if value<>"ASC" and value<>"DESC" then value="ASC" if orderByRef then oParse.AddSort CStr(i+1) & " " & value else oParse.AddSort oParse.arSelList(i) & " " & value end if ' user-supplied filter case "f": a=split(qs,"[") if ubound(a)=2 then if a(2)="op]" then i=left(a(1),len(a(1))-1) if not IsNumeric(i) then exit for if len(i)>3 then exit for i=CInt(i) if i<0 or i>ubound(oParse.arSelList) then exit for fop=Request.QueryString(qs) newfilter=oParse.arSelList(i) select case fop case "EQ": newfilter = "(" & AddCoalesce(newfilter) & " IN " & GetMultiParmFilter(qs) & ")" case "LE": newfilter=newfilter & "<=?" PushParam Request.QueryString(replace(qs,"[op]","[0]")) case "GE": newfilter=newfilter & ">=?" PushParam Request.QueryString(replace(qs,"[op]","[0]")) case "NULL": newfilter=newfilter & " is null" case "NOTNULL": newfilter=newfilter & " is not null" case "LIKE": newfilter=newfilter & " LIKE ?" PushParam replace(Request.QueryString(replace(qs,"[op]","[0]")),"*",objDB.Wildcard) case "NE" newfilter = "(" & AddCoalesce(newfilter) & " NOT IN " & GetMultiParmFilter(qs) & ")" end select if (InStr(oParse.arSelList(i),"min(")>0 or _ InStr(oParse.arSelList(i),"max(")>0 or _ InStr(oParse.arSelList(i),"sum(")>0 or _ InStr(oParse.arSelList(i),"count(")>0) and _ InStr(oParse.arSelList(i),"(select ")<1 then oParse.AddHavingCondition newfilter else oParse.AddWhereCondition newfilter end if end if end if end select next end sub Private function AddCoalesce(ByVal newfilter) if objDB.Dialect="Access" then newfilter="iif(IsNull(" & newfilter & "),''," & newfilter & ")" else newfilter="coalesce(" & newfilter & ",'')" end if AddCoalesce=newfilter end function Private function GetMultiParmFilter(ByVal qs) dim flen,j,param,filter flen = Request.QueryString(replace(qs,"[op]","[len]")) if not IsNumeric(flen) then exit function flen = CInt(flen) for j=0 to flen-1 if j>0 then filter=filter & "," filter=filter & "?" param=Request.QueryString(replace(qs,"[op]","[" & j & "]")) PushParam param next GetMultiParmFilter = "(" & filter & ")" end function Public function XmlStringCell(value) dim result if IsNull(value) then result="" else result=server.HTMLEncode(value) if fmt="html" and result="" then result=" " XmlStringCell="" & result & "" end function ' for the root node, parentID should "" (empty string) ' containerORleaf: L/zero (leaf), C/non-zero (container) ' selectable: 0->not selectable, 1->selectable Public sub WriteTreeRow(parentID,ID,description,containerORleaf,selectable) response.write vbLf & "" response.write XmlStringCell(parentID) response.write XmlStringCell(ID) response.write XmlStringCell(description) response.write XmlStringCell(containerORleaf) response.write XmlStringCell(selectable) response.write "" end sub '****************************************************************************************** '' @SDESCRIPTION: takes a given string and makes it JSON valid (http://json.org/) '' @AUTHOR: Michael Rebec '' @DESCRIPTION: all characters which needs to be escaped are beeing replaced by their '' unicode representation according to the '' RFC4627#2.5 - http://www.ietf.org/rfc/rfc4627.txt?number=4627 '' @PARAM: val [string]: value which should be escaped '' @RETURN: [string] JSON valid string '****************************************************************************************** public function escapeJSON(val) const cDoubleQuote = &h22 const cRevSolidus = &h5C const cSolidus = &h2F dim i,currentDigit for i = 1 to (len(val)) currentDigit = mid(val, i, 1) if asc(currentDigit)> &h00 and asc(currentDigit) <&h1F then currentDigit = escapeJSONSquence(currentDigit) elseif asc(currentDigit)>= &hC280 and asc(currentDigit) <= &hC2BF then currentDigit = "\u00" + right(padLeft(hex(asc(currentDigit) - &hC200), 2, 0), 2) elseif asc(currentDigit)>= &hC380 and asc(currentDigit) <= &hC3BF then currentDigit = "\u00" + right(padLeft(hex(asc(currentDigit) - &hC2C0), 2, 0), 2) else select case asc(currentDigit) case cDoubleQuote: currentDigit = escapeJSONSquence(currentDigit) case cRevSolidus: currentDigit = escapeJSONSquence(currentDigit) case cSolidus: currentDigit = escapeJSONSquence(currentDigit) end select end if escapeJSON = escapeJSON & currentDigit next end function function escapeJSONSquence(digit) escapeJSONSquence = "\u00" + right(padLeft(hex(asc(digit)), 2, 0), 2) end function function padLeft(value, totalLength, paddingChar) padLeft = right(clone(paddingChar, totalLength) & value, totalLength) end function public function clone(byVal str, n) dim i for i = 1 to n : clone = clone & str : next end function end class %>