Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch ber Twitter erhalten. Follow us!fb:porticula NoPaste
Body.Bas (Wiki/Stupi/GBO)
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 16.07.2007 08:56:06 |
Randomize Timer
#include "main.bas"
Const Host_Login = "www.kilahu.de"
Const Host_Chat = "insel.kilahu.de"
Const Host_Wiki = "de.wikipedia.org"
Const Host_Stupi = "www.stupidedia.org"
Const ToRead = 0
Const ToSend = 1
'"w/index.php?title="+SearchString+"&action=raw&ctype=text/javascript&dontcountme=s"
'"stupi?title="+SearchString+"&action=raw&ctype=text/javascript&dontcountme=s"
Declare Function StupiSearch (byval SearchString as String) as String
Declare Function Replace (byval buffer as string, byval oldstring as string, byval newstring as string) as string
Declare Function DelTag (byval buffer as string) as string
Declare Function FormatString (Byval buffer as String, byval InOutVar as Integer, byval SO as Integer=0) as String
Declare Function DelXTag (byval buffer as string) as string
Declare Function Stupi(byval Search as String) as String
'****************************************************************
Function StupiSearch (byval SearchString as String) as String
'****************************************************************
'-------------------------------------------------------'
Dim socket as TCPsocket
socket = TCP_open (Host_Stupi)
TCP_http (,socket,Host_Stupi, _
"stupi?title="+SearchString+"&action=edit&dontcountme=s")
'' receive til connection is closed
Dim recvbuffer As Zstring * RECVBUFFLEN+1
Dim recv_Buffer as String
Dim bytes As Integer
'-------------------------------------------------------'
Do
bytes = SDLNet_TCP_Recv( socket, Strptr( recvbuffer ), RECVBUFFLEN )
If( bytes <= 0 ) Then Exit Do
'' add the null-terminator
recvbuffer[bytes] = 0
'' save recvbuffer;
recv_Buffer+=Trim(mid(recvbuffer,1,Len(recvbuffer)-1))
If INSTR(lcase(recv_Buffer),"==") then exit do
Loop
'-------------------------------------------------------'
TCP_close (socket)
'-------------------------------------------------------'
'Datenverarbeitung/Filter'
Dim SS as Integer
Dim SE as Integer
SS=INSTR(lcase(recv_buffer),"<textarea")
If SS=0 Then
Dim MaxStrings as Integer
Dim InfString as String
InfString="NotFound!"
Return InfString
End If
SS=INSTR(SS,recv_buffer,">")+1
SE=INSTR(SS,recv_buffer,"==")
IF SE=SS Then
SE=INSTR(SE+2,recv_buffer,"==")
SE=INSTR(SE+2,recv_buffer,"==")
End IF
recv_buffer=mid(recvbuffer,SS,SE-SS)
Return trim(recv_Buffer)
'****************************************************************
End Function 'StupiSearch
'****************************************************************
'****************************************************************
Function Replace (byval buffer as string, _
byval oldstring as string, _
byval newstring as string) as string
'****************************************************************
Dim rep as ubyte=0
Do
rep=0
If INSTR(buffer,oldstring)>0 Then
rep=1
buffer=mid(buffer,1,INSTR(buffer,oldstring)-1)+newstring+ _
mid(buffer,INSTR(buffer,oldstring)+len(oldstring), _
Len(buffer)-(INSTR(buffer,oldstring)+(len(oldstring)-1)))
End If
Loop While rep=1
Return trim(buffer)
'****************************************************************
End Function 'Replace
'****************************************************************
'****************************************************************
Function DelTag (byval buffer as string) as string
'****************************************************************
Dim delt as ubyte=0
Dim SS as Integer
Dim SE as Integer
Do
delt=0
If INSTR(buffer,"<")>0 Then
delt=1
SS=INSTR(buffer,"<")
SE=INSTR(SS,buffer,">")
If SE=0 Then SE=Len(buffer)-1
buffer=mid(buffer,1,SS-1)+mid(buffer,SE+1,len(buffer)-SE)
End If
Loop While delt=1
Return trim(buffer)
'****************************************************************
End Function 'DelTag
'****************************************************************
'****************************************************************
Function FormatString (Byval buffer as String, _
byval InOutVar as Integer, _
byval SO as Integer=0) as String
'****************************************************************
Select Case InOutVar
Case ToRead
'UTF-8
'buffer=Replace (buffer,"==","")
if SO=0 Then buffer=Replace (buffer,"<","<")
if SO=0 Then buffer=Replace (buffer,">",">")
if SO=1 Then buffer=Replace (buffer,"<","[")
if SO=1 Then buffer=Replace (buffer,">","]")
buffer=Replace (buffer,"'''''",chr(34))
buffer=Replace (buffer,"'''",chr(34))
buffer=Replace (buffer,"''",chr(34))
buffer=Replace (buffer,"ü","") 'ue
buffer=Replace (buffer,"ß","") 'SZ
buffer=Replace (buffer,"ö","") 'oe
buffer=Replace (buffer,"é",chr(130)) '
buffer=Replace (buffer,"ä","") 'ae
buffer=Replace (buffer,"Ü","") 'UE
buffer=Replace (buffer,"°",chr(248)) '
buffer=Replace (buffer,"§","") '
buffer=Replace (buffer,"__TO","")
buffer=Replace (buffer,"–","-")
'HTML
buffer=Replace (buffer,""",chr(34)) '"
buffer=Replace (buffer,"","") 'UE
buffer=Replace (buffer,"","") 'ue
buffer=Replace (buffer,"","") 'AE
buffer=Replace (buffer,"","") 'ae
buffer=Replace (buffer,"","") 'OE
buffer=Replace (buffer,"","") 'oe
buffer=Replace (buffer,"&","&") '&
buffer=Replace (buffer,""," ") '
'buffer=Replace (recv_buffer,"","") '
'buffer=Replace (recv_buffer,"","") '
buffer=Replace (buffer,chr(10),chr(32))
buffer=Replace (buffer,chr(0),chr(32))
if SO=1 Then buffer=Replace (buffer,chr(13),chr(32))
End Select
Return buffer
'****************************************************************
End Function 'FormatString
'****************************************************************
'****************************************************************
Function DelXTag (byval buffer as string) as string
'****************************************************************
Dim FT as Integer
Dim FE as Integer
Dim TC as UByte=0
Dim LT as UByte=0
Dim FTT as Integer
Dim XT as integer
If INSTR(buffer,"{|")>0 Then
FE=INSTR(buffer,"|}")+2
FTT=INSTR(FT+2,buffer,"{|")
If FTT>0 and FTT<FE Then
FE=INSTR(FE,buffer,"|}")+2
End If
buffer=trim(mid(buffer,FE,Len(Buffer)-FE))
End If
Do
TC=0
If INSTR(buffer,"[[")=1 Then
FE=INSTR(buffer,"]]")+2
FTT=INSTR(FT+2,buffer,"[[")
If FTT>0 and FTT<FE Then
FE=INSTR(FE,buffer,"]]")+2
End If
buffer=trim(mid(buffer,FE,Len(Buffer)-FE))
TC=1
End If
If INSTR(buffer,"{{")=1 Then
FE=INSTR(buffer,"}}")+2
FTT=INSTR(FT+2,buffer,"{{")
If FTT>0 and FTT<FE Then
FE=INSTR(FE,buffer,"}}")+2
End If
buffer=trim(mid(buffer,FE,Len(Buffer)-FE))
TC=1
End If
Loop While TC=1
Do
TC=0
If INSTR(buffer,"[[") Then
TC=1
FT=INSTR(buffer,"[[")
FE=INSTR(buffer,"]]")
FTT=INSTR(FT+2,buffer,"[[")
If FTT>0 and FTT<FE Then
FE=INSTR(FE,buffer,"]]")+2
End If
XT=0
For l as integer=FT to FE
If mid(buffer,l,1)="|" Then XT=l+1
Next l
If XT=0 Then XT=FT+2
buffer=mid(buffer,1,FT-1)+mid(buffer,XT,FE-XT)+mid(buffer,FE+2,Len(buffer)-(FE+1))
End If
Loop While TC=1
Do
TC=0
If INSTR(buffer,"{{") Then
TC=1
FT=INSTR(buffer,"{{")
FE=INSTR(buffer,"}}")
FTT=INSTR(FT+2,buffer,"{{")
If FTT>0 and FTT<FE Then
FE=INSTR(FE,buffer,"}}")+2
End If
XT=0
For l as integer=FT to FE
If mid(buffer,l,1)="|" Then XT=l+1
Next l
If XT=0 Then XT=FT+2
buffer=mid(buffer,1,FT-1)+mid(buffer,XT,FE-XT)+mid(buffer,FE+2,Len(buffer)-(FE+1))
End If
Loop While TC=1
Return trim(buffer)
'****************************************************************
End Function 'DelXTag
'****************************************************************
'****************************************************************
Function Stupi(byval Search as String) as String
'****************************************************************
Dim StupiString as String
dim RE as integer
Dim RSS as integer
Dim RSE as integer
'------------------------------------'
StupiString=StupiSearch(Search)
'------------------------------------'
StupiString=FormatString(StupiString,ToRead)
StupiString=DelTag(StupiString)
'------------------------------------'
RE=Len(StupiString)
If len(StupiString)>1000 Then
RE=instr(StupiString,chr(46))
RE=instr(RE,StupiString,chr(46))
End If
StupiString=mid(StupiString,1,RE)
'------------------------------------'
StupiString=DelXTag (StupiString)
'------------------------------------'
if instr(lcase(StupiString),"#redirect")=1 Then
RSS=instr(StupiString,chr(32))
RSE=instr(RSS+1,StupiString,chr(32))
StupiString=Stupi(trim(mid(StupiString,RSS,RSE-RSS)))
End If
'------------------------------------'
If Len(StupiString)>699 Then
StupiString=mid(StupiString,1,699)
RSS=Len(StupiString)
do
If mid(StupiString,RSS,1)="." Or mid(StupiString,RSS,1)="!" Then
StupiString=mid(StupiString,1,RSS)+"..."
Exit Do
End If
RSS-=1
If RSS=0 Then Exit Do
loop
End If
'------------------------------------'
Return StupiString
'****************************************************************
End Function 'Stupi
'****************************************************************
'****************************************************************
Function WikiSearch (byval SearchString as String) as String
'****************************************************************
'-------------------------------------------------------'
Dim socket as TCPsocket
socket = TCP_open (Host_Wiki)
TCP_http (,socket,Host_Wiki, _
"w/index.php?title="+SearchString+"&action=edit&dontcountme=s")
'' receive til connection is closed
Dim recvbuffer As Zstring * RECVBUFFLEN+1
Dim recv_Buffer as String
Dim bytes As Integer
'-------------------------------------------------------'
Do
bytes = SDLNet_TCP_Recv( socket, Strptr( recvbuffer ), RECVBUFFLEN )
If( bytes <= 0 ) Then Exit Do
'' add the null-terminator
'recvbuffer[bytes] = 0
'' save recvbuffer;
recv_Buffer+=Trim(mid(recvbuffer,1,Len(recvbuffer)-1))
If INSTR(lcase(recv_Buffer),"==") then exit do
Loop
'-------------------------------------------------------'
TCP_close (socket)
'-------------------------------------------------------'
'Datenverarbeitung/Filter'
Dim SS as Integer
Dim SE as Integer
SS=INSTR(lcase(recv_buffer),"<textarea")
If SS=0 Then
Return "NotFound!"
End If
SS=INSTR(SS,recv_buffer,">")+1
SE=INSTR(SS,recv_buffer,"==")
If SE=0 Then SE=INSTR(SS,lcase(recv_buffer),"</textarea")
IF SE=SS Then
SE=INSTR(SE+2,recv_buffer,"==")
SE=INSTR(SE+2,recv_buffer,"==")
End IF
recv_buffer=mid(recv_buffer,SS,SE-SS)
Return trim(recv_Buffer)
'****************************************************************
End Function 'WikiSearch
'****************************************************************
'****************************************************************
Function Wiki(byval Search as String) as String
'****************************************************************
Dim WikiString as String
dim RE as integer
Dim RSS as integer
Dim RSE as integer
'------------------------------------'
WikiString=WikiSearch(Search)
'------------------------------------'
WikiString=FormatString(WikiString,ToRead)
WikiString=DelTag(WikiString)
'------------------------------------'
' RE=Len(WikiString)
' If len(WikiString)>1000 Then
' RE=instr(WikiString,chr(46))
' RE=instr(RE,WikiString,chr(46))
' End If
'
' WikiString=mid(WikiString,1,RE)
'------------------------------------'
WikiString=DelXTag (WikiString)
'------------------------------------'
if instr(lcase(WikiString),"#redirect")=1 Then
RSS=instr(WikiString,chr(32))
RSE=instr(RSS+1,WikiString,chr(32))
WikiString=(trim(mid(WikiString,RSS,RSE-RSS)))
WikiString=Wiki(WikiString)
End If
'------------------------------------'
If Len(WikiString)>699 Then
WikiString=mid(WikiString,1,699)
RSS=Len(WikiString)
do
If mid(WikiString,RSS,1)="." Or mid(WikiString,RSS,1)="!" Then
WikiString=mid(WikiString,1,RSS)+"..."
Exit Do
End If
RSS-=1
If RSS=0 Then Exit Do
loop
End If
'------------------------------------'
'##########################################################################'
'!!!!!!!!!!!!!!
''''Nicht gefunden Zufalls Ausgabe Einfuegen!!!'''
If Len(WikiString)=0 Then WikiString="hmm.."
'!!!!!!!!!!!!!!
'##########################################################################'
Return WikiString
'****************************************************************
End Function 'Wiki
'****************************************************************
Function GBOget as String
'-------------------------------------------------------'
Dim socket as TCPsocket
Dim RPath as String
RPath=STR(INT(RND*30000))
'RPath="26307"
socket = TCP_open ("german-bash.org")
TCP_http (,socket,"german-bash.org", _
RPath)
'' receive til connection is closed
Dim recvbuffer As Zstring * RECVBUFFLEN+1
Dim recv_Buffer as String=""
Dim bytes As Integer
'-------------------------------------------------------'
Dim CC as Integer
Dim CX as UByte=0
Do
bytes = SDLNet_TCP_Recv( socket, Strptr( recvbuffer ), RECVBUFFLEN )
If( bytes <= 0 ) Then Exit Do
'' add the null-terminator
'recvbuffer[bytes] = 0
'' save recvbuffer;
recv_Buffer+=Trim(mid(recvbuffer,1,Len(recvbuffer)-1))
'CC=INSTR(lcase(recv_Buffer),"<span class="+chr(34)+"quote_zeile"+chr(34))
'If CC>0 and CX=0 Then recv_buffer=mid(recv_buffer,CC,Len(recv_buffer)-CC):CX=1
'If CC>0 Then
' If INSTR(CC,lcase(recv_buffer),"<script")>CC Then
' recv_buffer=mid(recv_buffer,1,INSTR(CC,lcase(recv_buffer),"<script"))
' exit do
' End If
'End If
Loop
'-------------------------------------------------------'
TCP_close (socket)
'-------------------------------------------------------'
Return recv_buffer
End Function
Function GBO as String
'Datenverarbeitung/Filter'
dim rec_buffer as string
Dim buffer as string=""
Dim SS as Integer
Dim SE as Integer
''IST GBO Spruch?
do
rec_buffer=GBOget
SS=INSTR(lcase(rec_buffer),"<span class="+chr(34)+"quote_zeile")
loop while SS=0
''Weiter wenn Ja
''Filtern
Dim SX as Integer
dim lh as integer
lh=1
Dim HF as UByte
DIM FS as String
do
SX=0
SS=INSTR(lh,lcase(rec_buffer),"<span class="+chr(34)+"quote_zeile")
SE=INSTR(SS,lcase(rec_buffer),"</span")
If SS>0 and SE>0 Then
SX=1
SS=INSTR(SS,rec_buffer,">")+1
If (SE-SS)>199 Then Return "neee...."
'buffer+=
'If HF=0 Then
' FS=Trim(FormatString(mid(rec_buffer,SS,SE-SS)+chr(32),ToRead,1))
' HF=1
'End If
'If Trim(FormatString(mid(rec_buffer,SS,SE-SS)+chr(32),ToRead,1))=FS Then Return ""
?Trim(FormatString(mid(rec_buffer,SS,SE-SS)+chr(32),ToRead,1))
'?asc(mid(Trim(FormatString(mid(rec_buffer,SS,SE-SS)+chr(32),ToRead,1)),1,1))
'?buffer
SE=SE+5
'?SS,SE
lh=se
'rec_buffer=mid(rec_buffer,SE,Len(rec_buffer)-SE)
End If
loop while SX=1
''--------------GBO in Buffer
'recv_buffer=mid(recv_buffer,SS,SE-SS)
'If INSTR(lcase(recv_buffer),"n sie mit paypal")>0 Then
' SS=INSTR(lcase(recv_buffer),"n sie mit paypal")-1
' SE=INSTR(SS,lcase(recv_buffer),"-->")+3
' recv_buffer=mid(recv_buffer,1,SS)+mid(recv_buffer,SE,len(recv_buffer)-SE)
'End If
'SS=0
'do
' SE=0
' If INSTR(SS+1,lcase(recv_buffer),"</span>")>0 Then
' SS=INSTR(SS+1,lcase(recv_buffer),"</span>")
' SE=1
' End If
'
'loop While SE=1
'recv_buffer=mid(recv_buffer,1,SS-1)
'buffer=DelTag (recv_buffer)
'SE=INSTR(lcase(buffer),"vorheriges ")
'recv_buffer=mid(recv_buffer,1,SE-1)
buffer=FormatString (buffer,ToRead,1)
'Return buffer
return ""
End Function
dim test as string
dim test2 as string
'?Stupi("schmetterling")
'test=Wiki("Bsdfdsf")
'?test
'test=GBO
?GBO
'?asc(mid(test,1,1))
'?asc(mid(test,len(test),1))
open "utf-8.txt" for output as #1
? #1,test
close #1
Sleep