401 Unauthorized" _
& VbNewLine & ""
response.end
End If
On Error GoTo 0
i = 0
For Each thing In oFiles
If bShowFile(Thing) Then
On Error Resume Next
ArrFiles(i,ColumnOrdinal_LastModified) = thing.datelastmodified
ArrFiles(i,ColumnOrdinal_Size) = thing.size
ArrFiles(i,ColumnOrdinal_Filename) = thing.name
ArrFiles(i,ColumnOrdinal_CanViewSource) = False 'set default
For j = 0 To UBound(arrSourceViewFilenameExtensions)
If LCase(ext(thing.name)) = LCase(arrSourceViewFilenameExtensions(j)) Then
ArrFiles(i,ColumnOrdinal_CanViewSource) = True
End If
Next
If bViewSource Then
If LCase(thing.path) = LCase(Server.MapPath(FolderSpec) & "\" & FileSpec) Then
bRequestedSourceFileFound = True
End If
End If
On Error GoTo 0
i = i + 1
End If
Next
If Not bRequestedSourceFileFound Then bViewSource = False
i = 0
For each thing in oFolders
If bShowFile(Thing) Then
On Error Resume Next
ArrFolders(i,ColumnOrdinal_LastModified) = thing.datelastmodified
ArrFolders(i,ColumnOrdinal_Size) = thing.size
ArrFolders(i,ColumnOrdinal_Filename) = thing.name
On Error GoTo 0
i = i + 1
End If
Next
If Sort <> DefaultSort Then
If ubound(arrFiles,1) > 0 Then Call QuickSort(arrFiles, 0, ubound(arrFiles,1), cint(sort))
If ubound(arrFolders,1) > 0 Then Call QuickSort(arrFolders, 0, ubound(arrFolders,1), cint(sort))
End if
PageTitle = PageTitle & " - " & FolderSpec
If bViewSource Then PageTitle = PageTitle & "/" & FileSpec & " (Source)"
End Sub
'___________________________________________________________________
Sub ScriptTerminate
On Error Resume Next
Set oFiles = nothing
Set oFolders = nothing
Set oFolder = nothing
Set oFso = Nothing
On Error GoTo 0
End Sub
'###########################################################################
'#
'# Secondary Functions
'#
'##########
'___________________________________________________________________
Sub DumpFilesList(FolderSpec, ArrFiles, lo, hi, mark)
'==-----------------------------------------==
'== Print out an array from the lo bound ==
'== to the hi bound. Highlight the column ==
'== whose number matches parm mark ==
'==-----------------------------------------==
Dim Row,Column
Dim Filename
Dim v
For Row = lo to hi
Filename = FolderSpec & "/" & ArrFiles(Row, ColumnOrdinal_Filename)
If LCase(Filename) <> LCase(PathInfo()) Then
echo ""
For Column = 0 to Ubound(ArrFiles,2)
v = ArrFiles(Row,Column)
If Column = mark then
echo "| "
Else
echo " | "
End If
If VarType(v) <> 0 Then
if Column = ColumnOrdinal_Filename then
echo "" & v & ""
If ArrFiles(Row,ColumnOrdinal_CanViewSource) And bAllowViewSource Then
If Column = mark then
echo " | (view source)"
Else
echo " | (view source)"
End If
' echo " |
Else
If Column = mark then
echo " | "
Else
echo " | "
End If
End If
ElseIf Column = ColumnOrdinal_Size Then
echo FormatNumber(v, 0)
ElseIf Column = ColumnOrdinal_LastModified Then
echo FormatDateTime(DateValue(v), VbShortDate) & " | " & FormatDateTime(TimeValue(v), VbShortTime)
ElseIf column = ColumnOrdinal_CanViewSource Then
'do nothing
Else
echo v
End If
End If
response.write " | "
Next
echo "
"
End If
Next
End Sub 'PrintArray
Const BgColor_Dark = "#EEEEEE"
Const BgColor_Light = "#FFFFEE"
Dim BgColor_Now
Function BgColor()
If BgColor_Now = BgColor_Light Then
BgColor_Now = BgColor_Dark
Else
BgColor_Now = BgColor_Light
End If
BgColor = BgColor_Now
End Function
'___________________________________________________________________
Sub DumpFoldersList(ByVal ArrFolders,lo,hi,mark)
'==-----------------------------------------==
'== Print out an array from the lo bound ==
'== to the hi bound. Highlight the column ==
'== whose number matches parm mark ==
'==-----------------------------------------==
Dim Row, Column
Dim Data
For Row = lo to hi
echo ""
For Column = 0 to Ubound(ArrFolders,2)
Data = ArrFolders(Row, Column)
If Column = mark then
echo "| "
Else
echo " | "
End If
If Column = ColumnOrdinal_Filename Then
if vartype(data) = 0 then
response.write " "
else
echo "" & Data & ""
end if
If Column = mark then
echo " | "
Else
echo " | "
End If
ElseIf Column = ColumnOrdinal_Size Then
if vartype(data) = 0 then
response.write " "
else
Echo FormatNumber(Data, 0)
end if
ElseIf Column = ColumnOrdinal_LastModified Then
if vartype(data) = 0 then
echo " | "
else
echo FormatDateTime(DateValue(Data), VbShortDate)
echo " | "
echo FormatDateTime(TimeValue(Data), VbShortTime)
end if
Else
if vartype(data) = 0 then
response.write " "
else
Response.Write Data
end if
End If
response.write " | "
Next
echo "
"
Next
End Sub
'___________________________________________________________________
Sub DumpSource(ByRef fso, ByVal VPath)
Dim tso, buffer, i
Dim NewBuffer
Dim CursorPos
Dim Needle
Dim c, cPrefix, cPostfix
Dim LN
Dim bWaitingForMoreChars
Dim bInsideASP
Dim bCommentOn
Dim bInsideQuote
Dim cLast
LN = 1
Set tso = fso.opentextfile(server.mappath(VPath))
Set NewBuffer = CreateObject("ADODB.Stream")
NewBuffer.Type = 2 'String
NewBuffer.Open
echo ""
If bShowLineNumbers Then
response.write " Turn off line numbering"
Else
response.write " Turn on line numbering"
End If
If bShowSyntaxHighlighting Then
response.write " Turn off syntax highlighting"
Else
response.write " Turn on syntax highlighting"
End If
echo ""
If bShowSyntaxHighlighting Then
echo ""
bInsideASP = False
bWaitingForMoreChars = False
bCommentOn = False
bInsideQuote = False
Buffer = Tso.ReadAll
Response.Write ""
For i = 1 To Len(Buffer)
cPrefix = ""
cPostfix = ""
c = Mid(Buffer, i, 1)
If bInsideAsp Then
Select Case C
Case ">"
If Not bInsideQuote Then
If bWaitingForMoreChars Then
bInsideAsp = False
cPrefix = ""
cPostfix = ""
End If
End If
bWaitingForMoreChars = False
Case VbCr
If Not bInsideQuote Then
If bCommentOn Then
bCommentOn = False
cPostfix = ""
End If
End If
bWaitingForMoreChars = False
Case "%" 'stop right here, wait to see if next char is a greater than symbol.
If Not bInsideQuote Then
bWaitingForMoreChars = True
End If
Case "'"
If Not bInsideQuote Then
bCommentOn = True
cPrefix = ""
End If
bWaitingForMoreChars = False
Case Chr(34)
If Not bCommentOn Then
If bInsideQuote Then
bInsideQuote = False
cPostfix = ""
Else
bInsideQuote = True
cPrefix = ""
End If
End If
bWaitingForMoreChars = False
Case Else
bWaitingForMoreChars = False
End Select
Else
If bWaitingForMoreChars Then
If c = "%" Then
bInsideAsp = True
cPrefix = ""
cPostFix = ""
End If
bWaitingForMoreChars = False
Else
If c = "<" Then 'stop right here, wait to see if next char is a percent symbol.
bWaitingForMoreChars = True
Else
bWaitingForMoreChars = False
End If
End If
End If
If bShowLineNumbers Then
If c = VbLf Then
LN = LN + 1
End If
If i = 1 Then
response.write "" & LN & "" & VbTab
Else
If c = VbLf Then
cpostfix = cpostfix & "" & LN & "" & VbTab
End If
End If
End If
If bWaitingForMoreChars Then
cLast = cLast & C
Else
Response.Write cPrefix & server.htmlencode(cLast & C) & cPostfix
cLast = ""
End If
Next
Else
Do While Not tso.atendofstream
i = i + 1
response.write vbnewline
If bShowLineNumbers Then response.write "" & i & "" & VbTab
response.write server.htmlencode(tso.readline)
Loop
End If
tso.close
Set tso = Nothing
NewBuffer.Position = 0
Response.Write NewBuffer.ReadText
NewBuffer.Close
Set NewBuffer = Nothing
echo ""
End Sub
'###########################################################################
'#
'# Tertiary Functions and Utilities
'#
'##########
'___________________________________________________________________
Function FilenameAsUrl(s)
FilenameAsUrl = Replace(Server.UrlEncode(oFso.GetBaseName(s)),"+","%20") & Ext(s)
End Function
'___________________________________________________________________
'EXT RETURNS THE dot IN THE FILENAME
function ext(byval fname)
If InStr(fname, ".") > 0 Then
ext = lcase(mid(fname,inStrRev(fname,".")))
Else
ext = ""
End If
end function
'___________________________________________________________________
Function ColumnClass(i)
Select Case i
case ColumnOrdinal_LastModified
ColumnClass = "lm"
case ColumnOrdinal_Size
ColumnClass = "sz"
case ColumnOrdinal_Filename
ColumnClass = "fn"
End Select
End Function
'___________________________________________________________________
Function P()
p = Request.ServerVariables("PATH_INFO")
End Function
'___________________________________________________________________
'Replacement for Server.MapPath
Function MapPath(ByVal path)
Dim i
Dim arrBadChars
Dim arrDidReplace
Dim arrGoodChars
arrBadChars = Array(";" ,"," ,"'" ,"]")
arrDidReplace = Array(False ,False ,False ,False)
arrGoodChars = Array("%3B" ,"%2C" ,"%27" ,"%5D")
For i = 0 To UBound(arrBadChars)
If InStr(path, arrBadChars(i)) > 0 Then
path = Replace(path, arrBadChars(i), arrGoodChars(i))
arrDidReplace(i) = True
End If
Next
Path = Server.MapPath(path)
For i = 0 To UBound(arrBadChars)
If arrDidReplace(i) Then
Path = Replace(path, arrGoodChars(i), arrBadChars(i))
End If
Next
MapPath = Path
End Function
' ________________________________________
Function TypeCast(ByVal What, ByVal WhatType, ByVal DefaultValue)
Dim result, i
if vartype(What) = WhatType Then
result = What ' no problem! lets split and get back to work.
else
' not specifically that type.
' Ok, lets try and convert it.
on error resume next
select case WhatType
case vbInteger
result = CInt(what)
case vbLong
result = CLng(what)
case vbSingle
result = CSng(what)
case vbDouble
result = CDbl(what)
case vbCurrency
result = CCur(what)
case vbDate
result = CDate(what)
case vbString
result = CStr(what)
case vbBoolean
result = CBool(what)
case vbByte
result = CByte(what)
case VbEnum '### NOTE!! IMPORTANT!! VbEnum is NOT a built-in vb value:
' This is something that I made up myself-
' you MUST declare VbEnum as a global CONST
' for this to work!!!! (i use 100 - its far enough away
' from any other VbXXX constants that its not likely to
' interfereany time soon)
'to use this option, pass an ARRAY of possible enum values
' in the "DefaultValue" argument.
' If "what" does not match any of the values of the array,
' then TypeCast() will return the first value in the array.
'echo "; what=" & what & " " & typename(what)
for i = 0 to ubound(DefaultValue)
if what = DefaultValue(i) then
result = what
exit for
else
result = defaultValue(0)
end if
next
end select
if err.number <> 0 then
Result = DefaultValue 'sorry pal. you trying to fake us out. no soup for you.
end if
on error goto 0
End If
TypeCast = result
End Function
'__________________________________________________________
'__________________________________________________________
Function pathinfo()
pathinfo = Request.ServerVariables("PATH_INFO")
End Function
'************************************************************************
' Just an error-free wrapper. Especially handy in the case of html-encoding values
' directly from an SQL recordset, because "Server.HtmlEncode" chokes on nulls.
'___________________________________________________________________
Function HtmlEncode(s)
HtmlEncode = Server.HtmlEncode(Typecast(s,VbString,""))
End Function
'____________________________________________________________________
Function echo(s)
Response.write vbnewline & s
End Function
'______________________________________________________________________________
Function bDeveloperMode
Dim Result
Result = False
If request.servervariables("REMOTE_ADDR") = "64.251.68.235" _
or request.servervariables("REMOTE_ADDR") = "64.251.68.238" _
or request.servervariables("REMOTE_ADDR") = "64.251.68.232" _
Then
Result = True
End If
bDeveloperMode = Result
End Function
'___________________________________________________________________
Sub Debug(s)
DebugL "Debug", s
End Sub
'___________________________________________________________________
Sub DebugL(label, value)
If bDeveloperMode Then
echo "
" _
& " " & htmlencode(label) & ":" _
& " " & HtmlEncode(value) & "" _
& " (" & TypeName(value) & ")" _
& "
"
End If
End Sub
'___________________________________________________________________
Sub DebugE(s)
Dim ErrorCheck
On Error Resume Next
ErrorCheck = eval(s)
ErrorCheck = err.number
On Error GoTo 0
If ErrorCheck = 0 Then
If Not IsEmpty(Eval(s)) Then
DebugL s, eval(s)
Else
DebugL "Debug:", s
End If
Else
DebugL "Debug:", s
End If
End Sub
'___________________________________________________________________
Function bFilenameHasIllegalChars(byVal s, bIgnoreSlashes)
dim i 'as integer - used for incrementing through each character of the string
dim Result 'as boolean - status of our investigating
dim c 'as string - each piece of the string as we move through it
dim a 'as integer - the numeric Ascii value of c
' looks for any non alphanumeric characters, returns false if the string is 'clean'
Result = False 'innocent until proven guilty.
If VarType(s) <> VbString Then
Result = True
Else
for i = 1 to len(s)
c = mid(s,i,1)
a = asc(c)
Select Case True
' (n.p ), ", *, :, <, >, ?, |
Case (a <= 31)
'not printable
Result = True
Exit For
Case (a = 34 Or a = 42 or a = 58 or a = 60 or a = 62 or a = 63 or a = 124)
'is an illegal character.
Result = True
Exit For
' /, \
Case (a = 47 Or a = 92)
'is a back or forward slash
If Not bIgnoreSlashes Then
Result = True
Exit For
End If
Case True
'is printable and not illegal. don't do anything.
End Select
Next
End If
bFilenameHasIllegalChars = Result
End Function
'___________________________________________________________________
Function bShowFile(ByRef objFile)
Dim Result
Dim Attributes, Hidden, System, Alias
Result = True
Attributes = objFile.attributes
Hidden = cbool(attributes and FileAttribute_Hidden)
System = cbool(attributes and FileAttribute_System)
Alias = cbool(attributes and FileAttribute_Alias)
dim ppath
Dim vpath
ppath = objFile.path
vpath = Replace(ppath, DefaultPhysPath, "")
vpath = replace(vpath, "\", "/")
if InArray(vpath, arrPathsToExclude) Then
Result = False
End If
If StrComp(DefaultVpath & vpath, PathInfo(), VbTextCompare) = 0 then
Result = False
End If
if Alias then
if not ShowAlias Then Result = False
end if
If Hidden Then
If Not ShowHidden Then Result = False
end if
If System Then
If Not SHowSystem Then Result = False
End If
bShowFile = Result
End Function
'___________________________________________________________________
sub echo(s)
response.write vbnewline & s
end sub
'___________________________________________________________________
sub br(s)
echo "
" & s
end sub
'___________________________________________________________________
Function Table(s)
table = VbNewLine & "