viewData_Old.asp

<%@ Language=VBScript EnableSessionState= False Transaction=Required %>
<% Option Explicit %>
<% ' to force authentication for connection to SQL Server
   If Request.ServerVariables("AUTH_USER") = "" Then
      Response.Status = "401 Access Denied"
      Response.End
   End If
%>
<% Response.Buffer = True
   Response.Expires = 0
   Response.ContentType = "text/xml" %>
<?xml version="1.0" encoding="UTF-8" ?>
<% Dim procName, tableName, fieldList, whereID, sortBy, search, qryString
   Dim oRs, oCmd, oNLS, oSearch, flushCount

   ' Turned on to catch SQL Server errors
   ' On Error Resume Next
   
   Set oNLS = Nothing

   tableName = Request.QueryString("tableName")
   If tableName="" Or IsEmpty(tableName) Then
   
      procName = Request.QueryString("procName")
      If procName="" Or IsEmpty(procName) Then
         Response.Write "<url-error>Missing required parameter: tableName or procName</url-error>" 
         Response.End 
      End if

      Set oCmd = Server.CreateObject("ADODB.Command")
      With oCmd
         .ActiveConnection = Application("Eval_ConnectionString")
         .CommandText = procName
         .CommandType = adCmdStoredProc
         .CommandTimeout = 30
         Call appendParams(oCmd)
         Set oRs = .Execute
      End With
      If Err.Number <> 0 Then ReportError

   Else
      
      fieldList = Request.QueryString("fieldList")
      If fieldList="" Or IsEmpty(fieldList) Then
         fieldList = "*"
      End If
   
      qryString = qryString & "SELECT " & fieldList & " FROM [" & tableName & "] AS t"

      whereID = Request.QueryString("whereID")
      If Not (whereID="" Or IsEmpty(whereID)) Then 
         qryString = qryString & " WHERE " & tableName & "Id=" & CLng(whereID)
      Else
         'Full-text search
         search = Request.QueryString("search")
         If Not (search="" Or IsEmpty(search)) Then
            Set oSearch = Server.CreateObject("CML.Search")
            oSearch.SearchString = search
            qryString = qryString & " WHERE CONTAINS(t.*,N'" & oSearch.SearchString & "')"
         End If
      End If 

      sortBy = Request.QueryString("sortBy")
      If Not (sortBy="" Or IsEmpty(sortBy)) Then 
         qryString = qryString & " ORDER BY " & sortBy
      End If 
         
      Set oRs = Server.CreateObject("ADODB.Recordset")
      'Using adOpenStatic to find the value of RecordCount
      oRs.Open qryString,Application("Eval_ConnectionString"),adOpenStatic
      If Err.Number <> 0 Then ReportError

   End If
   
   Call EmitDTD(oRs)
   
   Response.Write "<xmldata>" & vbCrLf
   
   Do Until oRs Is Nothing
      If Not oRs.EOF Then Call Convert(oRs)
      Set oRs = oRs.NextRecordset 
   Loop
   
   Response.Write "</xmldata>"

' Emit the Document Type Definition for the XML stream
' NOTE: all recordsets must comply with this definition
' SETS GLOBALS: flushCount
Sub EmitDTD(oRs)
   Dim oField, sRec, recSize, sSep
   
   ' emit DTD (and detect ID field)
   sRec = "<!DOCTYPE xmldata [" & vbCrLf & vbCrLf & _
          "<!ELEMENT xmldata (record)+>" & vbCrLf & _
          "<!ELEMENT record ("
          
   sSep = ""
   For Each oField In oRs.Fields
      sRec = sRec & sSep & oField.Name
      If oField.Attributes And adFldIsNullable Then
         sRec = sRec & "?"
      End If
      sSep = ","
   Next
   
   sRec = sRec & ")>" & vbCrLf
   
   ' once more for each field name
   For Each oField In oRs.Fields
      sRec = sRec & "<!ELEMENT " & oField.Name & " (#PCDATA)>" & vbCrLf
      recSize = recSize + oField.DefinedSize + Len(oField.Name)*2
   Next
   sRec = sRec & vbCrLf & _
                 "<!ATTLIST record" & vbCrLf & _
                 "          id ID #REQUIRED" & vbCrLf & _
                 " >" & vbCrLf & vbCrLf & _
                 "]>" & vbCrLf & vbCrLf
                 
   Response.Write sRec
   
   ' calculate flush period based on approximate size of record
   flushCount = CInt(4096/recSize) + 1
End Sub   

' Returns the most likely ID field (for use by ID attribute of record)
Function GetIDField(oRs)
   Dim oField
   Set GetIDField = Nothing
   For Each oField In oRs.Fields
      If oField.Attributes = adFldFixed Then
         Set GetIDField = oField
         Exit For
      End If
   Next
   If GetIDField Is Nothing Then Set GetIDField = oRs(0)
End Function

' Convert the current recordset to XML stream
' USES GLOBALS: flushCount, oNLS
Sub Convert(oRs)
   Dim oField, oIDField, vValue, sRec
   
   Set oIDField = GetIDField(oRs)
   
   Do While Not oRs.EOF
      sRec = "<record id='_" & oIDField.Value & "'> " & vbCrLf  
      For Each oField In oRs.Fields
         vValue = oField.Value   ' check for null value carefully, esp. nTEXT type
         If Not (IsNull(vValue) Or vValue="") Then
            sRec = sRec & "<" & oField.Name & ">"
            Select Case oField.Type
            Case adCurrency:
               ' BUG: reformatting insufficient -- must convert value from db locale
               ' BUG: server default locale is used (not user locale)
               sRec = sRec & GetNLS.FormatLocaleCurrency(0,vValue)
            Case adDate, adDBDate, adDBFileTime, adDBTime, adDBTimeStamp, adFileTime:
               ' BUG: time value does not incorporate timezone info
               ' BUG: server default locale is used (not user locale)
               sRec = sRec & GetNLS.FormatLocaleDateTime(0,vValue)
            Case adDecimal, adDouble, adNumeric:
               ' BUG: server default locale is used (not user locale)
               sRec = sRec & GetNLS.FormatLocaleNumber(0,vValue)
            Case adChapter:
               ' Hierarchical recordset, make recursive call
               If Not vValue.EOF Then Convert(vValue)
            Case Else:
               ' Treat all other records as text
               sRec = sRec & Server.HTMLEncode(vValue)
            End Select
            sRec = sRec & "</" & oField.Name & ">" & vbCrLf
         End If
      Next
      sRec = sRec & "</record>" & vbCrLf
      Response.Write sRec
      If oRs.RecordCount Mod flushCount = 0 Then Response.Flush
      oRs.MoveNext 
   Loop
End Sub

' Get an instance of the NLS object
' SET GLOBALS: oNLS
Function GetNLS()
   If oNLS Is Nothing Then
      Set oNLS = Server.CreateObject("NLS.Formats")
   End If
   Set GetNLS = oNLS
End Function

' Copy stored proc parameters from QueryString (URL)
' SET GLOBALS: oCmd.Parameters
Sub appendParams(oCmd)
   Dim param,name,value
   With oCmd
      .Parameters.Refresh 
      'Copy values frm FORM into PARAMETERS collection
      For Each param In .Parameters
         If param.Direction = adParamInput Then
            name =  Mid(param.Name,2)
            value = Request.QueryString(name)
            'Response.Write "DEBUG: url value '" & name & "' = '" & value & "'<BR>"
            param.Value = value
         End If
      Next
   End With
End Sub

' Format error, and END
Sub ReportError()
   Response.Write "<xmldata>" & vbCrLf & _
                  "<error>" & vbCrLf & _
                  "<number>" & Hex(Err.Number) & "</number>" & vbCrLf & _
                  "<description>" & Err.Description & "</description>" & vbCrLf & _
                  "<source>" & Err.Source & "</source>" & vbCrLf & _
                  "</error>" & vbCrLf & _
                  "</xmldata>"
   Response.End
End Sub
%>