Subversion Repositories Kolibri OS

Rev

Rev 619 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed

  1. {}
  2.  
  3. procedure OpenStdout(var f: TextRec); forward;
  4. procedure WriteStdout(var f: TextRec); forward;
  5. procedure CloseStdout(var f: TextRec); forward;
  6.  
  7. procedure OpenStdin(var f: TextRec); forward;
  8. procedure ReadStdin(var f: TextRec); forward;
  9. procedure CloseStdin(var f: TextRec); forward;
  10.  
  11.  
  12.  
  13. procedure AssignStdout(var f: Text);
  14. begin
  15.   Assign(f, '');
  16.   TextRec(f).OpenFunc := @OpenStdout;
  17.   Rewrite(f);
  18. end;
  19.  
  20. procedure OpenStdout(var f: TextRec);
  21. begin
  22.   TextRec(f).InOutFunc := @WriteStdout;
  23.   TextRec(f).FlushFunc := @WriteStdout;
  24.   TextRec(f).CloseFunc := @CloseStdout;
  25. end;
  26.  
  27. procedure WriteStdout(var f: TextRec);
  28. var
  29.   msg: String;
  30. begin
  31.   msg := StrPas(PChar(f.bufptr));
  32.   SetLength(msg, f.bufpos);
  33.   f.bufpos := 0;
  34.   Konsole.Write(msg);
  35. end;
  36.  
  37. procedure CloseStdout(var f: TextRec);
  38. begin
  39. end;
  40.  
  41.  
  42.  
  43. procedure AssignStdin(var f: Text);
  44. begin
  45.   Assign(f, '');
  46.   TextRec(f).OpenFunc := @OpenStdin;
  47.   Reset(f);
  48. end;
  49.  
  50. procedure OpenStdin(var f: TextRec);
  51. begin
  52.   TextRec(f).InOutFunc := @ReadStdin;
  53.   TextRec(f).FlushFunc := nil;
  54.   TextRec(f).CloseFunc := @CloseStdin;
  55. end;
  56.  
  57. procedure ReadStdin(var f: TextRec);
  58. var
  59.   max, curpos: Longint;
  60.   c: Longint;
  61. begin
  62.   max := f.bufsize - Length(LineEnding);
  63.   curpos := 0;
  64.   repeat
  65.     c := 13{l4_getc()};
  66.     case c of
  67.       13:
  68.       begin
  69.         {f.bufptr^[curpos] := LineEnding;}
  70.         Inc(curpos);
  71.         f.bufpos := 0;
  72.         f.bufend := curpos;
  73.         {l4_putc(Longint(LineEnding));}
  74.         break;
  75.       end;
  76.       32..126: if curpos < max then
  77.       begin
  78.         f.bufptr^[curpos] := Char(c);
  79.         Inc(curpos);
  80.         {l4_putc(c);}
  81.       end;
  82.     end;
  83.   until False;
  84. end;
  85.  
  86. procedure CloseStdin(var f: TextRec);
  87. begin
  88. end;
  89.  
  90.  
  91. { TKonsole }
  92.  
  93. procedure KonsoleThreadMain(Console: PKonsole);
  94. {Рабочий цикл консоли}
  95. var
  96.   ThreadInfo: TKosThreadInfo;
  97.   Message: ShortString;
  98.   Event: DWord;
  99. begin
  100.   kos_maskevents(ME_PAINT or ME_KEYBOARD or ME_IPC);
  101.   kos_threadinfo(@ThreadInfo);
  102.   Console^.FThreadSlot := kos_getthreadslot(ThreadInfo.ThreadID);
  103.  
  104.   kos_initipc(Console^.FIPCBuffer, Console^.FIPCBufferSize);
  105.  
  106.   {сразу отобразить и активировать окно}
  107.   Console^.Paint();
  108.   {$ifndef EMULATOR}
  109.   kos_setactivewindow(Console^.FThreadSlot);
  110.   {$endif}
  111.  
  112.   {готов к обработке событий}
  113.   Console^.FOpened := True;
  114.   while not Console^.FTerminate do
  115.   begin
  116.     Event := kos_getevent();
  117.     if Console^.FTerminate then
  118.       {Console^.ProcessMessage('[CONSOLE] Terminate...'#13#10)} else
  119.     case Event of
  120.       SE_PAINT: Console^.Paint();
  121.       SE_KEYBOARD: Console^.ProcessKeyboard(kos_getkey());
  122.       SE_IPC: while Console^.ReceiveMessage(Message) do Console^.ProcessMessage(Message);
  123.     end;
  124.   end;
  125.   Console^.FOpened := False;
  126. end;
  127.  
  128. constructor TKonsole.Init(ACaption: String);
  129. const
  130.   IPC_SIZE = 4096;
  131. var
  132.   ThreadInfo: TKosThreadInfo;
  133. begin
  134.   if ACaption <> '' then
  135.     FCaption := ACaption else
  136.   begin
  137.     kos_threadinfo(@ThreadInfo);
  138.     FCaption := StrPas(ThreadInfo.AppName);
  139.   end;
  140.   SetLength(FLines, 1);
  141.   FLines[0] := ' ';
  142.   FCursor.X := 1;
  143.   FCursor.Y := 0;
  144.   FMaxLines := 150;
  145.   FTerminate := False;
  146.   FOpened := False;
  147.   FIPCBufferSize := SizeOf(TKosIPC) + IPC_SIZE;
  148.   FIPCBuffer := GetMem(FIPCBufferSize);
  149.   {FIPCBufferSize := SizeOf(KonsoleIPCBuffer);
  150.   FIPCBuffer := @KonsoleIPCBuffer;}
  151.   FIPCBuffer^.Lock := False;
  152.   FIPCBuffer^.Size := 0;
  153.   FThreadSlot := -1;
  154.   FThreadID := BeginThread(TThreadFunc(@KonsoleThreadMain), @Self);
  155.   if FThreadID <> 0 then
  156.     while not FOpened do kos_delay(1);
  157. end;
  158.  
  159. destructor TKonsole.Done();
  160. begin
  161.   FTerminate := True;
  162.   Self.Write(#0);
  163.   if FOpened then kos_delay(1);
  164.   if FOpened then kos_delay(10);
  165.   if FOpened then kos_delay(20);
  166.   if FOpened then
  167.   begin
  168.     FOpened := False;
  169.     KillThread(FThreadID);
  170.   end;
  171.   FreeMem(FIPCBuffer);
  172.   SetLength(FLines, 0);
  173. end;
  174.  
  175. function TKonsole.ReceiveMessage(var Message: ShortString): Boolean;
  176. {Извлечь первое сообщение из буфера}
  177. var
  178.   PMsg: PKosMessage;
  179.   Size: Longword;
  180. begin
  181.   if FIPCBuffer^.Size > 0 then
  182.   begin
  183.     FIPCBuffer^.Lock := True;
  184.     PMsg := Pointer(Longword(FIPCBuffer) + SizeOf(TKosIPC));
  185.     {TODO: проверка PMsg^.SenderID}
  186.     {Size := PMsg^.Size;
  187.     Dec(FIPCBuffer^.Size, Size + SizeOf(TKosMessage));
  188.     if Size > 255 then Size := 255;
  189.     SetLength(Message, Size);
  190.     Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage))^, Message[1], Size);
  191.     if FIPCBuffer^.Size > 0 then
  192.       Move(Pointer(Longword(PMsg) + SizeOf(TKosMessage) + PMsg^.Size)^, PMsg^, FIPCBuffer^.Size);}
  193.  
  194.     {XXX}
  195.     Size := FIPCBuffer^.Size;
  196.     Dec(FIPCBuffer^.Size, Size);
  197.     if Size > 255 then Size := 255;
  198.     SetLength(Message, Size);
  199.     Move(PMsg^, Message[1], Size);
  200.  
  201.     Result := True;
  202.   end else
  203.   begin
  204.     Message := '';
  205.     Result := False;
  206.   end;
  207.  
  208.   {FIXME: если FIPCBuffer^.Size = 0, то FIPCBuffer^.Lock все равно > 0}
  209.   FIPCBuffer^.Lock := False;
  210. end;
  211.  
  212. procedure TKonsole.ProcessMessage(Message: ShortString);
  213. {Вывести сообщение на консоль}
  214. var
  215.   S: String;
  216.   LinesCount: Word;
  217.   CR, LF, W: Word;
  218.   BottomRow: Boolean = True;
  219. begin
  220.   if Length(Message) < 1 then Exit;
  221.  
  222.   repeat
  223.     CR := Pos(#13, Message);
  224.     LF := Pos(#10, Message);
  225.     if (CR > 0) and ((CR < LF) or (LF <= 0)) then
  226.       W := CR else
  227.     if LF > 0 then
  228.       W := LF else
  229.       W := Length(Message) + 1;
  230.     if W > 0 then
  231.     begin
  232.       if W > 1 then
  233.       begin
  234.         S := Copy(Message, 1, W - 1);
  235.         Delete(FLines[FCursor.Y], FCursor.X, Length(FLines[FCursor.Y]) - FCursor.X);
  236.         Insert(S, FLines[FCursor.Y], FCursor.X);
  237.         Inc(FCursor.X, Length(S));
  238.       end;
  239.       Delete(Message, 1, W);
  240.       if W = CR then
  241.         {перевод коретки в начало строки}
  242.         FCursor.X := 1 else
  243.       if W = LF then
  244.       begin
  245.         {перевод коретки на следующую строку}
  246.         BottomRow := False;
  247.         Inc(FCursor.Y);
  248.         LinesCount := Length(FLines);
  249.         while FCursor.Y >= FMaxLines do Dec(FCursor.Y, FMaxLines);
  250.         if FCursor.Y < LinesCount then FLines[FCursor.Y] := '';
  251.         while FCursor.Y >= LinesCount do
  252.         begin
  253.           SetLength(FLines, LinesCount + 1);
  254.           FLines[LinesCount] := '';
  255.           Inc(LinesCount);
  256.         end;
  257.       end;
  258.     end;
  259.   until Length(Message) <= 0;
  260.  
  261.   Paint(BottomRow);
  262. end;
  263.  
  264. procedure TKonsole.ProcessKeyboard(Key: Word);
  265. begin
  266.   FKeyPressed := Key;
  267. end;
  268.  
  269. function TKonsole.GetRect(): TKosRect;
  270. var
  271.   ThreadInfo: TKosThreadInfo;
  272. begin
  273.   kos_threadinfo(@ThreadInfo, FThreadSlot);
  274.   Result := ThreadInfo.WindowRect;
  275. end;
  276.  
  277. function TKonsole.GetKeyPressed(): Word;
  278. begin
  279.   Result := FKeyPressed;
  280.   FKeyPressed := 0;
  281. end;
  282.  
  283. procedure TKonsole.Paint(BottomRow: Boolean);
  284. var
  285.   Buffer: array[Byte] of Char;
  286.   Rect: TKosRect;
  287.   J: Longint;
  288.   Width, Height, Row: Longint;
  289.   CaptionHeight, BorderWidth, FontWidth, FontHeight: Longint;
  290. begin
  291.   CaptionHeight := 16;
  292.   BorderWidth := 5;
  293.   FontWidth := 6;
  294.   FontHeight := 9;
  295.  
  296.   kos_begindraw();
  297.  
  298.   if not BottomRow then
  299.   begin
  300.     {отрисовка окна}
  301.     kos_definewindow(60, 60, 400, 400, $63000000);
  302.     {вывод заголовка}
  303.     Move(FCaption[1], Buffer, Length(FCaption));
  304.     Buffer[Length(FCaption)] := #0;
  305.     kos_setcaption(Buffer);
  306.   end;
  307.  
  308.   {подготовка к выводу строк}
  309.   Rect := GetRect();
  310.   Dec(Rect.Width, BorderWidth * 2);
  311.   Dec(Rect.Height, CaptionHeight + BorderWidth * 2);
  312.   Width  := Rect.Width div FontWidth;
  313.   Height := Rect.Height - FontHeight;
  314.   Row := FCursor.Y;
  315.  
  316.   while Height > 0 do
  317.   begin
  318.     {вывод одной строки}
  319.     J := Length(FLines[Row]);
  320.     if J > Width then J := Width;
  321.     kos_drawtext(0, Height, Copy(FLines[Row], 1, J), $00DD00, $FF000000);
  322.     {заливка оставшегося пространства в строке}
  323.     J := J * FontWidth;
  324.     kos_drawrect(J, Height, Rect.Width - J + 1, FontHeight, $000000);
  325.     {подготовка к выводу следующей строки}
  326.     Dec(Height, FontHeight);
  327.     Dec(Row);
  328.     if BottomRow or ((Row < 0) and (Length(FLines) < FMaxLines)) then Break;
  329.     while Row < 0 do Inc(Row, FMaxLines);
  330.   end;
  331.   if FCursor.X <= Width then
  332.     {отрисовка курсора}
  333.     kos_drawrect((FCursor.X - 1) * FontWidth, Rect.Height - 2, FontWidth, 2, $FFFFFF);
  334.   if not BottomRow then
  335.     {заливка оставшейся части окна}
  336.     kos_drawrect(0, 0, Rect.Width + 1, Height + FontHeight, $000000);
  337.  
  338.   kos_enddraw();
  339. end;
  340.  
  341. procedure TKonsole.Write(Message: ShortString);
  342. var
  343.   I: Integer;
  344. begin
  345.   {XXX: возможна ситуация при которой сообщение не будет отправлено}
  346.   if FOpened then
  347.   begin
  348.     I := 20;
  349.     while (kos_sendmsg(FThreadID, @Message[1], Length(Message)) = 2) and (I > 0) do
  350.     begin
  351.       Dec(I);
  352.       ThreadSwitch;
  353.     end;
  354.   end;
  355. end;
  356.