project64/Source/Script/upload_beta.vbs

518 lines
15 KiB
Plaintext
Raw Normal View History

' On Error Resume Next
2015-09-30 00:18:37 +00:00
if WScript.Arguments.Count < 4 then
WScript.StdOut.WriteLine "Missing parameters"
2015-09-30 00:18:37 +00:00
WScript.StdOut.WriteLine "[password] [file to upload] [BuildUrl] [Posttitle]"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
Set IE = CreateIeWindow()
WScript.StdOut.WriteLine IE.HWND
IE.Visible = True
Login IE
PostThread IE
IE.Quit
2015-12-01 20:51:59 +00:00
WScript.Quit 0
function CreateIeWindow ()
on error resume next
Set CreateIeWindow = nothing
For count = 0 to 100
WScript.StdOut.WriteLine count & ": Trying to create Internet Explorer"
Set IE = WScript.CreateObject("InternetExplorer.Application", "IE_")
if not IE is nothing then
WScript.StdOut.WriteLine count & ": Created Internet Explorer"
2015-09-29 05:04:21 +00:00
WScript.StdOut.WriteLine IE.HWND
IE.Visible = True
WScript.StdOut.WriteLine IE.HWND
Set CreateIeWindow = IE
exit for
end if
WScript.StdOut.WriteLine count & ": Not created"
WScript.Sleep 100
WScript.StdOut.WriteLine count & ": Should loop"
Next
if CreateIeWindow is nothing then
WScript.StdOut.WriteLine "Failed to create InternetExplorer.Application"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
End Function
Sub Wait(IE)
Dim complete
complete = False
WScript.StdOut.WriteLine "Waiting for IE"
For count = 0 to 1000
WScript.StdOut.WriteLine "before sleep"
WScript.Sleep 100
WScript.StdOut.WriteLine "after sleep"
if IE is nothing then
WScript.StdOut.WriteLine "after sleep"
end if
WScript.StdOut.WriteLine count & ": IE.readyState: " & IE.readyState
if IE.readyState >= 4 then
WScript.StdOut.WriteLine count & ": IE.Busy: " & IE.Busy
if not IE.Busy then
WScript.StdOut.WriteLine count & ": IE.document.readyState: " & IE.document.readyState
if StrComp(IE.document.readyState, "complete", vbTextCompare) = 0 then
complete = true
exit for
end if
end if
end if
Next
if not complete then
WScript.StdOut.WriteLine "Failed to wait for IE"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
WScript.StdOut.WriteLine "IE Done"
End Sub
Function FindIeWindow(ieID)
on error resume next
set IE = nothing
Set Shell = CreateObject("Shell.Application")
For i = 0 to Shell.Windows.Count -1
set Win = Shell.Windows.Item(i)
WScript.StdOut.WriteLine i & ": " & TypeName(win.Document)
If TypeName(win.Document) = "HTMLDocument" Then
WScript.StdOut.WriteLine "uniqueID: @" & win.HWND & "@" & ieID & "@"
if win.HWND = ieID then
WScript.StdOut.WriteLine "matched"
set IE = win
end if
End If
if not IE is nothing then
exit for
end if
Next
set FindIeWindow = IE
if IE is nothing then
WScript.StdOut.WriteLine "Failed to find navigating window"
else
WScript.StdOut.WriteLine "HWND : " & IE.HWND
end if
End Function
Sub Navigate(IE, url)
dim ieId
ieID = IE.HWND
WScript.StdOut.WriteLine "Navigating (" & IE.HWND & ") to: " & url
IE.Navigate url
WScript.Sleep 100
2015-09-30 00:18:37 +00:00
' set IE = FindIeWindow(ieID)
Wait IE
End Sub
Sub ValidateLoggedIn(IE)
WScript.StdOut.WriteLine "ValidateLoggedIn - 1"
WScript.StdOut.WriteLine "ValidateLoggedIn start"
WScript.StdOut.WriteLine "ValidateLoggedIn - 2"
Navigate IE, "http://forum.pj64-emu.com/"
WScript.StdOut.WriteLine "ValidateLoggedIn - 3"
Wait IE
WScript.StdOut.WriteLine "ValidateLoggedIn - 4"
Dim LoggedIn
LoggedIn = False
WScript.StdOut.WriteLine "ValidateLoggedIn - 5"
Set NodeList = IE.document.getElementsByTagName("a")
WScript.StdOut.WriteLine "ValidateLoggedIn - 6"
WScript.StdOut.WriteLine "Got Node list"
For Each Elem In NodeList
WScript.StdOut.WriteLine Elem.href
if lcase(Mid(Elem.href,1,39)) = "http://forum.pj64-emu.com/member.php?u=" then
if lcase(Mid(Elem.parentElement.innerHTML,1,11)) = "welcome, <a" then
if lcase(Elem.innerHTML) = "buildbot" then
2015-09-22 02:04:00 +00:00
WScript.StdOut.WriteLine "Found welcome message"
LoggedIn = true
exit for
end if
end if
end if
Next
if LoggedIn = false then
WScript.StdOut.WriteLine "Failed to login"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
WScript.StdOut.WriteLine "ValidateLoggedIn Done"
End Sub
Sub Login(IE)
'On Error resume next
Set IE2 = WScript.CreateObject("InternetExplorer.Application", "IE_")
IE2.Visible = True
WScript.StdOut.WriteLine "Login start"
Navigate IE2, "http://forum.pj64-emu.com/"
set navbar_username = IE2.document.getelementbyid("navbar_username")
set navbar_password = IE2.document.getelementbyid("navbar_password")
if navbar_username is nothing then
WScript.StdOut.WriteLine "Failed to find login form, checking if already logged in"
ValidateLoggedIn IE
exit sub
end if
WScript.StdOut.WriteLine "Found login form"
navbar_username.value = "buildbot"
navbar_password.value = WScript.Arguments(0)
navbar_username.form.submit
Wait IE2
Dim FoundIt
FoundIt = False
WScript.StdOut.WriteLine "Looking for redirect"
For count = 0 to 100
Set NodeList = IE2.document.getElementsByTagName("a")
WScript.StdOut.WriteLine count & ": Found " & NodeList.length & " a tags"
For Each Elem In NodeList
if StrComp(Elem.href, "http://forum.pj64-emu.com/", vbTextCompare) = 0 then
if StrComp(Elem.innerHTML, "Click here if your browser does not automatically redirect you.", vbTextCompare) = 0 then
FoundIt = True
Exit For
End if
end if
Next
if FoundIt = True then
Exit For
end if
WScript.Sleep 100
Next
if FoundIt = false then
WScript.StdOut.WriteLine "Failed to find redirect"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
WScript.StdOut.WriteLine "found redirect"
Navigate IE, "http://forum.pj64-emu.com/"
Wait IE
2015-09-22 02:05:06 +00:00
WScript.StdOut.WriteLine "Quitting IE2"
IE2.Quit
ValidateLoggedIn IE
WScript.StdOut.WriteLine "Login Done"
End Sub
Sub PostThread(IE)
WScript.StdOut.WriteLine "PostThread start"
Navigate IE, "http://forum.pj64-emu.com/newthread.php?do=newthread&f=10"
Wait IE
Dim submitButton
For count = 0 to 100
WScript.StdOut.WriteLine count & ": looking for submit button"
set submitButton = nothing
Set NodeList = IE.document.getElementsByTagName("input")
For Each Elem In NodeList
WScript.StdOut.WriteLine count & ": " & lcase(Elem.className)
if lcase(Elem.className) = "button" and lcase(Elem.value) = "submit new thread" then
WScript.StdOut.WriteLine count & ": found submit button"
set submitButton = Elem
exit for
end if
Next
if not submitButton is nothing then
exit for
end if
WScript.Sleep 300
Next
if submitButton is nothing then
WScript.StdOut.WriteLine "failed to find submit button"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
dim ieId
ieID = IE.HWND
2015-09-30 00:18:37 +00:00
SetPostDetails IE, WScript.Arguments(2), WScript.Arguments(3)
UploadFile WScript.Arguments(1)
WScript.StdOut.WriteLine "submitting"
submitButton.click
WScript.Sleep 100
2015-09-30 00:18:37 +00:00
' set IE = FindIeWindow(ieID)
Wait IE
WScript.StdOut.WriteLine "PostThread Finished"
End Sub
2015-09-30 00:18:37 +00:00
Sub SetPostDetails(IE, BuildUrl, PostTitle)
WScript.StdOut.WriteLine "Posting Details"
Dim oReq
Set oReq = CreateObject("MSXML2.XMLHTTP")
oReq.open "GET", BuildUrl & "api/xml?wrapper=changes", False
oReq.send
if (oReq.status <> 200) then
WScript.StdOut.WriteLine "failed to get job details (" & BuildUrl & "api/xml?wrapper=changes)"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
Dim xmlDoc
Set xmlDoc = oReq.responseXML
Set objLst = xmlDoc.getElementsByTagName("freeStyleBuild")
2015-09-30 00:18:37 +00:00
Dim PostContent
For each elem in objLst
set childNodes = elem.childNodes
for each node in childNodes
2015-09-30 00:18:37 +00:00
if lcase(node.nodeName)="changeset" then
for each item in node.childNodes
dim commitId, comment
commitId = ""
comment = ""
for each itemDetail in item.childNodes
if lcase(itemDetail.nodeName)="commitid" then
commitId = itemDetail.text
end if
if lcase(itemDetail.nodeName)="comment" then
comment = Replace(Replace(itemDetail.text, vbLf, " "), vbCr, " ")
end if
next
if (Len(comment) > 0 and Len(commitId) > 0) then
PostContent = PostContent & "[*]" & comment & " (commit: [URL=""https://github.com/project64/project64/commit/" & commitId & """]"& commitId & "[/URL])" & vbCr
end if
next
end if
next
Next
if (Len(PostContent) > 0) then
PostContent = "Changes:"&vbCr&"[LIST=1]" & vbCr & PostContent & "[/LIST]"
else
PostContent = "No code changes"
end if
WScript.StdOut.WriteLine "PostTitle = """ & PostTitle & """"
WScript.StdOut.WriteLine "PostContent = """ & PostContent & """"
Dim SetTitle
SetTitle = False
Set NodeList = IE.document.getElementsByTagName("input")
For Each Elem In NodeList
if lcase(Elem.name) = "subject" then
Elem.value = PostTitle
SetTitle = true
exit for
end if
Next
if not SetTitle then
WScript.StdOut.WriteLine "failed to set post title"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
Dim SetMessage
SetMessage = False
Set NodeList = IE.document.getElementsByTagName("textarea")
For Each Elem In NodeList
WScript.StdOut.WriteLine Elem.name
if lcase(Elem.name) = "message" then
Elem.value = PostContent
SetMessage = true
exit for
end if
Next
if not SetMessage then
WScript.StdOut.WriteLine "failed to set post message"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
end sub
sub UploadFile(FileToUpload)
WScript.StdOut.WriteLine "UploadFile start"
dim filePos
filePos = InStrRev(FileToUpload, "\")
if filePos = 0 then
2015-12-01 20:51:59 +00:00
WScript.StdOut.WriteLine "failed to find directory seperator in " & FileToUplo& FileToUpload
WScript.Quit 1
end if
dim fileName
fileName = Mid(FileToUpload, filePos + 1, len(FileToUpload))
WScript.StdOut.WriteLine fileName
extPos = InStrRev(fileName, ".")
if extPos = 0 then
WScript.StdOut.WriteLine "failed to find file extension in " & fileName
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
extension = Mid(fileName, extPos, len(fileName))
if lcase(extension) <> ".zip" then
WScript.StdOut.WriteLine "not a zip file: " & fileName
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
set manage_attachments_button = ie.document.getelementbyid("manage_attachments_button")
if manage_attachments_button is nothing then
WScript.StdOut.WriteLine "failed to find manage_attachments_button"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
WScript.StdOut.WriteLine "InStr(1, lcase(manage_attachments_button.onclick), ""vb_attachments"") = " & InStr(1, lcase(manage_attachments_button.onclick), "vb_attachments")
dim startPos, endPos
startPos = InStr(1, lcase(manage_attachments_button.onclick), "vb_attachments")
if startPos = 0 then
WScript.StdOut.WriteLine "failed to find vb_attachments in " & manage_attachments_button.onclick
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
startPos = InStr(startPos, lcase(manage_attachments_button.onclick), "'")
if startPos = 0 then
WScript.StdOut.WriteLine "failed to find first quote in " & manage_attachments_button.onclick
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
startPos = startPos + 1
endPos = InStr(startPos,manage_attachments_button.onclick, "'")
if endPos = 0 then
WScript.StdOut.WriteLine "failed to find second quote in " & manage_attachments_button.onclick
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
Set IE2 = WScript.CreateObject("InternetExplorer.Application", "IE_")
IE2.Visible = True
Navigate IE2, "http://forum.pj64-emu.com/" & Mid(manage_attachments_button.onclick, startPos, endPos - startPos)
Wait IE2
Set FormList = IE2.document.getElementsByTagName("form")
if FormList.length <> 1 or FormList(0).name <> "newattachment" then
WScript.StdOut.WriteLine "failed to find attachement form"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
Set InputList = FormList(0).getElementsByTagName("input")
WScript.StdOut.WriteLine "InputList.length = " & InputList.length
dim PreFormData, PostFormData
For Each Input In InputList
if lcase(Input.type) = "hidden" then
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""" & Input.name & """" & vbCrLf & vbCrLf & Input.value& vbCrLf
end if
WScript.StdOut.WriteLine "Input.type: " & Input.type & " Input.name: " & Input.name & " Input.value: " & Input.value
next
PreFormData = PreFormData & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""attachment[]""; filename=""" & fileName & """" & vbCrLf
PreFormData = PreFormData & "Content-Type: application/zip" & vbCrLf & vbCrLf
PostFormData = vbCrLf & "--AaB03x" & vbCrLf & "Content-Disposition: form-data; name=""upload""" & vbCrLf & vbCrLf & "Upload" & vbCrLf
PostFormData = PostFormData & vbCrLf & vbCrLf & "--AaB03x--"& vbCrLf
WScript.StdOut.WriteLine PreFormData & PostFormData
dim fileContents
fileContents = ReadBinaryFile(FileToUpload)
dim UploadUrl
UploadUrl = "http://forum.pj64-emu.com/" & FormList(0).action
IE2.Quit
Header = "Content-Type: multipart/form-data; boundary=AaB03x" & vbCrLf
Const adTypeBinary = 1
Dim DataToPOSTStream
Set DataToPOSTStream = CreateObject("ADODB.Stream")
DataToPOSTStream.type=adTypeBinary
DataToPOSTStream.Open
DataToPOSTStream.Write = Stream_StringToBinary(PreFormData,"us-ascii")
DataToPOSTStream.Write = fileContents
DataToPOSTStream.Write = Stream_StringToBinary(PostFormData,"us-ascii")
DataToPOSTStream.Position = 0
DataToPOSTStream.Type = adTypeBinary
Dim DataToPOST
DataToPOST = DataToPOSTStream.Read
Set IE3 = CreateIeWindow()
IE3.Visible = 1
dim ieId
ieID = IE3.HWND
WScript.StdOut.WriteLine "Uploading form to: " & UploadUrl
IE3.Navigate UploadUrl, Nothing, Nothing, DataToPOST, Header
WScript.Sleep 100
2015-09-30 00:18:37 +00:00
'set IE3 = FindIeWindow(ieID)
Wait IE3
Dim UploadDone
UploadDone = False
For count = 0 to 1000
WScript.StdOut.WriteLine count & ": Waiting for upload done"
Set NodeList = IE3.document.getElementsByTagName("legend")
For Each Elem In NodeList
if (len(Elem.innerHTML) > 19) and lcase(Mid(Elem.innerHTML, 1, 19)) = "current attachments" then
UploadDone = true
WScript.StdOut.WriteLine "Upload done"
exit for
end if
Next
if UploadDone then
exit for
end if
Next
if not UploadDone then
2015-09-22 02:06:35 +00:00
WScript.StdOut.WriteLine "Failed to upload file"
2015-12-01 20:51:59 +00:00
WScript.Quit 1
end if
IE3.Quit
WScript.StdOut.WriteLine "UploadFile Finished"
end sub
Function Stream_StringToBinary(Text, CharSet)
Const adTypeText = 2
Const adTypeBinary = 1
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = adTypeText
BinaryStream.CharSet = CharSet
BinaryStream.Open
BinaryStream.WriteText Text
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary
Stream_StringToBinary = BinaryStream.Read
Set BinaryStream = Nothing
End Function
Function ReadBinaryFile(path)
2015-09-25 21:13:29 +00:00
Const adTypeText = 2
Const adTypeBinary = 1
2015-09-25 21:13:29 +00:00
dim inStream
dim myByte,myByteValue,myCharacter
set inStream=WScript.CreateObject("ADODB.Stream")
inStream.Open
inStream.type=1
inStream.LoadFromFile path
ReadBinaryFile=inStream.Read()
inStream.Close
End Function