Buchempfehlung
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
"Der" Petzold, das über 1000 Seiten starke Standardwerk zum Win32-API - besonders nützlich u. a. bei der GUI-Programmierung in FreeBASIC! [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

tIRC - Tiny IRC Client 1.1

Uploader:MitgliedPMedia
Datum/Zeit:30.07.2007 11:48:28

/' tIRC => TinyIRC
  a SMALL IRC-Client for Windows and Linux
  written in 2007 by PMedia <pmedia@gmx.net>
  
  licensed under GPL
  
  uses substr and replace from ytwinky (ytwinky.freebasic.de)
  
  Changelog:
    1.1 (PMedia, 30.07.2007):
    ·  80-Char's limit inserted, after long wishes by other users ;)
    1.0 (PMedia):
    ·  Language: German / English-Mix ;)
    ·  First Version    
    
  ToDo:
    · Langfiles?
    · really NC-Like Interface (NC = Norton Commander)
    · Easier Configuration
    · fix the Bug with the BackSpace-Key
    · better formation of the code than the current simple-80-char's-fix
'/


Includes:
    #ifdef __FB_WIN32__
    #include once "win/winsock2.bi"
    #else
    #include once "crt/netdb.bi"
    #include once "crt/sys/socket.bi"
    #include once "crt/netinet/in.bi"
    #include once "crt/arpa/inet.bi"
    #include once "crt/unistd.bi"
    #endif
Defines:
    #define newline chr(13) + chr(10)
Declares:
    Declare Function SubStr(byVal Liste As String, byVal Trenner As String, _
                            byVal Stelle As Long) As String
    Declare Function Replace(byVal Text As String, byVal Suche As String, _
                             byVal ErsetzeMit As String) As String
    Declare Function RecvText() As String
    Declare Function resolveHost ( Byref hostname As String ) As Integer
    Declare Sub Listener()
    Declare Sub Reconnect()
    Declare Sub SendText(sendbuffer As String)
    Declare Sub DoInit()
    Declare Sub DoShutdown()
Variables:
    Dim Shared socket As socket
    Dim Shared nick As String
    Dim Shared pass As String
    Dim Shared host As String
    Dim Shared s As String
    Dim Shared saccess As Integer
    Dim Shared ip As Integer
    Dim Shared sa As sockaddr_in
    Dim Shared Message As String
    Dim Shared MsgMode As Integer
    Dim Shared MsgChg  As Integer
    Dim Shared InpBuff As String
    Dim Shared KeyIn As String
    Dim Shared LastLine As Integer
    Dim Shared Destination As String
    #define newline chr(13) + chr(10)
SubsAndFunctions:
    Sub Listener()

        Do
            s = ""
            Do
                s += recvText()
            Loop Until Instr(s, newline)

            saccess = 1
            Do
                Sleep 5
            Loop Until saccess = 0

        Loop Until Inkey = Chr(255) + "k"

    End Sub

    Sub ReConnect()

        If socket <> 0 Then
            closesocket( socket )
        End If

        ip = resolveHost( host )
        If( ip = 0 ) Then
            Print "resolveHost(): invalid address"
            End 1
        End If

        socket = opensocket( AF_INET, SOCK_STREAM, IPPROTO_TCP )
        If( socket = 0 ) Then
            Print "openSocket(): Something went wrong"
            End 1
        End If

        sa.sin_port            = htons( 6667 )
        sa.sin_family        = AF_INET
        sa.sin_addr.S_addr    = ip

        If ( connect( socket, cast( PSOCKADDR, @sa ), Len( sa )) = _
            SOCKET_ERROR ) Then
            Print "connect(): Something went wrong"
            closesocket( socket )
            End 1
        End If

        SendText("NICK " + NICK + NEWLINE + "USER " + NICK + " 0 0 *:" + _
           NICK + NEWLINE)

        If pass <> "" Then sendtext("PRIVMSG NickServ :IDENTIFY " + pass +_
           NEWLINE)

        SendText("PRIVMSG nickserv :set unfiltered on" + NEWLINE)

    End Sub

    Sub SendText(sendbuffer As String)
        If( send( socket, sendBuffer, Len( sendBuffer ), 0 ) = SOCKET_ERROR ) _
            Then
            Print "send(): Something went wrong"
            closesocket( socket )
            End 1
        End If
    End Sub

    Function RecvText() As String
        Dim recvbuffer As Zstring * 2
        Dim bytes As Integer
        bytes = recv( socket, recvBuffer, 1, 0 )
        recvbuffer[bytes] = 0
        Return RecvBuffer
    End Function


    Sub doInit
        #ifdef __FB_WIN32__
        '' init winsock
        Dim wsaData As WSAData

        If( WSAStartup( MAKEWORD( 1, 1 ), @wsaData ) <> 0 ) Then
            Print "Error: WSAStartup failed"
            End 1
        End If
        #Endif
    End Sub

    Sub doShutdown
        #ifdef __FB_WIN32__
        '' quit winsock
        WSACleanup
        #Endif
    End Sub

    Function resolveHost ( Byref hostname As String ) As Integer

        Dim ia As in_addr
        Dim hostentry As hostent Ptr

        '' check if it's an ip address
        ia.S_addr = inet_addr( hostname )
        If ( ia.S_addr = INADDR_NONE ) Then

            '' if not, assume it's a name, resolve it
            hostentry = gethostbyname( hostname )
            If ( hostentry = 0 ) Then
                Exit Function
            End If

            Function = *cast( Integer Ptr, *hostentry->h_addr_list )

        Else

            '' just return the address
            Function = ia.S_addr
        End If
    End Function

    Function SubStr(byVal Liste As String, byVal Trenner As String,_
      byVal Stelle As Long) As String
      Dim As Long Aktuell=0, Ooops, ltr=Len(Trenner), Vorige=1, Gefunden
      If Stelle=0 Or Liste="" Or Trenner="" Or Instr(Liste, Trenner)=0 _
        Then Return ""
      Do
        Ooops=Gefunden
        Gefunden=Instr(Gefunden+1, Liste, Trenner)
        Aktuell-=Gefunden<>0
        If Aktuell=Stelle-1 Then Vorige=Gefunden+ltr
        If Aktuell=Stelle Then Exit Do
      Loop Until Gefunden=0
      If Stelle>Aktuell Then Return Mid(Liste, IIF(Stelle-Aktuell>1,_
        Len(Liste)+1, Ooops+ltr)) &Chr(0)
      Return Mid(Liste, Vorige, Gefunden-Vorige)
    End Function

    Function Replace(byVal Text As String, byVal Suche As String,_
         byVal ErsetzeMit As String) As String
      Dim s As String=Text, i As Long
      While Instr(s, Suche)
        i=Instr(s, Suche)
        s=Left(s, i-1) &ErsetzeMit &Mid(s, i+Len(Suche))
      Wend
      Return s
    End Function

Main:
    Randomize Timer

    Nick = "PMedau" '"USER"+str(rnd* (2^32))
    Pass = ""
    Host = "chat.freenode.net"
    Destination = "#freebasic.de"

    ThreadCreate(@Listener, 0)
    DoInit()
    ReConnect()


    SendText("JOIN "+Destination+NEWLINE)

    Width 80, 25
    Locate 1, 17
    color 8,0
    Print chr(32, 176, 177, 178 , 219);
    color 7,8
    Print chr(176, 177, 178 , 219);
    color 15,7
    Print chr(176, 177, 178 , 219);
    Color 0,15
    Print " PMedia TinyIRC 1.0 " ;
    color 15,7
    Print Chr(219, 178, 177, 176);
    color 7,8
    Print Chr(219, 178, 177, 176);
    color 8,0
    Print Chr(219, 178, 177, 176)

    locate 25,1
    Color 0,3
    print "Enter=Send"+chr(219)+"F1=Notice"+Chr(219)+"F2=Message"+_
    Chr(219)+"F3=Join"+Chr(219)+"F4=Destination"+CHR(219)+"F5=NICK"+_
    CHR(219)+"ESC=Exit";
    Color 15,10

    MsgChg = 1

    Do
        View Print 2 to 24
        Locate LastLine,1
        if saccess = 1 then
            s = replace(s,Newline, "")

            if mid(s, 1,1) <> ":" then s = ":" + s

            If Instr(replace(s, ":" + substr(s, ":", 2)+":", ""),Nick) Then
                Beep
            End If

            if substr(substr(ucase(s), ":", 2)," ",2) = "PRIVMSG" Then
                'SendText("PRIVMSG #FREEBASIC.DE :" + s + NEWLINE)
                Color 15,0
                Print "<"+substr(substr(substr(s, ":", 2)," ",1),"!",1)_
                + "@" + substr(substr(s, ":", 2)," ",3) + "> ";
                Color 7,0
                Print replace(s, ":" + substr(s, ":", 2)+":", "")
                LastLine = CSRLIN
            Elseif substr(substr(ucase(s), ":", 2)," ",2) = "NOTICE" Then
                'SendText("PRIVMSG #FREEBASIC.DE :" + s + NEWLINE)
                Color 7,0
                Print "<"+substr(substr(substr(s, ":", 2)," ",1),"!",1)_
                + "@" + substr(substr(s, ":", 2)," ",3) + "> ";
                Color 8,0
                Print replace(s, ":" + substr(s, ":", 2)+":", "")
                LastLine = CSRLIN
            ElseIf substr(substr(ucase(s), ":", 2)," ",2) = "NICK" Then
                View Print 2 to 24
                Locate LastLine,1
                Color 10,0
                Print substr(substr(substr(s, ":", 2)," ",1),"!",1) +_
                " is now known as " + replace(s, ":" + substr(s, ":", 2)_
                +":", "")
                LastLine = CSRLIN
            ElseIf substr(substr(ucase(s), ":", 2)," ",2) = "KICK" Then
                View Print 2 to 24
                Locate LastLine,1
                Color 12,0
                Print substr(substr(substr(s, ":", 2)," ",1),"!",1) +_
                      " kicked "+substr(substr(s, ":", 2)," ",4)+" from "+_
                      substr(substr(s, ":", 2)," ",3)+" (reason: " +_
                      replace(s, ":" + substr(s, ":", 2)+":", "")+")"
                LastLine = CSRLIN
            Elseif substr(substr(ucase(s), ":", 2)," ",2) = "PING" Then
                Color 8,0
                Print "PING"
                SendText("PONG "+NEWLINE)
            End IF
            saccess = 0
        End If

        sleep 5
        View Print 1 to 25
        If MsgChg = 1 then

            Locate 24,1,0
            Color 15,0
            If MsgMode = 0 then
                Print "PRIVMSG";
            ElseIf MsgMode = 1 then
                Print "NOTICE";
            ElseIf MsgMode = 2 then
                Print "Join";
            ElseIf MsgMode = 3 then
                Print "Destination";
            ElseIf MsgMode = 4 then
                Print "NICK";
            End If

            Color 7,0
            Print ":";

            'Ich weiß, ich bin Faul:
            If MsgMode = 0 then
              If Len(InpBuff) < Len("PrivMsg:") then
                COlor 15,0
                Print InpBuff + Space(79 - Len("PrivMsg:") - Len(InpBuff))
              else
                COlor 15,0
                Print right(InpBuff, 79-Len("PrivMsg:"))
              End If
            ElseIf MsgMode = 1 then
              If Len(InpBuff) < Len("Notice:") then
                COlor 15,0
                Print InpBuff + Space(79 - Len("Notice:") - Len(InpBuff))
              else
                COlor 15,0
                Print right(InpBuff, 79-Len("Notice:"))
              End If
            ElseIf MsgMode = 2 then
              If Len(InpBuff) < Len("Join:") then
                COlor 15,0
                Print InpBuff + Space(79 - Len("Join:") - Len(InpBuff))
              else
                COlor 15,0
                Print right(InpBuff, 79-Len("Join:"))
              End If
            ElseIf MsgMode = 3 then
              If Len(InpBuff) < Len("Destination:") then
                COlor 15,0
                Print InpBuff + Space(79 - Len("Destination:") - Len(InpBuff))
              else
                COlor 15,0
                Print right(InpBuff, 79-Len("Destination:"))
              End If
            ElseIf MsgMode = 4 then
              If Len(InpBuff) < Len("Nick:") then
                COlor 15,0
                Print InpBuff + Space(79 - Len("Nick:") - Len(InpBuff))
              else
                COlor 15,0
                Print right(InpBuff, 79-Len("Nick:"))
              End If
            End If

            MsgChg = 0

        End If

        KeyIn = Inkey

        If KeyIn = Chr(255, Asc("k")) then
        elseif keyin = Chr(13) then
            If MsgMode = 0 then
                SendText("PRIVMSG "+Destination+" :"+InpBuff+NEWLINE)
                View Print 2 to 24
                Locate LastLine,1
                Color 10,0
                Print "<"+Nick + "@" + Destination + "> ";
                Color 2,0
                Print InpBuff
                LastLine = CSRLIN
            ElseIf MsgMode = 1 then
                SendText("NOTICE "+Destination+" :"+InpBuff+NEWLINE)
                View Print 2 to 24
                Locate LastLine,1
                Color 9,0
                Print "<"+Nick + "@" + Destination + "> ";
                Color 8,0
                Print InpBuff
                LastLine = CSRLIN
            ElseIf MsgMode = 2 then
                SendText("JOIN "+InpBuff+NEWLINE)
                Destination = InpBuff
                View Print 2 to 24
                Locate LastLine,1
                Color 10,0
                Print Nick + " joined " + Destination
                LastLine = CSRLIN
            ElseIf MsgMode = 3 then
                Destination = InpBuff
            ElseIf MsgMode = 4 then
                Nick = InpBuff
                SendText("NICK "+Nick+NEWLINE)
            End If
            InpBuff = ""
            MsgMode = 0
            MsgChg = 1
        ElseIf KeyIn = Chr(255, Asc(";")) then 'F1
            MsgMode = 0
            MsgChg = 1
        ElseIf KeyIn = Chr(255, Asc("<")) then 'F2
            MsgMode = 1
            MsgChg = 1
        ElseIf KeyIn = Chr(255, Asc("=")) then 'F3
            MsgMode = 2
            MsgChg = 1
        ElseIf KeyIn = Chr(255, Asc(">")) then 'F4
            MsgMode = 3
            MsgChg = 1
        ElseIf KeyIn = Chr(255, 63) then 'F5
            MsgMode = 4
            MsgChg = 1
        ElseiF KeyIn = Chr(8) then
            InpBuff = Left(InpBuff, Len(InpBuff)-1)
            MsgChg = 1
        ElseIf Instr(KeyIn,ANY Chr(01, 02, 03,04,05,06,_
            07,08,09,10,11,12,13,14,15,16,17,18,19,20,21,_
            22,23,24,25,26,27,28,29,30,31,255)) Then
            'Nix da... diese Zeichen gibts nicht für kleine Spinner *g*
            'aber für Debug isses scho ganz nett:
            'print Asc(Mid(KeyIn,1,1))
            'print Asc(Mid(KeyIn,2,1))
        Else
            InpBuff += KeyIn
            MsgChg = 1
        End If

    Loop Until instr(ucase(Message),"QUIT") OR_
               KeyIn = Chr(255) + "k" OR KeyIn = Chr(27)
    SendText("QUIT tIRC - written in FreeBASIC:"+NEWLINE)
    sleep 10
    doshutdown()