BlueGrey
calm
Elegant
Català-Valencià – Catalan
中文 – Chinese (Simplified)
中文 – Chinese (Traditional)
Česky – Czech
Dansk – Danish
Nederlands – Dutch
English – English
Suomi – Finnish
Français – French
Deutsch – German
עברית – Hebrew
हिंदी – Hindi
Magyar – Hungarian
Bahasa Indonesia – Indonesian
Italiano – Italian
日本語 – Japanese
한국어 – Korean
Македонски – Macedonian
मराठी – Marathi
Norsk – Norwegian
Polski – Polish
Português – Portuguese
Português – Portuguese (Brazil)
Русский – Russian
Slovenčina – Slovak
Slovenščina – Slovenian
Español – Spanish
Svenska – Swedish
Türkçe – Turkish
Українська – Ukrainian
Oëzbekcha – Uzbek
Subversion Repositories
Kolibri OS
(root)
/
programs
/
develop
/
fp
/
rtl
/
kos_stdio.inc
@ 3941
– Rev 666
Rev
Rev 643
|
Blame
|
Compare with Previous
|
Last modification
|
View Log
|
Download
|
RSS feed
{
}
procedure OpenStdout
(
var f
:
TextRec
)
; forward;
procedure WriteStdout
(
var f
:
TextRec
)
; forward;
procedure FlushStdout
(
var f
:
TextRec
)
; forward;
procedure CloseStdout
(
var f
:
TextRec
)
; forward;
procedure OpenStdin
(
var f
:
TextRec
)
; forward;
procedure ReadStdin
(
var f
:
TextRec
)
; forward;
procedure CloseStdin
(
var f
:
TextRec
)
; forward;
procedure AssignStdout
(
var f
:
Text
)
;
begin
Assign
(
f
,
''
)
;
TextRec
(
f
)
.
OpenFunc
:
= @OpenStdout
;
Rewrite
(
f
)
;
end
;
procedure OpenStdout
(
var f
:
TextRec
)
;
begin
TextRec
(
f
)
.
InOutFunc
:
= @WriteStdout
;
TextRec
(
f
)
.
FlushFunc
:
= @FlushStdout
;
TextRec
(
f
)
.
CloseFunc
:
= @CloseStdout
;
end
;
procedure WriteStdout
(
var f
:
TextRec
)
;
var
msg
:
String
;
begin
msg
:
= StrPas
(
PChar
(
f
.
bufptr
)
)
;
SetLength
(
msg
,
f
.
bufpos
)
;
f
.
bufpos
:
=
0
;
Konsole
.
Write
(
msg
)
;
end
;
procedure FlushStdout
(
var f
:
TextRec
)
;
begin
WriteStdout
(
f
)
;
Konsole
.
Flush
;
end
;
procedure CloseStdout
(
var f
:
TextRec
)
;
begin
end
;
procedure AssignStdin
(
var f
:
Text
)
;
begin
Assign
(
f
,
''
)
;
TextRec
(
f
)
.
OpenFunc
:
= @OpenStdin
;
Reset
(
f
)
;
end
;
procedure OpenStdin
(
var f
:
TextRec
)
;
begin
TextRec
(
f
)
.
InOutFunc
:
= @ReadStdin
;
TextRec
(
f
)
.
FlushFunc
:
= nil
;
TextRec
(
f
)
.
CloseFunc
:
= @CloseStdin
;
end
;
procedure ReadStdin
(
var f
:
TextRec
)
;
var
max
,
curpos
:
Longint
;
c
:
Longint
;
begin
max
:
= f
.
bufsize
-
Length
(
LineEnding
)
;
curpos
:
=
0
;
repeat
c
:
=
13
{
l4_getc
(
)
}
;
case c of
13
:
begin
{
f
.
bufptr^
[
curpos
]
:
= LineEnding
;}
Inc
(
curpos
)
;
f
.
bufpos
:
=
0
;
f
.
bufend
:
= curpos
;
{
l4_putc
(
Longint
(
LineEnding
)
)
;}
break
;
end
;
32
..
126
:
if curpos < max then
begin
f
.
bufptr^
[
curpos
]
:
= Char
(
c
)
;
Inc
(
curpos
)
;
{
l4_putc
(
c
)
;}
end
;
end
;
until False
;
end
;
procedure CloseStdin
(
var f
:
TextRec
)
;
begin
end
;
{
TKonsole
}
procedure KonsoleThreadMain
(
Console
:
PKonsole
)
;
{
¡®ç¨© 横« ª®á®«¨
}
var
ThreadInfo
:
TKosThreadInfo
;
Message
:
ShortString
;
Event
:
DWord
;
begin
kos_maskevents
(
ME_PAINT
or
ME_KEYBOARD
or
ME_IPC
)
;
kos_threadinfo
(
@ThreadInfo
)
;
Console^
.
FThreadSlot
:
= kos_getthreadslot
(
ThreadInfo
.
ThreadID
)
;
kos_initipc
(
Console^
.
FIPCBuffer
,
Console^
.
FIPCBufferSize
)
;
{
áà §ã ®â®¡à §¨âì ¨ ªâ¨¢¨à®¢ âì ®ª®
}
Console^
.
Paint
(
)
;
{
$
ifndef EMULATOR
}
kos_setactivewindow
(
Console^
.
FThreadSlot
)
;
{
$
endif
}
{
£®â®¢ ª ®¡à ¡®âª¥ ᮡë⨩
}
Console^
.
FOpened
:
= True
;
while
not
Console^
.
FTerminate
do
begin
Event
:
= kos_getevent
(
)
;
Console^
.
FOnAir
:
= True
;
if
not
Console^
.
FTerminate then
case Event of
SE_PAINT
:
Console^
.
Paint
(
)
;
SE_KEYBOARD
:
Console^
.
ProcessKeyboard
(
kos_getkey
(
)
)
;
SE_IPC
:
while Console^
.
ReceiveMessage
(
Message
)
do
Console^
.
ProcessMessage
(
Message
)
;
end
;
Console^
.
FOnAir
:
= False
;
end
;
Console^
.
FOpened
:
= False
;
end
;
constructor TKonsole
.
Init
(
ACaption
:
String
)
;
const
IPC_SIZE =
4096
;
var
ThreadInfo
:
TKosThreadInfo
;
begin
if ACaption <>
''
then
FCaption
:
= ACaption else
begin
kos_threadinfo
(
@ThreadInfo
)
;
FCaption
:
= StrPas
(
ThreadInfo
.
AppName
)
;
end
;
SetLength
(
FLines
,
1
)
;
FLines
[
0
]
:
=
''
;
FCursor
.
X
:
=
1
;
FCursor
.
Y
:
=
0
;
FMaxLines
:
=
150
;
FTerminate
:
= False
;
FOpened
:
= False
;
FOnAir
:
= False
;
FIPCBufferSize
:
= SizeOf
(
TKosIPC
)
+
IPC_SIZE
;
FIPCBuffer
:
= GetMem
(
FIPCBufferSize
)
;
FIPCBuffer^
.
Lock
:
= False
;
FIPCBuffer^
.
Size
:
=
0
;
FThreadSlot
:
=
-
1
;
FThreadID
:
= BeginThread
(
TThreadFunc
(
@KonsoleThreadMain
)
,
@Self
)
;
if FThreadID <>
0
then
{
XXX
:
¬®¦¥â § ¢¨áãâì
}
while
not
FOpened
do
ThreadSwitch
;
end
;
destructor TKonsole
.
Done
(
)
;
begin
FTerminate
:
= True
;
if FOpened then begin Self
.
Write
(
#
0
)
; kos_delay(01); end;
if FOpened then begin Self
.
Write
(
#
0
)
; kos_delay(10); end;
if FOpened then begin Self
.
Write
(
#
0
)
; kos_delay(20); end;
if FOpened then
begin
FOpened
:
= False
;
FOnAir
:
= False
;
KillThread
(
FThreadID
)
;
end
;
{
FreeMem
(
FIPCBuffer
)
;
SetLength
(
FLines
,
0
)
;}
end
;
function TKonsole
.
ReceiveMessage
(
var Message
:
ShortString
)
:
Boolean
;
{
§¢«¥çì ¯¥à¢®¥ á®®¡é¥¨¥ ¨§ ¡ãä¥à
}
var
PMsg
:
PKosMessage
;
Size
:
Longword
;
begin
FIPCBuffer^
.
Lock
:
= True
;
if FIPCBuffer^
.
Size >
0
then
begin
PMsg
:
= Pointer
(
Longword
(
FIPCBuffer
)
+
SizeOf
(
TKosIPC
)
)
;
{
TODO
:
¯à®¢¥àª PMsg^
.
SenderID
}
{
Size
:
= PMsg^
.
Size
;
Dec
(
FIPCBuffer^
.
Size
,
Size
+
SizeOf
(
TKosMessage
)
)
;
if Size >
255
then Size
:
=
255
;
SetLength
(
Message
,
Size
)
;
Move
(
Pointer
(
Longword
(
PMsg
)
+
SizeOf
(
TKosMessage
)
)
^
,
Message
[
1
]
,
Size
)
;
if FIPCBuffer^
.
Size >
0
then
Move
(
Pointer
(
Longword
(
PMsg
)
+
SizeOf
(
TKosMessage
)
+
PMsg^
.
Size
)
^
,
PMsg^
,
FIPCBuffer^
.
Size
)
;}
{
XXX
}
Size
:
= FIPCBuffer^
.
Size
;
Dec
(
FIPCBuffer^
.
Size
,
Size
)
;
if Size >
255
then Size
:
=
255
;
SetLength
(
Message
,
Size
)
;
Move
(
PMsg^
,
Message
[
1
]
,
Size
)
;
Result
:
= True
;
end else
begin
Message
:
=
''
;
Result
:
= False
;
end
;
{
FIXME
:
¥á«¨ FIPCBuffer^
.
Size =
0
,
â® FIPCBuffer^
.
Lock
¢á¥ à ¢® >
0
}
FIPCBuffer^
.
Lock
:
= False
;
end
;
procedure TKonsole
.
ProcessMessage
(
Message
:
ShortString
)
;
{
뢥á⨠ᮮ¡é¥¨¥ ª®á®«ì
}
var
OnlyBottomLine
:
Boolean = True
;
procedure PutChar
(
C
:
Char
)
;
var
LinesCount
:
Longint
;
PLine
:
PShortString
;
I
:
Longint
;
begin
{
¯¥à¥¢®¤ ª®à¥âª¨ ¯®§¨æ¨î ¢«¥¢®
}
if C = #
8
then
begin
if FCursor
.
X >
1
then
Dec
(
FCursor
.
X
)
;
end else
{
¯¥à¥¢®¤ ª®à¥âª¨ á«¥¤ãîéãî áâபã
}
if C = #
10
then
begin
OnlyBottomLine
:
= False
;
Inc
(
FCursor
.
Y
)
;
LinesCount
:
= Length
(
FLines
)
;
while FCursor
.
Y >= FMaxLines
do
Dec
(
FCursor
.
Y
,
FMaxLines
)
;
if FCursor
.
Y < LinesCount then FLines
[
FCursor
.
Y
]
:
=
''
;
while FCursor
.
Y >= LinesCount
do
begin
SetLength
(
FLines
,
LinesCount
+
1
)
;
FLines
[
LinesCount
]
:
=
''
;
Inc
(
LinesCount
)
;
end
;
end else
{
¯¥à¥¢®¤ ª®à¥âª¨ ¢ ç «® áâப¨
}
if C = #
13
then
FCursor
.
X
:
=
1
else
{
¯®¬¥é¥¨¥ ᨬ¢®« ¢ áâபã
}
begin
if FCursor
.
X >
200
then
begin
PutChar
(
#
13
)
;
PutChar
(
#
10
)
;
end
;
{
FIXME
:
᫨ ¢ PascalMain ⮫쪮 ®¤¨
Write
/
Ln
,
â® § ¢¨á®
.
á¬
.
FPC_DO_EXIT
,
InternalExit
}
PLine
:
= @FLines
[
FCursor
.
Y
]
;
I
:
= Length
(
PLine^
)
;
if FCursor
.
X > I then
begin
SetLength
(
PLine^
,
FCursor
.
X
)
;
Inc
(
I
)
;
while I < FCursor
.
X
do
begin
PLine^
[
I
]
:
=
' '
;
Inc
(
I
)
;
end
;
end
;
FLines
[
FCursor
.
Y
]
[
FCursor
.
X
]
:
= C
;
Inc
(
FCursor
.
X
)
;
end
;
end
;
var
I
:
Longint
;
begin
for I
:
=
1
to Length
(
Message
)
do
PutChar
(
Message
[
I
]
)
;
Paint
(
OnlyBottomLine
)
;
end
;
procedure TKonsole
.
ProcessKeyboard
(
Key
:
Word
)
;
begin
FKeyPressed
:
= Key
;
end
;
function TKonsole
.
GetRect
(
)
:
TKosRect
;
var
ThreadInfo
:
TKosThreadInfo
;
begin
kos_threadinfo
(
@ThreadInfo
,
FThreadSlot
)
;
Result
:
= ThreadInfo
.
WindowRect
;
end
;
function TKonsole
.
GetKeyPressed
(
)
:
Word
;
begin
Result
:
= FKeyPressed
;
FKeyPressed
:
=
0
;
end
;
procedure TKonsole
.
Paint
(
BottomRow
:
Boolean
)
;
var
Buffer
:
array
[
Byte
]
of Char
;
Rect
:
TKosRect
;
J
:
Longint
;
Width
,
Height
,
Row
:
Longint
;
CaptionHeight
,
BorderWidth
,
FontWidth
,
FontHeight
:
Longint
;
begin
CaptionHeight
:
=
16
;
BorderWidth
:
=
5
;
FontWidth
:
=
6
;
FontHeight
:
=
9
;
kos_begindraw
(
)
;
if
not
BottomRow then
begin
{
®âà¨á®¢ª ®ª
}
kos_definewindow
(
60
,
60
,
400
,
400
,
$
63000000
)
;
{
¢ë¢®¤ § £®«®¢ª
}
Move
(
FCaption
[
1
]
,
Buffer
,
Length
(
FCaption
)
)
;
Buffer
[
Length
(
FCaption
)
]
:
= #
0
;
kos_setcaption
(
Buffer
)
;
end
;
{
¯®¤£®â®¢ª ª ¢ë¢®¤ã áâப
}
Rect
:
= GetRect
(
)
;
Dec
(
Rect
.
Width
,
BorderWidth
*
2
)
;
Dec
(
Rect
.
Height
,
CaptionHeight
+
BorderWidth
*
2
)
;
Width
:
= Rect
.
Width
div
FontWidth
;
Height
:
= Rect
.
Height
-
FontHeight
;
Row
:
= FCursor
.
Y
;
while Height >
0
do
begin
{
¢ë¢®¤ ®¤®© áâப¨
}
J
:
= Length
(
FLines
[
Row
]
)
;
if J > Width then J
:
= Width
;
kos_drawtext
(
0
,
Height
,
Copy
(
FLines
[
Row
]
,
1
,
J
)
,
$
00DD00
,
$
FF000000
)
;
{
§ «¨¢ª ®á⠢襣®áï ¯à®áâà á⢠¢ áâப¥
}
J
:
= J
*
FontWidth
;
kos_drawrect
(
J
,
Height
,
Rect
.
Width
-
J
+
1
,
FontHeight
,
$
000000
)
;
{
¯®¤£®â®¢ª ª ¢ë¢®¤ã á«¥¤ãî饩 áâப¨
}
Dec
(
Height
,
FontHeight
)
;
Dec
(
Row
)
;
if BottomRow
or
(
(
Row <
0
)
and
(
Length
(
FLines
)
< FMaxLines
)
)
then Break
;
while Row <
0
do
Inc
(
Row
,
FMaxLines
)
;
end
;
if FCursor
.
X <= Width then
{
®âà¨á®¢ª ªãàá®à
}
kos_drawrect
(
(
FCursor
.
X
-
1
)
*
FontWidth
,
Rect
.
Height
-
2
,
FontWidth
,
2
,
$
FFFFFF
)
;
if
not
BottomRow then
{
§ «¨¢ª ®á⠢襩áï ç á⨠®ª
}
kos_drawrect
(
0
,
0
,
Rect
.
Width
+
1
,
Height
+
FontHeight
,
$
000000
)
;
kos_enddraw
(
)
;
end
;
procedure TKonsole
.
Write
(
Message
:
ShortString
)
;
var
I
:
Integer
;
begin
{
XXX
:
¢®§¬®¦ á¨âã æ¨ï ¯à¨ ª®â®à®© á®®¡é¥¨¥ ¥ ¡ã¤¥â ®â¯à ¢«¥®
}
if FOpened then
begin
I
:
=
100
;
while
(
kos_sendmsg
(
FThreadID
,
@Message
[
1
]
,
Length
(
Message
)
)
=
2
)
and
(
I >
0
)
do
begin
Dec
(
I
)
;
ThreadSwitch
;
end
;
end
;
end
;
procedure TKonsole
.
Flush
(
)
;
begin
while FOnAir
do
ThreadSwitch
;
end
;