%
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 & ""
total="false"
sendDebugMsgs=false
SendHdg=true
case "xl":
Response.ContentType="application/vnd.ms-excel"
Response.write "" & vbLf
closetags=""
RowsStart=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 & "" & tag & ">"
response.write vbLf & "<" & tag & ">" & server.htmlencode(content) & "" & tag & ">"
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) & "" & tag & ">"
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
%>