Changeset 691 for trunk

Timestamp:

Mar 16, 2009, 8:34:59 AM (15 years ago)

Author:

イグトランス (egtra)

Message:

プロンプト画面のテキスト描画を、1文字ずつから、同じ色のテキストをまとめて書く方法へ変更。また、一部の制御コードに対応 (NUL, BEL, BS, HT, LF, FF, CR)。

File:

• trunk/ab5.0/ablib/src/basic/prompt.sbp (modified) (4 diffs)

trunk/ab5.0/ablib/src/basic/prompt.sbp

@@ -42 +42 @@
     ForeColor As COLORREF
     BackColor As COLORREF
-    StartPos As Long
 End Type
 
@@ -79 +78 @@
 End Sub
 
+Sub DrawTextBlock(hdc As HDC, len As Long, p As PCTSTR, ci As *_PromptSys_CharacterInformation)
+    If len = 0 Then
+        Exit Sub
+    End If
+
+    If ci[0].BackColor = -1 Then
+        SetBkMode(hdc, TRANSPARENT)
+    Else
+        SetBkMode(hdc, OPAQUE)
+        SetBkColor(hdc, ci[0].BackColor)
+    End If
+    SetTextColor(hdc, ci[0].ForeColor)
+
+    Dim i As Long
+    For i = 0 To ELM(len)
+        If ci[i].ForeColor <> ci[0].ForeColor Or ci[i].BackColor <> ci[0].BackColor Then
+            TextOut(hdc, 0, 0, p, i)
+            DrawTextBlock(hdc, len - 1, VarPtr(p[i]), VarPtr(ci[i]))
+            Exit Sub
+        End If
+    Next
+    TextOut(hdc, 0, 0, p, i)
+End Sub
+
 Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long)
-    Dim i As Long, i2 As Long, i3 As Long
-    Dim ret As Long
+    Dim i As Long
 
     Dim hOldFont = SelectObject(hDC, _PromptSys_hFont) As HFONT
@@ -105 +127 @@
     Wend
 
-    i = 0' : Debug
-    While i * _PromptSys_FontSize.cy < rc.bottom and i <= 100
-        If StartLine=-1 or (StartLine<=i and i<=EndLine) Then
-            Dim currentLineCharInfo = _PromptSys_TextLine[i].CharInfo
-
-            Dim sz As SIZE
-            i3 = _PromptSys_TextLine[i].Length
-            _PromptSys_GetTextExtentPoint32(hDC, _PromptSys_TextLine[i].Text, i3, sz)
-
-'           BitBlt(hDC,_
-'               sz.cx, i * _PromptSys_FontSize.cy, _
-'               rc.right, _PromptSys_FontSize.cy, _
-'               _PromptSys_hMemDC, sz.cx, i * _PromptSys_FontSize.cy, SRCCOPY)
-
-            While i2 < i3
-                SetTextColor(hDC, currentLineCharInfo[i2].ForeColor)
-                If currentLineCharInfo[i2].BackColor = -1 Then
-                    SetBkMode(hDC, TRANSPARENT)
-                Else
-'                   Debug
-                    ret = SetBkMode(hDC, OPAQUE)
-                    ret = SetBkColor(hDC, currentLineCharInfo[i2].BackColor)
-                End If
-
-                Dim tempLen As Long
-                If _System_IsDoubleUnitChar(_PromptSys_TextLine[i].Text[i2], _PromptSys_TextLine[i].Text[i2+1]) Then
-                    tempLen = 2
-                Else
-                    tempLen = 1
-                End If
-                With _PromptSys_FontSize
-                    _PromptSys_TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]) As *Char, tempLen)
-                End With
-                i2 += tempLen
-            Wend
-        End If
-
+    SetTextAlign(hDC, TA_LEFT Or TA_TOP Or TA_UPDATECP)
+    i = 0
+    While i * _PromptSys_FontSize.cy < rc.bottom And i <= 100
+        If StartLine = -1 Or (StartLine <= i And i <= EndLine) Then
+            With _PromptSys_TextLine[i]
+                BitBlt(hDC,_
+                    0, i * _PromptSys_FontSize.cy, _
+                    rc.right, _PromptSys_FontSize.cy, _
+                    _PromptSys_hMemDC, 0, i * _PromptSys_FontSize.cy, SRCCOPY)
+                MoveToEx(hDC, 0, i * _PromptSys_FontSize.cy, ByVal 0)
+                DrawTextBlock(hDC, .Length, .Text, .CharInfo)
+            End With
+        End If
         i++
     Wend
-
     SelectObject(hDC, hOldFont)
 End Sub
 
 Sub PRINT_ToPrompt(buf As String)
-    OutputDebugString(ToTCStr(Ex"PRINT_ToPrompt " + buf + Ex"\r\n"))
+    System.Diagnostics.Debug.WriteLine("PRINT_ToPrompt: " + buf)
+    PrintToPromptImpl(ToTCStr(buf), Len(buf))
+End Sub
+
+/*
+@brief PrintToPromptImplの内部関数
+@date 2009/03/16
+@author Egtra
+出力行が変わるときに呼ばれる。
+*/
+Sub SetLineLength()
+    _PromptSys_TextLine[_PromptSys_CurPos.y].Length = System.Math.Max(_PromptSys_TextLine[_PromptSys_CurPos.y].Length, _PromptSys_CurPos.x)
+End Sub
+
+/*
+@brief PrintToPromptImplの内部関数
+@date 2009/03/16
+@author Egtra
+1文字を出力するときに呼ばれる。
+*/
+Sub PutCharToPrompt(c As Char)
+    With _PromptSys_CurPos
+        Dim current = _PromptSys_TextLine[.y]
+        current.Text[.x] = c
+        current.CharInfo[.x].ForeColor = _PromptSys_NowTextColor
+        current.CharInfo[.x].BackColor = _PromptSys_NowBackColor
+        .x++
+    End With
+End Sub
+
+Sub PrintToPromptImpl(p As PCTSTR, len As Long)
     EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
-    If buf = "あ" Then Debug
-    With _PromptSys_CurPos
-        Dim hdc = GetDC(_PromptSys_hWnd)
-        Dim hOldFont = SelectObject(hdc, _PromptSys_hFont)
-        Dim StartLine = .y As Long
-        Dim bufLen = buf.Length
-        Dim doubleUnitChar = False As Boolean
-        'Addition
-        Dim i2 = 0 As Long, i3 As Long
-        For i2 = 0 To ELM(bufLen)
-            If buf[i2] = &h0d Then 'CR \r
-                _PromptSys_TextLine[.y].Length = .x
-                .x = 0
-            ElseIf buf[i2] = &h0a Then 'LF \n
-                _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
-                .y++
-            Else
-                Dim currentLineCharInfo = _PromptSys_TextLine[.y].CharInfo
-                _PromptSys_TextLine[.y].Text[.x] = buf[i2]
-                currentLineCharInfo[.x].ForeColor = _PromptSys_NowTextColor
-                currentLineCharInfo[.x].BackColor = _PromptSys_NowBackColor
-
-                If buf[i2] = &h09 Then 'tab
-                    Dim tabStop = _PromptSys_FontSize.cx * 8
-                    currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + _
-                        tabStop - currentLineCharInfo[.x].StartPos Mod tabStop
-                Else
-                    If doubleUnitChar <> False Then
-                        doubleUnitChar = False
-                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos
-                    Else
-                        Dim sz As SIZE
-                        Dim charLen As Long
-                        If _System_IsDoubleUnitChar(buf[i2], buf[i2 + 1]) Then
-                            charLen = 2
-                            doubleUnitChar = True
-                        Else
-                            charLen = 1
-                        EndIf
-                        Dim p = buf.StrPtr
-                        _PromptSys_GetTextExtentPoint32(hdc, VarPtr(p[i2]) As *Char, charLen, sz)
-                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx
-                    End If
-                End If
-                .x++
-            End If
-        Next
-        _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
-
-        'Draw the text buffer added
-        'DrawPromptBuffer(hdc, StartLine, .y)
-        InvalidateRect(_PromptSys_hWnd, ByVal 0, TRUE)
-        UpdateWindow(_PromptSys_hWnd)
-        SelectObject(hdc, hOldFont)
-        ReleaseDC(_PromptSys_hWnd, hdc)
-    End With
+    Dim leadByte = False
+    'Addition
+    Dim i = 0 As Long
+    For i = 0 To ELM(len)
+        If leadByte Then
+            PutCharToPrompt(p[i])
+        Else
+            With _PromptSys_CurPos
+                Select Case p[i]
+                    Case 13 'CR \r 復帰
+                        SetLineLength()
+                        .x = 0
+                    Case 12 'FF フォームフィード
+                        Cls 1
+                    Case 10 'LF 改行
+                        SetLineLength()
+                        .y++
+                    Case 9 'HT 水平タブ
+                        Dim j As Long
+                        For j = (.x And 7) To ELM(8)
+                            PutCharToPrompt(&h20) '空白
+                        Next
+                    Case 8 'BS 後退
+                        .x--
+                    Case 7 'BEL ベル
+                        MessageBeep(MB_ICONHAND) 'PuTTY由来のアイディア
+                    Case 0 'NUL 空文字
+                    Case Else
+                        PutCharToPrompt(p[i])
+                        If IsDBCSLeadByte(p[i]) Then
+                            leadByte = True
+                        End If
+                End Select
+            End With
+        End If
+    Next
+    SetLineLength() 
+
     LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
+
+    InvalidateRect(_PromptSys_hWnd, ByVal 0, TRUE)
+    UpdateWindow(_PromptSys_hWnd)
 End Sub
 
@@ -313 +325 @@
         CreateCaret(hwnd, 0, 9, 6)
         With _PromptSys_CurPos
-            SetCaretPos(_PromptSys_TextLine[.y].CharInfo[.x].StartPos, (.y + 1) * _PromptSys_FontSize.cy - 7)
+            SetCaretPos(.x * _PromptSys_FontSize.cx, (.y + 1) * _PromptSys_FontSize.cy - 7)
         End With
         ShowCaret(hwnd)