source: trunk/ab5.0/ablib/src/Classes/System/Console.ab@ 707

'Classes/System/Console.ab

Namespace System

Enum ConsoleColor
    Black       = 0 
    DarkGray    = FOREGROUND_INTENSITY
    Gray        = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE
    White       = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY

    DarkRed     = FOREGROUND_RED
    Red         = FOREGROUND_RED Or FOREGROUND_INTENSITY

    DarkYellow  = FOREGROUND_RED Or FOREGROUND_GREEN
    Yellow      = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY

    DarkGreen   = FOREGROUND_GREEN
    Green       = FOREGROUND_GREEN Or FOREGROUND_INTENSITY

    DarkCyan    = FOREGROUND_GREEN Or FOREGROUND_BLUE
    Cyan        = FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY

    DarkBlue    = FOREGROUND_BLUE
    Blue        = FOREGROUND_BLUE Or FOREGROUND_INTENSITY

    DarkMagenta = FOREGROUND_RED Or FOREGROUND_BLUE
    Magenta     = FOREGROUND_RED Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY
End Enum


/*
@brief コンソール入出力・ウィンドウなどのクラス
@date 2008/02/26
@auther Egtra
*/
Class Console
Public
    /*
    @brief コンソールの背景色を取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub BackgroundColor ( value As ConsoleColor )
        If ActiveBasic.IsNothing(Console.out) Then
            Exit Sub
        Else
            If Console.hconsoleout = NULL Then
                Exit Sub
            Else
                Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
                Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
                If ret = 0 Then Throw New IO.IOException()
                csbi.wAttributes And = &HFF0F'背景色だけ変更できるようにマスク処理
                ret = SetConsoleTextAttribute(Console.hconsoleout,csbi.wAttributes Or (This.ConsoleColorToTextAttribute(value)<<4) As Word/* foreをbackへ変換 */)           
                If ret = 0 Then Throw New IO.IOException()
            End If
        End If
    End Sub
    Static Function BackgroundColor() As ConsoleColor
        If ActiveBasic.IsNothing(Console.out) Then
            Return ConsoleColor.Gray
        Else
            If Console.hconsoleout = NULL Then
                Return ConsoleColor.Gray
            Else
                Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
                Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
                If ret = 0 Then Throw New IO.IOException()
                Dim attributes = csbi.wAttributes And &H00F0'背景色だけ取り出せるようにマスク処理
                Return This.TextAttributeToConsoleColor(attributes>>4/* backをforeへ変換 */)
            End If
        End If
    End Function


    /*
    @brief バッファ領域の高さを取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub BufferHeight ( value As Long )
        Dim width As Long, height As Long
        This.GetBufferSize(width,height)
        Console.SetBufferSize(width,value)
    End Sub
    Static Function BufferHeight () As Long
        Dim width As Long, height As Long
        This.GetBufferSize(width,height)
        Return height
    End Function

    /*
    @brief バッファ領域の幅を取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub BufferWidth ( value As Long )
        Dim width As Long, height As Long
        This.GetBufferSize(width,height)
        Console.SetBufferSize(value,height)
    End Sub
    Static Function BufferWidth () As Long
        Dim width As Long, height As Long
        This.GetBufferSize(width,height)
        Return width
    End Function

    /*
    @brief カーソルの列位置を取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub CursorLeft ( value As Long )
        Dim left As Long, top As Long
        This.GetCursorPosition(left,top)
        Console.SetCursorPosition(value,top)
    End Sub
    Static Function CursorLeft () As Long
        Dim left As Long, top As Long
        This.GetCursorPosition(left,top)
        Return left
    End Function

    /*
    @brief 文字セル内のカーソルの高さを取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub CursorSize ( value As Long )
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim cci As CONSOLE_CURSOR_INFO
            Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci)
            If ret = 0 Then Throw New IO.IOException()
            cci.dwSize = value As DWord
            ret = SetConsoleCursorInfo(Console.hconsoleout,cci)
            If ret = 0 Then Throw New IO.IOException()
        End If
    End Sub
    Static Function CursorSize () As Long
        If Console.hconsoleout = NULL Then
            Return -1 As Long
        Else
            Dim cci As CONSOLE_CURSOR_INFO
            Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci)
            If ret = 0 Then Throw New IO.IOException()
            Return cci.dwSize As Long
        End If
    End Function

    /*
    @brief カーソルの行位置を取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub CursorTop ( value As Long )
        Dim left As Long, top As Long
        This.GetCursorPosition(left,top)
        Console.SetCursorPosition(left,value)
    End Sub
    Static Function CursorTop () As Long
        Dim left As Long, top As Long
        This.GetCursorPosition(left,top)
        Return top
    End Function

    /*
    @brief カーソルを表示するかどうかを示す値を取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub CursorVisible ( visible As Boolean )
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim cci As CONSOLE_CURSOR_INFO
            Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci)
            If ret = 0 Then Throw New IO.IOException()
            cci.bVisible = visible As BOOL
            ret = SetConsoleCursorInfo(Console.hconsoleout,cci)
            If ret = 0 Then Throw New IO.IOException()
        End If
    End Sub
    Static Function CursorVisible () As Boolean
        If Console.hconsoleout = NULL Then
            Return False
        Else
            Dim cci As CONSOLE_CURSOR_INFO
            Dim ret = GetConsoleCursorInfo(Console.hconsoleout,cci)
            If ret = 0 Then Throw New IO.IOException()
            Return cci.bVisible As Boolean
        End If
    End Function

    /*
    @brief コンソールの前景色を取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub ForegroundColor ( value As ConsoleColor )
        If ActiveBasic.IsNothing(Console.out) Then
            Exit Sub
        Else
            If Console.hconsoleout = NULL Then
                Exit Sub
            Else
                Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
                Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
                If ret = 0 Then Throw New IO.IOException()
                csbi.wAttributes And = &HFFF0'前景色だけ変更できるようにマスク処理
                ret = SetConsoleTextAttribute(Console.hconsoleout,csbi.wAttributes Or This.ConsoleColorToTextAttribute(value))          
                If ret = 0 Then Throw New IO.IOException()
            End If
        End If
    End Sub
    Static Function ForegroundColor() As ConsoleColor
        If ActiveBasic.IsNothing(Console.out) Then
            Return ConsoleColor.Gray
        Else
            If Console.hconsoleout = NULL Then
                Return ConsoleColor.Gray
            Else
                Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
                Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
                If ret = 0 Then Throw New IO.IOException()
                Dim attributes = csbi.wAttributes And &H000F'前景色だけ取り出せるようにマスク処理
                Return This.TextAttributeToConsoleColor(attributes)
            End If
        End If
    End Function

    /*
    @brief コンソールのタイトルを取得または設定する
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub Title( title As String )
        If Console.hconsoleout =NULL Then
            Exit Sub
        Else
            SetConsoleTitle(ToTCStr(title))
        End If
    End Sub
    Static Function Title() As String
        If Console.hconsoleout =NULL Then
            Return ""
        Else
            Dim sb = New Text.StringBuilder
            sb.Length = 24500
            Dim ret = GetConsoleTitle(StrPtr(sb),sb.Length())
            If ret = 0 Then
                Dim error = GetLastError()
                If error <> ERROR_SUCCESS Then
                    ActiveBasic.Windows.ThrowWithErrorCode(error, "Console.Title")
                End If
            End If
            sb.Length = ret
            Return sb.ToString()
        End If
    End Function


    /*
    @brief 標準エラー出力を設定する
    @date 2008/08/21
    @auther Egtra
    */
    Static Sub SetError(newErr As IO.TextWriter)
        If ActiveBasic.IsNothing(newErr) Then
            Throw New ArgumentNullException("newErr")
        End If
        Console.err = newErr
'       Dim sw = Console.err As IO.StreamWriter
'       Dim fs = sw.BaseStream() As IO.FileStream
'       Console.hconsoleerr = fs.Handle()
    End Sub

    /*
    @brief 標準エラー出力を取得する
    @date 2008/08/21
    @auther Egtra
    */
    Static Function Error() As IO.TextWriter
        Error = err
    End Function

    /*
    @brief 標準出力を設定する
    @date 2008/06/21
    @auther overtaker
    */
    Static Sub SetOut(newOut As IO.TextWriter)
        If ActiveBasic.IsNothing(newOut) Then
            Throw New ArgumentNullException("newOut")
        End If
        Console.out = newOut
    End Sub

    /*
    @brief 標準出力を取得する
    @date 2008/06/21
    @auther overtaker
    */
    Static Function Out() As IO.TextWriter
        Out = out
    End Function

    /*
    @brief 標準出力に1行書き込む
    @date 2008/06/21
    @auther overtaker
    */
    Static Sub WriteLine(value As String)
        out.WriteLine(value)
        out.Flush()
    End Sub

    Static Sub WriteLine()
        out.WriteLine()
        out.Flush()
    End Sub

    Static Sub WriteLine(x As Boolean)
        WriteLine(Str$(x))
    End Sub
    
    Static Sub WriteLine(x As Char)
        WriteLine(Chr$(x))
    End Sub

    Static Sub WriteLine(x As Byte)
        WriteLine(Str$(x))
    End Sub
#ifdef UNICODE
    Static Sub WriteLine(x As SByte)
        WriteLine(Str$(x))
    End Sub
#else
    Static Sub WriteLine(x As Word)
        WriteLine(Str$(x))
    End Sub
#endif
    Static Sub WriteLine(x As Integer)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As DWord)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As Long)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As QWord)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As Int64)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As Single)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As Double)
        WriteLine(Str$(x))
    End Sub

    Static Sub WriteLine(x As Object)
        WriteLine(x.ToString)
    End Sub

    /*
    @brief 標準出力に書き込む
    @date 2008/06/21
    @auther overtaker
    */
    Static Sub Write(s As String)
        out.Write(s)
        out.Flush()
    End Sub

    Static Sub Write(x As Boolean)
        Write(Str$(x))
    End Sub

    Static Sub Write(x As Char)
        Write(Chr$(x))
    End Sub

    Static Sub Write(x As Byte)
        Write(Str$(x))
    End Sub
#ifdef UNICODE
    Static Sub Write(x As SByte)
        Write(Str$(x))
    End Sub
#else
    Static Sub Write(x As Word)
        Write(Str$(x))
    End Sub
#endif
    Static Sub Write(x As Integer)
        Write(Str$(x))
    End Sub

    Static Sub Write(x As DWord)
        Write(Str$(x))
    End Sub

    Static Sub Write(x As Long)
        Write(Str$(x))
    End Sub

    Static Sub Write(x As QWord)
        Write(Str$(x))
    End Sub

    Static Sub Write(x As Int64)
        Write(Str$(x))
    End Sub

    Static Sub Write(x As Object)
        Write(x.ToString)
    End Sub

    /*
    @brief 標準入力を設定する
    @date 2008/02/26
    @auther Egtra
    */
    Static Sub SetIn(newIn As IO.TextReader)
        If ActiveBasic.IsNothing(newIn) Then
            Throw New ArgumentNullException("newIn")
        End If
        Console.in = newIn
    End Sub

    /*
    @brief 標準入力を取得する
    @date 2008/02/26
    @auther Egtra
    */
    Static Function In() As IO.TextReader
        In = in
    End Function

    /*
    @brief 標準入力から1行読み込む
    @date 2008/02/26
    @auther Egtra
    */
    Static Function ReadLine() As String
        ReadLine = in.ReadLine()
    End Function

    /*
    @brief 標準入力から1行読み込む
    @date 2008/02/26
    @auther Egtra
    */
    Static Function Read() As Long
        Read = in.Read()
    End Function

    /*
    @brief  コンソール バッファおよび対応するコンソール ウィンドウをクリア
    @date   2008/09/02
    @auther NoWest
    */
    Static Sub Clear()
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
            Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
            If ret = 0 Then Throw New IO.IOException()
            Dim length = csbi.dwSize.X * csbi.dwSize.Y
            Dim written As DWord
            Dim s = New String(" ")
            ret = FillConsoleOutputCharacter(Console.hconsoleout,s[0],length,0,written)
            If ret = 0 Then Throw New IO.IOException()
            ret = FillConsoleOutputAttribute(Console.hconsoleout,csbi.wAttributes,length,0,written)
            If ret = 0 Then Throw New IO.IOException()
            ret = SetConsoleCursorPosition(Console.hconsoleout,0)
            If ret = 0 Then Throw New IO.IOException()
        End If
    End Sub

    /*
    @brief  標準エラー ストリームを取得
    @date   2008/09/07
    @auther NoWest
    */
    Static Sub OpenStandardError()
        Dim w = New Detail.ConsoleWriter(hconsoleerr)
        Console.SetOut(System.IO.TextWriter.Synchronized(w))
    End Sub

    /*
    @brief  標準入力ストリーム ストリームを取得
    @date   2008/09/07
    @auther NoWest
    */
    Static Sub OpenStandardInput()
        Dim w = New Detail.ConsoleReader(hconsolein)
        Console.SetIn(System.IO.TextReader.Synchronized(w))
    End Sub

    /*
    @brief  標準出力ストリーム ストリームを取得
    @date   2008/09/07
    @auther NoWest
    */
    Static Sub OpenStandardOutput()
        Dim w = New Detail.ConsoleWriter(hconsoleout)
        Console.SetOut(System.IO.TextWriter.Synchronized(w))
        Console.defBC = This.ConsoleColorToTextAttribute(Console.BackgroundColor)
        Console.defFC = This.ConsoleColorToTextAttribute(Console.ForegroundColor)
    End Sub

    /*
    @brief  コンソールの前景色および背景色を既定値に設定
    @date   2008/09/07
    @auther NoWest
    */
    Static Sub ResetColor()
        Console.BackgroundColor = TextAttributeToConsoleColor(Console.defBC)
        Console.ForegroundColor = TextAttributeToConsoleColor(Console.defFC)
    End Sub

    /*
    @brief バッファ領域の高さと幅を指定された値に設定
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub SetBufferSize ( width As Long, height As Long )
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim size As COORD
            size.X = width As Integer
            size.Y = height As Integer
            Dim ret = SetConsoleScreenBufferSize(Console.hconsoleout,COORDtoDWORD(size))
            If ret = 0 Then Throw New IO.IOException()
        End If
    End Sub

    /*
    @brief カーソルの位置を設定
    @date 2008/09/02
    @auther NoWest
    */
    Static Sub SetCursorPosition ( left As Long, top As Long )
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim pos As COORD
            pos.X = left As Integer
            pos.Y = top As Integer
            Dim ret = SetConsoleCursorPosition(Console.hconsoleout,COORDtoDWORD(pos))
            If ret = 0 Then Throw New IO.IOException()
        End If
    End Sub

Private
    Function enter() As ActiveBasic.Windows.CriticalSectionLock
        Imports ActiveBasic.Windows
        If ActiveBasic.IsNothing(cs) Then
            Dim lock = New CriticalSectionLock(_System_CriticalSection)
            Try
                If ActiveBasic.IsNothing(cs) Then
                    cs = New CriticalSection
                End If
            Finally
                lock.Dispose()
            End Try
        End If
        enter = cs.Enter
    End Function

    Function ConsoleColorToTextAttribute( value As ConsoleColor ) As Word
        Dim ret = value As DWord
        Return ret As Word
    End Function

    Function TextAttributeToConsoleColor( value As Word ) As ConsoleColor
        Select Case value
            Case 0
                Return ConsoleColor.Black
            Case FOREGROUND_INTENSITY
                Return ConsoleColor.DarkGray
            Case FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE
                Return ConsoleColor.Gray
            Case FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY
                Return ConsoleColor.White
            Case FOREGROUND_RED
                Return ConsoleColor.DarkRed
            Case FOREGROUND_RED Or FOREGROUND_INTENSITY
                Return ConsoleColor.Red
            Case FOREGROUND_RED Or FOREGROUND_GREEN
                Return ConsoleColor.DarkYellow
            Case FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY
                Return ConsoleColor.Yellow
            Case FOREGROUND_GREEN
                Return ConsoleColor.DarkGreen
            Case FOREGROUND_GREEN Or FOREGROUND_INTENSITY
                Return ConsoleColor.Green
            Case FOREGROUND_GREEN Or FOREGROUND_BLUE
                Return ConsoleColor.DarkCyan
            Case FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY
                Return ConsoleColor.Cyan
            Case FOREGROUND_BLUE
                Return ConsoleColor.DarkBlue
            Case FOREGROUND_BLUE Or FOREGROUND_INTENSITY
                Return ConsoleColor.Blue
            Case FOREGROUND_RED Or FOREGROUND_BLUE
                Return ConsoleColor.DarkMagenta
            Case FOREGROUND_RED Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY
                Return ConsoleColor.Magenta
            Case Else
                Return ConsoleColor.Gray
        End Select
    End Function

    Sub GetCursorPosition ( ByRef left As Long, ByRef top As Long )
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
            Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
            If ret = 0 Then Throw New IO.IOException()
            left = csbi.dwCursorPosition.X
            top = csbi.dwCursorPosition.Y
        End If
    End Sub

    Sub GetBufferSize ( ByRef width As Long, ByRef height As Long )
        If Console.hconsoleout = NULL Then
            Exit Sub
        Else
            Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
            Dim ret = GetConsoleScreenBufferInfo(Console.hconsoleout,csbi)
            If ret = 0 Then Throw New IO.IOException()
            width = csbi.dwSize.X
            height = csbi.dwSize.Y
        End If
    End Sub

    Static hconsoleerr = GetStdHandle(STD_ERROR_HANDLE) As HANDLE
    Static hconsolein = GetStdHandle(STD_INPUT_HANDLE) As HANDLE
    Static hconsoleout = GetStdHandle(STD_OUTPUT_HANDLE) As HANDLE
    Static in = Nothing As IO.TextReader
    Static out = Nothing As IO.TextWriter
    Static err = Nothing As IO.TextWriter
    Static cs = Nothing As ActiveBasic.Windows.CriticalSection
    Static defBC As Word
    Static defFC As Word
End Class

Namespace Detail

Class ConsoleWriter
    Inherits IO.TextWriter
Public
    Sub ConsoleWriter(hOut As HANDLE)
        h = hOut
    End Sub

    Override Sub Flush()
        Dim b = Buffer
        Dim written As DWord
        WriteConsole(h, StrPtr(b), b.Length As DWord, written, 0)
        b.Remove(0, written As Long)
    End Sub

Private
    h As HANDLE
End Class

Class ConsoleReader
    Inherits IO.TextReader
Public
    Sub ConsoleReader(hIn As HANDLE)
        h = hIn
    End Sub

Protected
    Override Function Underflow() As Boolean
        If eofReached Then
            Underflow = 0
        Else
            Dim b = Buffer
            Dim currentBufLength = b.Length
            b.Length = currentBufLength + 256
            Dim p = StrPtr(b)
            Dim read As DWord
            If ReadConsole(h, VarPtr(p[currentBufLength]), 256 * SizeOf (TCHAR), read, 0) = 0 Then
                IO.Detail.ThrowWinLastErrorIOException()
            End If
            Dim eofPos = ActiveBasic.Strings.ChrFind(VarPtr(p[currentBufLength]) As PCTSTR, read As SIZE_T, &h1A As TCHAR)
            If eofPos <> -1 Then
                eofReached = True
                read = eofPos
            End If
            b.Length = currentBufLength + read
            Underflow = read <> 0
        End If
    End Function

Private
    h As HANDLE
    eofReached As Boolean
End Class

End Namespace 'Detail

End Namespace 'System