<% '===================================================== 'SITEMASTERMIND ENTERPRISE - NOV2007 'FOR 2008 RELEASE BETA 1.1 'Author by Steve Spencer - ihost technologies 'Copyright 2007 ihost technologies - webmastermind.com '===================================================== dim smversion smversion = "v 1.0" 'GLOBAL CONFIGS -- 1 'GLOBAL SYSTEM FILE -- 2 strURL = "http://jtbakeries.com/" FromEmail = "info@jtbakeries.com" FromEmailName = "JT Bakeries" dim strImgPath,strURL,strMainPath,strManageURL,strImgPhysPath,strImgURLPath,strconfigdomaincgi,ImagerPath dim strXMLURLPath,strXMLPhysPath, strManagePhysPath 'Web Site Physical Path strMainPath = Request.ServerVariables("APPL_PHYSICAL_PATH") ' strURL = "http://" & request.ServerVariables("SERVER_NAME") & "/" strManageURL = strURL & "assets/core/" strManagePhysPath = strMainPath & "assets\core\" strImgPhysPath = strMainPath & "assets\usrfiles\" strImgURLPath = strURL & "assets/usrfiles/" strDocPhysPath = strMainPath & "assets\usrdocs\" strDocURLPath = strURL & "assets/usrdocs/" strXMLPhysPath = strMainPath & "assets\usrxml\" strXMLURLPath = strURL & "assets/usrxml/" SiteTitle = "StarCOM Data Documents" SiteEmail = "info@starcomdata.com" strconfigdomaincgi = strURL & "assets" ImagerPath = strconfigdomaincgi 'response.write strconfigdomaincgi & "|" & strImgPhysPath 'FIGHTING THE IE CACHE! '====================== 'date in the past... Response.AddHeader "Expires", "Mon, 26 Jul 1997 05:00:00 GMT" Response.AddHeader "Last-Modified", Now & " GMT" Response.AddHeader "Cache-Control", "no-cache, must-revalidate" Response.AddHeader "Pragma", "no-cache" Response.Expires = 0 'DEBUGGING / TESTING - TURN IT ON OR OFF if request("debugon") <> "" then Session("debugon") = "ok" elseif request("debugoff") <> "" then Session("debugon") = "nope" end if if Session("debugon") = "ok" then else 'On Error Resume Next end if 'QUERYSTRINGS, PATH VARIABLES Dim todo, profiledisplay, t, docid t = request("t") docid = request("docid") 'GET OUR LAST LOCATION Sub GetReturnPath() mystring = request.ServerVariables("HTTP_REFERER") mypage = Split(mystring,"?",2) response.write mypage(1) End Sub 'GLOBAL SYSTEM FILE -- 2 '======================== dim GetTheDate,theyear 'what year are we in theyear = Year(now()) 'MySQL Friendly Date GetTheDate = Year(now()) & "-" & Month(now()) &"-" & day(now()) & " " & FormatDateTime(now(),4) Function GetRemoteAddy userIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If userIP = "" Then userIP = Request.ServerVariables("REMOTE_ADDR") End If GetRemoteAddy = userIP End Function 'INCLUDE OTHER SYSTEM FILES '========================== %> <% '###GLOBAL FUNCTIONS '###================================== 'Used throughout all the system files '###================================== 'Strip data for insertion to DB, make it safe to avoid SQl Injection attacks '## ========== FUNCTION sqlSafe(my_string,dowhat) if dowhat = "return" then sqlSafe = my_string elseif dowhat = "store" or dowhat = "" then if isnull(my_string) then sqlSafe = my_string else strOutput = my_string 'Replace all < and > with < and > 'strOutput = Replace(strOutput, "<", "<") ' strOutput = Replace(strOutput, ">", ">") strOutput = Replace(strOutput, "&", "&") strOutput = Replace(strOutput, "'", "'") strOutput = replace(strOutput,chr(39),"''") strOutput = replace(strOutput,chr(145),"''") strOutput = replace(strOutput,chr(146),"''") strOutput = replace(strOutput,chr(147),"""") strOutput = replace(strOutput,chr(148),"""") sqlSafe = strOutput 'Return the value of strOutput end if else sqlSafe = my_string end if END FUNCTION '## ========== FUNCTION FixBadCharacters() End Function '## FOR EVENTUAL TRASHING '## Functions to eventually phase out.. FUNCTION ReplaceIt2(my_string,uselessold) if uselessold = "return" or uselessold = "" then strOutput = Replace(my_string,"&","&") strOutput = Replace(strOutput, "&amp;lt;", "<") strOutput = Replace(strOutput, "&amp;gt;", ">") strOutput = Replace(strOutput, "&lt;", "<") strOutput = Replace(strOutput, "&gt;", ">") strOutput = Replace(strOutput, "<", "<") strOutput = Replace(strOutput, ">", ">") strOutput = Replace(strOutput, "&amp;#39","'") strOutput = replace(strOutput,"&#39;","'") strOutput = Replace(strOutput,"&amp;amp;#39","'") strOutput = Replace(strOutput, "'","'") strOutput = Replace(strOutput, "’","'") strOutput = replace(strOutput,"''",chr(39)) strOutput = replace(strOutput,"''",chr(145)) strOutput = replace(strOutput,"''",chr(146)) 'strOutput = replace(strOutput,"""",chr(147)) ' strOutput = replace(strOutput,"""",chr(148)) ReplaceIt2 = strOutput elseif uselessold = "vmessage" or uselessold = "" then 'strOutput = replace(my_string,vbnewline,"&lt;br&gt;") strOutput = Replace(my_string,"&","&") strOutput = Replace(strOutput, "&amp;lt;", "<") strOutput = Replace(strOutput, "&amp;gt;", ">") strOutput = Replace(strOutput, "&lt;", "<") strOutput = Replace(strOutput, "&gt;", ">") strOutput = Replace(strOutput, "<", "<") strOutput = Replace(strOutput, ">", ">") strOutput = Replace(strOutput, "&amp;#39","'") strOutput = replace(strOutput,"&#39;","'") strOutput = Replace(strOutput,"&amp;amp;#39","'") strOutput = Replace(strOutput, "'","'") strOutput = Replace(strOutput, "’","'") strOutput = replace(strOutput,"''",chr(39)) strOutput = replace(strOutput,"''",chr(145)) strOutput = replace(strOutput,"''",chr(146)) 'strOutput = replace(strOutput,"""",chr(147)) ' strOutput = replace(strOutput,"""",chr(148)) ReplaceIt2 = strOutput elseif uselessold = "store" then if isnull(my_string) then ReplaceIt2 = my_string else strOutput = my_string 'Replace all < and > with < and > strOutput = Replace(strOutput, "<", "<") strOutput = Replace(strOutput, ">", ">") strOutput = Replace(strOutput, "&", "&") strOutput = Replace(strOutput, "'", "'") strOutput = Replace(strOutput, "&", "&") strOutput = Replace(strOutput, "'", "'") ReplaceIt2 = strOutput 'Return the value of strOutput end if else ReplaceIt2 = my_string end if END FUNCTION '## ========== '### PAGING THE QUERY '### ======================================================= 'CREATE PAGING Dim sProjectCount Dim intRecordsPerPage Dim intPages Dim sLimitPart 'LIMIT 0,1 -----> LIMIT {START_NUMBER,RECORDS_PERPAGE} Dim sStartQuery Dim sMaxStart Dim sProjectPrev Dim sProjectNext Dim sTotalRecs Dim strRecperPg Function BuildPagedDisplay(strRecperPg,sTotalRecs) intRecordsPerPage = strRecperPg 'How many records to show per page sProjectCount = sTotalRecs 'response.write intRecordsPerPage & "|" & sProjectCount '# SIMPLE PAGING ========================= sStartQuery = Request.QueryString("start") 'Get total pages If intRecordsPerPage < sProjectCount then intPages = sProjectCount / intRecordsPerPage End If 'here we modify the number if it has a decimal, a better solution maybe would be to use formatnumber Dim instrIntPages instrIntPages = Instr(intPages,".") 'If after the decimal there is a 0 then we need to add a page If instrIntPages > 0 then intPages = Left(intPages,instrIntPages) + 1 End If 'Lets create the limit for the sql 'LIMIT 0,1 -----> LIMIT {START_NUMBER,RECORDS_PERPAGE} If sStartQuery <> "" AND isNumeric(sStartQuery) then sLimitPart = "LIMIT " & sStartQuery & "," & intRecordsPerPage Else sLimitPart = "LIMIT " & "0," & intRecordsPerPage End If 'Lets figure out what the max start number is sMaxStart = (intPages*intRecordsPerPage)-intRecordsPerPage If sStartQuery <> "" AND isNumeric(sStartQuery) then sStartQuery = CINT(sStartQuery) Else sStartQuery = 0 End If 'Now lets create our previous / next buttons and disable them if they are not needed. If sMaxStart < 0 then sMaxStart = 0 If sStartQuery = "" or sStartQuery = "0" then 'PREVIOUS DISABLED sProjectPrev = " " & noprevbutton ElseIf sStartQuery > 0 then 'PREVIOUS ENABLED sProjectPrev = sProjectPrev & "" sProjectPrev = sProjectPrev & prevbutton & " " End If 'Next If sMaxStart = sStartQuery then 'NEXT DISABLED sProjectNext = " " & nonextbutton ElseIf sStartQuery < sMaxStart then 'NEXT ENABLED sProjectNext = sProjectNext & " " sProjectNext = sProjectNext & nextbutton & "" End If End Function Public function Paging(strshowpages) 'Customize me to your liking... 'Assumes that the paging request variable is named 'page' Dim strQueryString Dim strScript Dim intStart Dim intEnd Dim i Dim intPage intPage = 0 if Not IsEmpty(Request("page")) Then if IsNumeric(Request("page")) Then intPage = CLng(Request("page")) End if End if 'response.write intPages intPageCount = intPages intRecordCount = sProjectCount if intPage > intPageCount Then intPage = intPageCount ElseIf intPage < 1 Then intPage = 1 End if if intRecordCount = 0 Then 'Paging = "No Records Found" ElseIf intPageCount = 1 Then 'Paging = "All Records Shown" Else For i = 1 To Request.QueryString.Count if LCase(Request.QueryString.Key(i)) <> "page" and LCase(Request.QueryString.Key(i)) <> "start" Then strQueryString = strQueryString & "&" strQueryString = strQueryString & Server.URLEncode(Request.QueryString.Key(i)) & "=" strQueryString = strQueryString & Server.URLEncode(Request.QueryString.Item(i)) End if Next For i = 1 To Request.Form.Count if LCase(Request.Form.Key(i)) <> "page" and LCase(Request.Form.Key(i)) <> "start" Then strQueryString = strQueryString & "&" strQueryString = strQueryString & Server.URLEncode(Request.Form.Key(i)) & "=" strQueryString = strQueryString & Server.URLEncode(Request.Form.Item(i)) End if Next if Len(strQueryString) <> 0 Then strQueryString = "?" & Mid(strQueryString, 2) & "&" Else strQueryString = "?" End if strScript = Request.ServerVariables("SCRIPT_NAME") & strQueryString if intPage <= strshowpages Then intStart = 1 Else if (intPage Mod strshowpages) = 0 Then intStart = intPage - (strshowpages - 1) Else intStart = intPage - (intPage Mod strshowpages) + 1 End if End if intEnd = intStart + (strshowpages - 1) if intEnd > intPageCount Then intEnd = intPageCount if intPageCount = 0 then sintPageCount = 1 else sintPageCount = intPageCount end if Paging = "Page " & intPage & " of " & sintPageCount & ": " Dim sPREV, sNEXT sPREV = sStartQuery - intRecordsPerPage sNEXT = sStartQuery + intRecordsPerPage if intPage <> 1 and la = 1 Then Paging = Paging & "«« " End if if intPage <> 1 Then Paging = Paging & "«« " End if For i = intStart To intEnd if i = intPage Then Paging = Paging & "" & i & " " Else Dim start start = 0 Paging = Paging & "" & i & "" if i <> intEnd Then Paging = Paging & " " End if Next if intPageCount < 2 then else if intPage <> intPageCount Then Paging = Paging & " »» " End if end if End if End function '## ========== %> <% '### FILE MANAGEMENT FUNCTIONS '### ========================= Dim doctitle, docheading, docdateupdated, doccontent Function LoadFileToEdit(pageid) 'response.write strXMLPhysPath & pageid & ".xml" Dim xml Set xml = Server.CreateObject("Microsoft.XMLDOM") xml.async = False xml.load (strXMLPhysPath & pageid & ".xml") doctitle = xml.documentElement.childNodes(0).text docheading = xml.documentElement.childNodes(1).text docdateupdated = xml.documentElement.childNodes(2).text doccontent = xml.documentElement.childNodes(3).text Set xml = Nothing End Function Function SaveFileToEdit(pageid) doctitle = trim(request("doctitle")) docheading = trim(request("doctitle")) docdateupdated = now() doccontent = trim(request("thedoc")) if doctitle = "" then doctitle = pageid end if if doctitle = "" then docheading = pageid end if if doccontent = "" then doccontent = "My page content" end if 'Does file exist?\ dim fs set fs=Server.CreateObject("Scripting.FileSystemObject") if fs.FileExists(strXMLPhysPath & pageid & ".xml") = true then strdate = Replace(Replace(GetTheDate," ","-"),":","")& ".xml" fs.CopyFile strXMLPhysPath & pageid & ".xml",strXMLPhysPath & "bu\" & pageid & "." & strdate set fs=nothing else end if 'Copy current with naming convention of: pagename-date.xml 'else overwrite or create the file 'end it 'response.ContentType="text/xml" strxmlcontent = "" _ & "" _ & ""&doctitle&"" _ & ""&docheading&"" _ & ""&GetTheDate&"" _ & "" _ & "" file_being_created = strXMLPhysPath & pageid & ".xml" set fs = createobject("scripting.filesystemobject") Set act = fs.CreateTextFile(file_being_created, true) 'Write output to the top of the html document act.WriteLine(strxmlcontent) act.close Set fs = Nothing End Function Function PermittedExtensions() End Function Dim strImageExtensions strImageExtensions = "jpg,jpeg,gif,bmp,png,tiff,tif,tga" 'checkFileExt(sFileExt,strImageExtensions) function checkFileExt(sFile,sExtAllowed) Set fs=Server.CreateObject("Scripting.FileSystemObject") checkFileExt = false dim i dim arrExt arrExt = split(sExtAllowed,",") for i = 0 to ubound(arrExt) if lcase(fs.GetExtensionName(strImgPhysPath & sFile)) = lcase(arrExt(i)) then checkFileExt = true exit function end if next set fs=nothing end function %> <% ' For examples, documentation, and your own free copy, go to: ' http://www.freeaspupload.net ' Note: You can copy and use this script for free and you can make changes ' to the code, but you cannot remove the above comment. 'Changes: 'Aug 2, 2005: Add support for checkboxes and other input elements with multiple values Class FreeASPUpload Public UploadedFiles Public FormElements Private VarArrayBinRequest Private StreamRequest Private uploadedYet Private Sub Class_Initialize() Set UploadedFiles = Server.CreateObject("Scripting.Dictionary") Set FormElements = Server.CreateObject("Scripting.Dictionary") Set StreamRequest = Server.CreateObject("ADODB.Stream") StreamRequest.Type = 1 'adTypeBinary StreamRequest.Open uploadedYet = false End Sub Private Sub Class_Terminate() If IsObject(UploadedFiles) Then UploadedFiles.RemoveAll() Set UploadedFiles = Nothing End If If IsObject(FormElements) Then FormElements.RemoveAll() Set FormElements = Nothing End If StreamRequest.Close Set StreamRequest = Nothing End Sub Public Property Get Form(sIndex) Form = "" If FormElements.Exists(LCase(sIndex)) Then Form = FormElements.Item(LCase(sIndex)) End Property Public Property Get Files() Files = UploadedFiles.Items End Property 'Calls Upload to extract the data from the binary request and then saves the uploaded files Public Sub Save(path) Dim streamFile, fileItem if Right(path, 1) <> "\" then path = path & "\" if not uploadedYet then Upload For Each fileItem In UploadedFiles.Items Set streamFile = Server.CreateObject("ADODB.Stream") streamFile.Type = 1 streamFile.Open StreamRequest.Position=fileItem.Start StreamRequest.CopyTo streamFile, fileItem.Length streamFile.SaveToFile path & fileItem.FileName, 2 streamFile.close Set streamFile = Nothing fileItem.Path = path & fileItem.FileName Next End Sub Public Function SaveBinRequest(path) ' For debugging purposes StreamRequest.SaveToFile path & "\debugStream.bin", 2 End Function Public Sub DumpData() 'only works if files are plain text Dim i, aKeys, f response.write "Form Items:
" aKeys = FormElements.Keys For i = 0 To FormElements.Count -1 ' Iterate the array response.write aKeys(i) & " = " & FormElements.Item(aKeys(i)) & "
" Next response.write "Uploaded Files:
" For Each f In UploadedFiles.Items response.write "Name: " & f.FileName & "
" response.write "Type: " & f.ContentType & "
" response.write "Start: " & f.Start & "
" response.write "Size: " & f.Length & "
" Next End Sub Private Sub Upload() Dim nCurPos, nDataBoundPos, nLastSepPos Dim nPosFile, nPosBound Dim sFieldName, osPathSep, auxStr 'RFC1867 Tokens Dim vDataSep Dim tNewLine, tDoubleQuotes, tTerm, tFilename, tName, tContentDisp, tContentType tNewLine = Byte2String(Chr(13)) tDoubleQuotes = Byte2String(Chr(34)) tTerm = Byte2String("--") tFilename = Byte2String("filename=""") tName = Byte2String("name=""") tContentDisp = Byte2String("Content-Disposition") tContentType = Byte2String("Content-Type:") uploadedYet = true on error resume next VarArrayBinRequest = Request.BinaryRead(Request.TotalBytes) if Err.Number <> 0 then response.write "

System reported this error:

" response.write Err.Description & "

" response.write "The most likely cause for this error is the incorrect setup of AspMaxRequestEntityAllowed in IIS MetaBase. Please see instructions in the requirements page of freeaspupload.net.

" Exit Sub end if on error goto 0 'reset error handling nCurPos = FindToken(tNewLine,1) 'Note: nCurPos is 1-based (and so is InstrB, MidB, etc) If nCurPos <= 1 Then Exit Sub 'vDataSep is a separator like -----------------------------21763138716045 vDataSep = MidB(VarArrayBinRequest, 1, nCurPos-1) 'Start of current separator nDataBoundPos = 1 'Beginning of last line nLastSepPos = FindToken(vDataSep & tTerm, 1) Do Until nDataBoundPos = nLastSepPos nCurPos = SkipToken(tContentDisp, nDataBoundPos) nCurPos = SkipToken(tName, nCurPos) sFieldName = ExtractField(tDoubleQuotes, nCurPos) nPosFile = FindToken(tFilename, nCurPos) nPosBound = FindToken(vDataSep, nCurPos) If nPosFile <> 0 And nPosFile < nPosBound Then Dim oUploadFile Set oUploadFile = New UploadedFile nCurPos = SkipToken(tFilename, nCurPos) auxStr = ExtractField(tDoubleQuotes, nCurPos) ' We are interested only in the name of the file, not the whole path ' Path separator is \ in windows, / in UNIX ' While IE seems to put the whole pathname in the stream, Mozilla seem to ' only put the actual file name, so UNIX paths may be rare. But not impossible. osPathSep = "\" if InStr(auxStr, osPathSep) = 0 then osPathSep = "/" oUploadFile.FileName = Right(auxStr, Len(auxStr)-InStrRev(auxStr, osPathSep)) if (Len(oUploadFile.FileName) > 0) then 'File field not left empty nCurPos = SkipToken(tContentType, nCurPos) auxStr = ExtractField(tNewLine, nCurPos) ' NN on UNIX puts things like this in the streaa: ' ?? python py type=?? python application/x-python oUploadFile.ContentType = Right(auxStr, Len(auxStr)-InStrRev(auxStr, " ")) nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line oUploadFile.Start = nCurPos-1 oUploadFile.Length = FindToken(vDataSep, nCurPos) - 2 - nCurPos If oUploadFile.Length > 0 Then UploadedFiles.Add LCase(sFieldName), oUploadFile End If Else Dim nEndOfData nCurPos = FindToken(tNewLine, nCurPos) + 4 'skip empty line nEndOfData = FindToken(vDataSep, nCurPos) - 2 If Not FormElements.Exists(LCase(sFieldName)) Then FormElements.Add LCase(sFieldName), String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos)) else FormElements.Item(LCase(sFieldName))= FormElements.Item(LCase(sFieldName)) & ", " & String2Byte(MidB(VarArrayBinRequest, nCurPos, nEndOfData-nCurPos)) end if End If 'Advance to next separator nDataBoundPos = FindToken(vDataSep, nCurPos) Loop StreamRequest.Write(VarArrayBinRequest) End Sub Private Function SkipToken(sToken, nStart) SkipToken = InstrB(nStart, VarArrayBinRequest, sToken) If SkipToken = 0 then Response.write "Error in parsing uploaded binary request." Response.End end if SkipToken = SkipToken + LenB(sToken) End Function Private Function FindToken(sToken, nStart) FindToken = InstrB(nStart, VarArrayBinRequest, sToken) End Function Private Function ExtractField(sToken, nStart) Dim nEnd nEnd = InstrB(nStart, VarArrayBinRequest, sToken) If nEnd = 0 then Response.write "Error in parsing uploaded binary request." Response.End end if ExtractField = String2Byte(MidB(VarArrayBinRequest, nStart, nEnd-nStart)) End Function 'String to byte string conversion Private Function Byte2String(sString) Dim i For i = 1 to Len(sString) Byte2String = Byte2String & ChrB(AscB(Mid(sString,i,1))) Next End Function 'Byte string to string conversion Private Function String2Byte(bsString) Dim i String2Byte ="" For i = 1 to LenB(bsString) String2Byte = String2Byte & Chr(AscB(MidB(bsString,i,1))) Next End Function End Class Class UploadedFile Public ContentType Public Start Public Length Public Path Private nameOfFile ' Need to remove characters that are valid in UNIX, but not in Windows Public Property Let FileName(fN) nameOfFile = fN nameOfFile = SubstNoReg(nameOfFile, "\", "_") nameOfFile = SubstNoReg(nameOfFile, "/", "_") nameOfFile = SubstNoReg(nameOfFile, ":", "_") nameOfFile = SubstNoReg(nameOfFile, "*", "_") nameOfFile = SubstNoReg(nameOfFile, "?", "_") nameOfFile = SubstNoReg(nameOfFile, """", "_") nameOfFile = SubstNoReg(nameOfFile, "<", "_") nameOfFile = SubstNoReg(nameOfFile, ">", "_") nameOfFile = SubstNoReg(nameOfFile, "|", "_") End Property Public Property Get FileName() FileName = nameOfFile End Property 'Public Property Get FileN()ame End Class ' Does not depend on RegEx, which is not available on older VBScript ' Is not recursive, which means it will not run out of stack space Function SubstNoReg(initialStr, oldStr, newStr) Dim currentPos, oldStrPos, skip If IsNull(initialStr) Or Len(initialStr) = 0 Then SubstNoReg = "" ElseIf IsNull(oldStr) Or Len(oldStr) = 0 Then SubstNoReg = initialStr Else If IsNull(newStr) Then newStr = "" currentPos = 1 oldStrPos = 0 SubstNoReg = "" skip = Len(oldStr) Do While currentPos <= Len(initialStr) oldStrPos = InStr(currentPos, initialStr, oldStr) If oldStrPos = 0 Then SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, Len(initialStr) - currentPos + 1) currentPos = Len(initialStr) + 1 Else SubstNoReg = SubstNoReg & Mid(initialStr, currentPos, oldStrPos - currentPos) & newStr currentPos = oldStrPos + skip End If Loop End If End Function %> <% ' Original Code written by: Robbert Nix ' Adapted and Modified by: Will Bickford ' Date: 12/20/2002 ' Email: wbic16@hotmail.com ' From: http://www.planet-source-code.com/vb/scripts/ShowCode.asp?lngWId=4&txtCodeId=7110 Function BufferContent(data) Dim strContent(64) Dim i ClearString strContent For i = 1 To LenB(data) AddString strContent,Chr(AscB(MidB(data,i,1))) Next BufferContent = fnReadString(strContent) End Function Sub ClearString(part) Dim index For index = 0 to 64 part(index)="" Next End Sub Sub AddString(part,newString) Dim tmp Dim index part(0) = part(0) & newString If Len(part(0)) > 64 Then index=0 tmp="" Do tmp=part(index) & tmp part(index) = "" index = index + 1 Loop until part(index) = "" part(index) = tmp End If End Sub Function fnReadString(part) Dim tmp Dim index tmp = "" For index = 0 to 64 If part(index) <> "" Then tmp = part(index) & tmp End If Next FnReadString = tmp End Function %> <% 'you can change this key to any unique string Dim key1 key1 = "Lhn2trcS3zHmvktdq637cX8t3nXSXfyeip9znYyLubt4q4aqb" 'Supporting encryption functions: FUNCTION hsh(h) hsh = Server.Urlencode(EncryptIt(h, key1)) END FUNCTION FUNCTION dhsh(h) dhsh = DecryptIt(h, key1) END FUNCTION Function EncryptIt(it, key) Dim keylen, size, encryptstr, keymod, i keylen = Len(key) size = Len(it) encryptstr = "" On Error Resume Next For i = 1 To size Step 1 keymod = (i Mod keylen) + 1 encryptstr = encryptstr & Chr(Asc(Mid(it, i, 1)) + Asc(Mid(key, keymod, 1))) Next EncryptIt = encryptstr End Function Function DecryptIt(it, key) Dim keylen, size, decryptstr, keymod, i keylen = Len(key) size = Len(it) decryptstr = "" On Error Resume Next For i = 1 To size step 1 keymod = (i MOD keylen) + 1 decryptstr = decryptstr & Chr(Asc(Mid(it, i, 1)) - Asc(Mid(key, keymod, 1))) Next DecryptIt = decryptstr End Function 'GET ACTUAL FQDN - for cookie or stright up. ==================== Function GetFQDN(sdom,returnforcookie) if returnforcookie = "" then returnforcookie = 1 end if dim sdomarray sdomarray = Split(request.ServerVariables("SERVER_NAME"),".") if UBound(sdomarray) > 1 then sgetfqdn = sdomarray(1) &"."& sdomarray(2) elseif UBound(sdomarray) = 1 then sgetfqdn = sdomarray(0) & "." & sdomarray(1) end if if returnforcookie = 1 then GetFQDN = "." & sgetfqdn else GetFQDN = sgetfqdn end if End Function 'GEN RANDOM CHARACTER SET ======================================= Function generatePassword(passwordLength) sDefaultChars="abcdefghijklmnopqrstuvxyzABCDEFGHIJKLMNOPQRSTUVXYZ0123456789!" iPasswordLength=passwordLength iDefaultCharactersLength = Len(sDefaultChars) Randomize'initialize the random number generator For iCounter = 1 To iPasswordLength iPickedChar = Int((iDefaultCharactersLength * Rnd) + 1) sMyPassword = sMyPassword & Mid(sDefaultChars,iPickedChar,1) Next generatePassword = sMyPassword End Function Function generatetranscode(passwordLength) sDefaultChars="ABCDEFGHIJKLMNOPQRSTUVXYZ0123456789" iPasswordLength=passwordLength iDefaultCharactersLength = Len(sDefaultChars) Randomize'initialize the random number generator For iCounter = 1 To iPasswordLength iPickedChar = Int((iDefaultCharactersLength * Rnd) + 1) sMyPassword = sMyPassword & Mid(sDefaultChars,iPickedChar,1) Next generatetranscode = sMyPassword End Function 'ENCRYPTION '================================================================ 'sitemastermind ver 2 - 2005 - copyright 2005 ihost technologies 'Last Edit Steve Spencer '================================================================ 'ENCRYPTION ================ ' Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm, ' as set out in the memo RFC1321. Private Const BITS_TO_A_BYTE = 8 Private Const BYTES_TO_A_WORD = 4 Private Const BITS_TO_A_WORD = 32 Private m_lOnBits(30) Private m_l2Power(30) m_lOnBits(0) = CLng(1) m_lOnBits(1) = CLng(3) m_lOnBits(2) = CLng(7) m_lOnBits(3) = CLng(15) m_lOnBits(4) = CLng(31) m_lOnBits(5) = CLng(63) m_lOnBits(6) = CLng(127) m_lOnBits(7) = CLng(255) m_lOnBits(8) = CLng(511) m_lOnBits(9) = CLng(1023) m_lOnBits(10) = CLng(2047) m_lOnBits(11) = CLng(4095) m_lOnBits(12) = CLng(8191) m_lOnBits(13) = CLng(16383) m_lOnBits(14) = CLng(32767) m_lOnBits(15) = CLng(65535) m_lOnBits(16) = CLng(131071) m_lOnBits(17) = CLng(262143) m_lOnBits(18) = CLng(524287) m_lOnBits(19) = CLng(1048575) m_lOnBits(20) = CLng(2097151) m_lOnBits(21) = CLng(4194303) m_lOnBits(22) = CLng(8388607) m_lOnBits(23) = CLng(16777215) m_lOnBits(24) = CLng(33554431) m_lOnBits(25) = CLng(67108863) m_lOnBits(26) = CLng(134217727) m_lOnBits(27) = CLng(268435455) m_lOnBits(28) = CLng(536870911) m_lOnBits(29) = CLng(1073741823) m_lOnBits(30) = CLng(2147483647) m_l2Power(0) = CLng(1) m_l2Power(1) = CLng(2) m_l2Power(2) = CLng(4) m_l2Power(3) = CLng(8) m_l2Power(4) = CLng(16) m_l2Power(5) = CLng(32) m_l2Power(6) = CLng(64) m_l2Power(7) = CLng(128) m_l2Power(8) = CLng(256) m_l2Power(9) = CLng(512) m_l2Power(10) = CLng(1024) m_l2Power(11) = CLng(2048) m_l2Power(12) = CLng(4096) m_l2Power(13) = CLng(8192) m_l2Power(14) = CLng(16384) m_l2Power(15) = CLng(32768) m_l2Power(16) = CLng(65536) m_l2Power(17) = CLng(131072) m_l2Power(18) = CLng(262144) m_l2Power(19) = CLng(524288) m_l2Power(20) = CLng(1048576) m_l2Power(21) = CLng(2097152) m_l2Power(22) = CLng(4194304) m_l2Power(23) = CLng(8388608) m_l2Power(24) = CLng(16777216) m_l2Power(25) = CLng(33554432) m_l2Power(26) = CLng(67108864) m_l2Power(27) = CLng(134217728) m_l2Power(28) = CLng(268435456) m_l2Power(29) = CLng(536870912) m_l2Power(30) = CLng(1073741824) Private Function LShift(lValue, iShiftBits) If iShiftBits = 0 Then LShift = lValue Exit Function ElseIf iShiftBits = 31 Then If lValue And 1 Then LShift = &H80000000 Else LShift = 0 End If Exit Function ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If If (lValue And m_l2Power(31 - iShiftBits)) Then LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000 Else LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits)) End If End Function Private Function RShift(lValue, iShiftBits) If iShiftBits = 0 Then RShift = lValue Exit Function ElseIf iShiftBits = 31 Then If lValue And &H80000000 Then RShift = 1 Else RShift = 0 End If Exit Function ElseIf iShiftBits < 0 Or iShiftBits > 31 Then Err.Raise 6 End If RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits) If (lValue And &H80000000) Then RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1))) End If End Function Private Function RotateLeft(lValue, iShiftBits) RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits)) End Function Private Function AddUnsigned(lX, lY) Dim lX4 Dim lY4 Dim lX8 Dim lY8 Dim lResult lX8 = lX And &H80000000 lY8 = lY And &H80000000 lX4 = lX And &H40000000 lY4 = lY And &H40000000 lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF) If lX4 And lY4 Then lResult = lResult Xor &H80000000 Xor lX8 Xor lY8 ElseIf lX4 Or lY4 Then If lResult And &H40000000 Then lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8 Else lResult = lResult Xor &H40000000 Xor lX8 Xor lY8 End If Else lResult = lResult Xor lX8 Xor lY8 End If AddUnsigned = lResult End Function Private Function F(x, y, z) F = (x And y) Or ((Not x) And z) End Function Private Function G(x, y, z) G = (x And z) Or (y And (Not z)) End Function Private Function H(x, y, z) H = (x Xor y Xor z) End Function Private Function I(x, y, z) I = (y Xor (x Or (Not z))) End Function Private Sub FF(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Sub GG(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Sub HH(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Sub II(a, b, c, d, x, s, ac) a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), x), ac)) a = RotateLeft(a, s) a = AddUnsigned(a, b) End Sub Private Function ConvertToWordArray(sMessage) Dim lMessageLength Dim lNumberOfWords Dim lWordArray() Dim lBytePosition Dim lByteCount Dim lWordCount Const MODULUS_BITS = 512 Const CONGRUENT_BITS = 448 lMessageLength = Len(sMessage) lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD) ReDim lWordArray(lNumberOfWords - 1) lBytePosition = 0 lByteCount = 0 Do Until lByteCount >= lMessageLength lWordCount = lByteCount \ BYTES_TO_A_WORD lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition) lByteCount = lByteCount + 1 Loop lWordCount = lByteCount \ BYTES_TO_A_WORD lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition) lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3) lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29) ConvertToWordArray = lWordArray End Function Private Function WordToHex(lValue) Dim lByte Dim lCount For lCount = 0 To 3 lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1) WordToHex = WordToHex & Right("0" & Hex(lByte), 2) Next End Function Public Function MD5(sMessage) Dim x Dim k Dim AA Dim BB Dim CC Dim DD Dim a Dim b Dim c Dim d Const S11 = 7 Const S12 = 12 Const S13 = 17 Const S14 = 22 Const S21 = 5 Const S22 = 9 Const S23 = 14 Const S24 = 20 Const S31 = 4 Const S32 = 11 Const S33 = 16 Const S34 = 23 Const S41 = 6 Const S42 = 10 Const S43 = 15 Const S44 = 21 x = ConvertToWordArray(sMessage) a = &H67452301 b = &HEFCDAB89 c = &H98BADCFE d = &H10325476 For k = 0 To UBound(x) Step 16 AA = a BB = b CC = c DD = d FF a, b, c, d, x(k + 0), S11, &HD76AA478 FF d, a, b, c, x(k + 1), S12, &HE8C7B756 FF c, d, a, b, x(k + 2), S13, &H242070DB FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE FF a, b, c, d, x(k + 4), S11, &HF57C0FAF FF d, a, b, c, x(k + 5), S12, &H4787C62A FF c, d, a, b, x(k + 6), S13, &HA8304613 FF b, c, d, a, x(k + 7), S14, &HFD469501 FF a, b, c, d, x(k + 8), S11, &H698098D8 FF d, a, b, c, x(k + 9), S12, &H8B44F7AF FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1 FF b, c, d, a, x(k + 11), S14, &H895CD7BE FF a, b, c, d, x(k + 12), S11, &H6B901122 FF d, a, b, c, x(k + 13), S12, &HFD987193 FF c, d, a, b, x(k + 14), S13, &HA679438E FF b, c, d, a, x(k + 15), S14, &H49B40821 GG a, b, c, d, x(k + 1), S21, &HF61E2562 GG d, a, b, c, x(k + 6), S22, &HC040B340 GG c, d, a, b, x(k + 11), S23, &H265E5A51 GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA GG a, b, c, d, x(k + 5), S21, &HD62F105D GG d, a, b, c, x(k + 10), S22, &H2441453 GG c, d, a, b, x(k + 15), S23, &HD8A1E681 GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8 GG a, b, c, d, x(k + 9), S21, &H21E1CDE6 GG d, a, b, c, x(k + 14), S22, &HC33707D6 GG c, d, a, b, x(k + 3), S23, &HF4D50D87 GG b, c, d, a, x(k + 8), S24, &H455A14ED GG a, b, c, d, x(k + 13), S21, &HA9E3E905 GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8 GG c, d, a, b, x(k + 7), S23, &H676F02D9 GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A HH a, b, c, d, x(k + 5), S31, &HFFFA3942 HH d, a, b, c, x(k + 8), S32, &H8771F681 HH c, d, a, b, x(k + 11), S33, &H6D9D6122 HH b, c, d, a, x(k + 14), S34, &HFDE5380C HH a, b, c, d, x(k + 1), S31, &HA4BEEA44 HH d, a, b, c, x(k + 4), S32, &H4BDECFA9 HH c, d, a, b, x(k + 7), S33, &HF6BB4B60 HH b, c, d, a, x(k + 10), S34, &HBEBFBC70 HH a, b, c, d, x(k + 13), S31, &H289B7EC6 HH d, a, b, c, x(k + 0), S32, &HEAA127FA HH c, d, a, b, x(k + 3), S33, &HD4EF3085 HH b, c, d, a, x(k + 6), S34, &H4881D05 HH a, b, c, d, x(k + 9), S31, &HD9D4D039 HH d, a, b, c, x(k + 12), S32, &HE6DB99E5 HH c, d, a, b, x(k + 15), S33, &H1FA27CF8 HH b, c, d, a, x(k + 2), S34, &HC4AC5665 II a, b, c, d, x(k + 0), S41, &HF4292244 II d, a, b, c, x(k + 7), S42, &H432AFF97 II c, d, a, b, x(k + 14), S43, &HAB9423A7 II b, c, d, a, x(k + 5), S44, &HFC93A039 II a, b, c, d, x(k + 12), S41, &H655B59C3 II d, a, b, c, x(k + 3), S42, &H8F0CCC92 II c, d, a, b, x(k + 10), S43, &HFFEFF47D II b, c, d, a, x(k + 1), S44, &H85845DD1 II a, b, c, d, x(k + 8), S41, &H6FA87E4F II d, a, b, c, x(k + 15), S42, &HFE2CE6E0 II c, d, a, b, x(k + 6), S43, &HA3014314 II b, c, d, a, x(k + 13), S44, &H4E0811A1 II a, b, c, d, x(k + 4), S41, &HF7537E82 II d, a, b, c, x(k + 11), S42, &HBD3AF235 II c, d, a, b, x(k + 2), S43, &H2AD7D2BB II b, c, d, a, x(k + 9), S44, &HEB86D391 a = AddUnsigned(a, AA) b = AddUnsigned(b, BB) c = AddUnsigned(c, CC) d = AddUnsigned(d, DD) Next MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d)) End Function 'END ENCRYPT ========================================== Private Function URLDecode(byVal encodedstring) Dim strIn, strOut, intPos, strLeft Dim strRight, intLoop strIn = encodedstring : strOut = "" : intPos = Instr(strIn, "+") Do While intPos strLeft = "" : strRight = "" If intPos > 1 then strLeft = Left(strIn, intPos - 1) End if If intPos < len(strIn) then strRight = Mid(strIn, intPos + 1) End if strIn = strLeft & " " & strRight intPos = InStr(strIn, "+") intLoop = intLoop + 1 Loop intPos = InStr(strIn, "%") Do while intPos If intPos > 1 then strOut = strOut & Left(strIn, intPos - 1) End if strOut = strOut & Chr(CInt("&H" & mid(strIn, intPos + 1, 2))) If intPos > (len(strIn) - 3) then strIn = "" Else strIn = Mid(strIn, intPos + 3) End If intPos = InStr(strIn, "%") Loop URLDecode = strOut & strIn End Function %> <% 'SECURITY CONFIGURATIONS 'security config file Dim strSMusername, strSMpassword %> <% 'CONFIGURE USERNAME / PASSWORD strSMusername = "jtbake" strSMpassword = "jtbake" %> <% Dim strloginerror strcookietoday = Replace(Replace(Date," ",""),":","") & strSMpassword strcookietoday = MD5(strcookietoday) if Server.URLEncode(request("t")) = "logout" then Response.Cookies("SMEditNOW")("HDGGTSkjidhsnnkd1ds1sds1soss") = "" Response.Cookies("SMEditNOW").Expires = Now - 3 Session.Abandon response.redirect strurl end if 'response.write strcookietoday & "
" 'response.write Request.Cookies("SMEditNOW")("HDGGTSkjidhsnnkd1ds1sds1soss") & "
" Function SecureThePage() if Request.Cookies("SMEditNOW")("HDGGTSkjidhsnnkd1ds1sds1soss") = strcookietoday then SecureThePage = 1 else SecureThePage = 0 end if End Function Function DoTheLogin(username,password,pagetogoto,inwindow) struser = Trim(username) strpass = Trim(password) 'response.write struser & "|" & strpass if struser = strSMusername and strpass = strSMpassword then Response.Cookies("SMEditNOW")("HDGGTSkjidhsnnkd1ds1sds1soss") = strcookietoday Response.Cookies("SMEditNOW").Expires = Now + 3 'DateAdd("d",1,Date) if pagetogoto <> "" and inwindow = 1 then response.redirect "editpage.asp?docid=" & pagetogoto 'response.redirect "/login-success.asp" else response.redirect "/login-success.asp" end if response.write "success!" else strloginerror = "Your login credentials are not valid, please try again." end if End Function Function EditButton(pagetogoto) if SecureThePage = 1 then EditButton = "



" _ & "" _ & "" end if End Function Function LoginButton(pagetogoto) ''LoginButton = "" _ '& "Login" LoginButton = "" _ & "Login" End Function Function BackToLogin(docid,inwindow) if inwindow = 1 then response.write "" response.end else response.redirect "/login.asp" end if End Function 'response.write Request.Cookies("SMEditNOW")("HDGGTSkjidhsnnkd1ds1sds1soss") & "
" %> <% strdocid = "home" Call LoadFileToEdit(strdocid) %> <%= doctitle %>

<%= doccontent %> <%= EditButton(strdocid)%>