--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see .
with "texttools";
project Examples is
for Main use ("alert.adb", "basic2.adb", "basic.adb", "listinfo2.adb",
"listinfo.adb", "os_demo.adb", "scrollable.adb", "try_unix.adb",
"uio2_demo.adb", "uio_demo.adb");
for Source_Dirs use (".");
for Object_Dir use ".";
for Exec_Dir use ".";
for Languages use ("Ada");
package Compiler is
for Default_Switches ("Ada") use ("ADAFLAGS");
end Compiler;
package Linker is
for Default_Switches ("Ada") use ("LDFLAGS");
end Linker;
end Examples;
texttools/examples/basic.adb 0000664 0000764 0000764 00000001231 11774715706 014634 0 ustar ken ken with Common, OS, UserIO, Controls, Windows;
use Common, OS, UserIO, Controls, Windows;
procedure basic is
ch : character; -- key pressed
pragma Unreferenced (Ch);
begin
StartupCommon( "TIA", "tia" );
StartupOS;
StartupUserIO;
StartupControls;
StartupWindows;
OpenWindow( "Basic Window", 0, 0, 40, 20, normal, false );
DrawWindow;
MoveTo( 2, 2 );
Draw( "This is a basic TextTools window." );
MoveTo( 2, 3 );
Draw( "It contains no controls." );
MoveTo( 2, 18 );
Draw( "Press any key to quit." );
GetKey( ch );
CloseWindow;
ShutdownWindows;
ShutdownControls;
ShutdownUserIO;
ShutdownOS;
ShutdownCommon;
end basic;
texttools/examples/scrollable.adb 0000664 0000764 0000764 00000012775 11774715706 015714 0 ustar ken ken with Common, OS, UserIO, Controls, Windows;
use Common, OS, UserIO, Controls, Windows;
procedure scrollable is
procedure ScrollTest is
line : aliased aStaticLine;
ok : aliased aSimpleButton;
up : aliased aSimpleButton;
down : aliased aSimpleButton;
left : aliased aSimpleButton;
right : aliased aSimpleButton;
list : aliased aStaticList;
DT : aDialogTaskRecord;
DisplayInfo : ADisplayInfoRec;
begin
GetDisplayInfo( DisplayInfo );
OpenWindow( "Window Scrolling Test", 0, 0, DisplayInfo.H_Res-1, DisplayInfo.V_Res-1, normal, true );
Init( line, 22, 18, 40, 18 );
SetText( line, "Click OK to quit." );
AddControl( line'unchecked_access );
Init( ok, 2, 18, 10, 18, 'o' );
SetText( ok, "OK" );
AddControl( ok'unchecked_access );
Init( up, 12, DisplayInfo.V_Res-4, 20, DisplayInfo.V_Res-4, 'u' );
SetText( up, "Up" );
Scrollable( up, false );
AddControl( up'unchecked_access );
Init( down, 22, DisplayInfo.V_Res-4, 30, DisplayInfo.V_Res-4, 'o' );
SetText( down, "Down" );
Scrollable( down, false );
AddControl( down'unchecked_access );
Init( left, 32, DisplayInfo.V_Res-4, 40, DisplayInfo.V_Res-4, 'l' );
SetText( left, "Left" );
Scrollable( left, false );
AddControl( left'unchecked_access );
Init( right, 42, DisplayInfo.V_Res-4, 50, DisplayInfo.V_Res-4, 'r' );
SetText( right, "Right" );
Scrollable( right, false );
AddControl( right'unchecked_access );
Init( list, 2, 1, 30, 16 );
AddControl( list'unchecked_access );
loop
SetInfoText( "Offset:" & GetWindowXScroll( CurrentWindow )'img &
"," & GetWindowYScroll( CurrentWindow )'img );
DoDialog( DT );
case DT.control is
when 2 => exit;
when 3 => ScrollWindow( 0, -1 ); -- move the control's up 1 vertically
DrawWindow( whole ); -- erase and redraw whole window
when 4 => ScrollWindow( 0, +1 ); -- move the control's down 1 vertically
DrawWindow( whole ); -- erase and redraw whole window
when 5 => ScrollWindow( -2, 0 ); -- move the control's left 2
DrawWindow( whole ); -- erase and redraw whole window
when 6 => ScrollWindow( +2, 0 ); -- move the control's right 2
DrawWindow( whole ); -- erase and redraw whole window
when others => null;
end case;
end loop;
CloseWindow;
end ScrollTest;
procedure ScrollTest2 is
line : aliased aStaticLine;
ok : aliased aSimpleButton;
hbar : aliased aScrollBar;
vbar : aliased aScrollBar;
list : aliased aStaticList;
DT : aDialogTaskRecord;
DisplayInfo : ADisplayInfoRec;
VirtualWidth : constant integer := 20; -- amount of scrolling
VirtualHeight : constant integer := 20; -- amount of scrolling
NewScroll : integer;
begin
GetDisplayInfo( DisplayInfo );
OpenWindow( "Window Scrolling Using Scroll Bars Test", 0, 0, DisplayInfo.H_Res-1, DisplayInfo.V_Res-1, normal, true );
Init( line, 22, 18, 40, 18 );
SetText( line, "Click OK to quit." );
AddControl( line'unchecked_access );
Init( ok, 2, 18, 10, 18, 'o' );
SetText( ok, "OK" );
AddControl( ok'unchecked_access );
Init( hbar, 1, DisplayInfo.V_Res-4, DisplayInfo.H_Res-4, DisplayInfo.V_Res-4 );
SetThumb( hbar, VirtualWidth/2 );
SetMax( hbar, VirtualWidth );
Scrollable( hbar, false );
AddControl( hbar'unchecked_access );
Init( vbar, DisplayInfo.H_Res-3, 1, DisplayInfo.H_Res-3, DisplayInfo.V_Res-5, 'u' );
SetThumb( vbar, VirtualHeight/2 );
SetMax( vbar, VirtualHeight );
Scrollable( vbar, false );
AddControl( vbar'unchecked_access );
Init( list, 2, 1, 30, 16 );
AddControl( list'unchecked_access );
loop
SetInfoText( "Offset:" & GetWindowXScroll( CurrentWindow )'img &
"," & GetWindowYScroll( CurrentWindow )'img );
DoDialog( DT );
case DT.control is
when 2 => exit;
when 3 => -- move the control horizontally
-- erase and redraw whole window
NewScroll := GetThumb( hbar ) - VirtualWidth/2;
NewScroll := NewScroll - GetWindowXScroll( CurrentWindow );
ScrollWindow (NewScroll, 0 );
DrawWindow( whole );
when 4 => -- move the control vertically
-- erase and redraw whole window
NewScroll := GetThumb( vbar ) - VirtualHeight/2;
NewScroll := NewScroll - GetWindowYScroll( CurrentWindow );
ScrollWindow( 0, NewScroll);
DrawWindow( whole );
when others => null;
end case;
end loop;
CloseWindow;
end ScrollTest2;
line1 : aliased AStaticLine;
line2 : aliased AStaticLine;
ok : aliased ASimpleButton;
DT : aDialogTaskRecord;
begin
StartupCommon( "TIA", "tia" );
StartupOS;
StartupUserIO;
StartupControls;
StartupWindows;
OpenWindow( "Window Scrolling Test", 0, 0, 60, 20, normal, false );
Init( line1, 2, 2, 58, 2 );
SetText( line1, "This a demonstration of ScrollWindow." );
AddControl( line1'unchecked_access );
Init( line2, 2, 3, 58, 3 );
SetText( line2, "It scrolls a window's controls." );
AddControl( line2'unchecked_access );
Init( ok, 2, 18, 30, 18, 'o' );
SetText( ok, "OK" );
AddControl( ok'unchecked_access );
DoDialog( DT );
ScrollTest;
ScrollTest2;
CloseWindow;
ShutdownWindows;
ShutdownControls;
ShutdownUserIO;
ShutdownOS;
ShutdownCommon;
end scrollable;
texttools/examples/uio_demo.adb 0000664 0000764 0000764 00000005334 11774715706 015363 0 ustar ken ken -- with common, userio;
-- use common, userio;
-- with text_io;
-- use text_io;
procedure uio_demo is
-- ch : character;
-- ir1 : anInputRecord( InputType => KeyInput );
-- ir2 : anInputRecord( InputType => HeldKeyInput );
-- ir3 : anInputRecord( InputType => DirectionInput );
-- ir4 : anInputRecord( InputType => LocationInput );
-- ir5 : anInputRecord( InputType => ButtonDownInput );
-- ir6 : anInputRecord( InputType => ButtonUpInput );
-- ir7 : anInputRecord( InputType => MoveInput );
-- ir8 : anInputRecord( InputType => UserInput );
begin
null;
-- StartupCommon( "uio_demo", "User IO Demo" );
-- StartupUserIO;
-- Draw( "This is a string" );
-- GetKey( ch );
-- ShutdownUserIO;
-- ShutdownCommon;
-- put( "Input record is" );
-- put( integer'image(ir1'size/8) );
-- put_line( " bytes" );
-- put( "Input record is" );
-- put( integer'image(ir5'size/8) );
-- put_line( " bytes" );
-- put( "InputType is" );
-- put( integer'image(ir1.InputType'size/8) );
-- put_line( " bytes" );
-- put( "TimeStamp is" );
-- put( integer'image(ir1.TimeStamp'size/8) );
-- put_line( " bytes" );
-- put( "Key =" );
-- put( integer'image(ir1.key'size/8) );
-- put_line( " bytes" );
-- put( "HeldKey =" );
-- put( integer'image(ir2.heldkey'size/8) );
-- put_line( " bytes" );
-- put( "Direction =" );
-- put( integer'image(ir3.direction'size/8) );
-- put_line( " bytes" );
-- put( "Velocity =" );
-- put( integer'image(ir3.velocity'size/8) );
-- put_line( " bytes" );
-- put( "X =" );
-- put( integer'image(ir4.x'size/8) );
-- put_line( " bytes" );
-- put( "Y =" );
-- put( integer'image(ir4.y'size/8) );
-- put_line( " bytes" );
-- put( "DownButton =" );
-- put( integer'image(ir5.downButton'size/8) );
-- put_line( " bytes" );
-- put( "DownLocationX =" );
-- put( integer'image(ir5.downLocationX'size/8) );
-- put_line( " bytes" );
-- put( "DownLocationY =" );
-- put( integer'image(ir5.downLocationY'size/8) );
-- put_line( " bytes" );
-- put( "UpButton =" );
-- put( integer'image(ir6.upButton'size/8) );
-- put_line( " bytes" );
-- put( "UpLocationX =" );
-- put( integer'image(ir6.upLocationX'size/8) );
-- put_line( " bytes" );
-- put( "UpLocationY =" );
-- put( integer'image(ir6.upLocationY'size/8) );
-- put_line( " bytes" );
-- put( "MoveLocationX =" );
-- put( integer'image(ir7.moveLocationX'size/8) );
-- put_line( " bytes" );
-- put( "MoveLocationY =" );
-- put( integer'image(ir7.moveLocationY'size/8) );
-- put_line( " bytes" );
-- put( "ID =" );
-- put( integer'image(ir8.id'size/8) );
-- put_line( " bytes" );
end uio_demo;
texttools/examples/basic2.adb 0000664 0000764 0000764 00000001633 11774715706 014724 0 ustar ken ken with Common, OS, UserIO, Controls, Windows;
use Common, OS, UserIO, Controls, Windows;
procedure basic2 is
line1 : aliased AStaticLine;
line2 : aliased AStaticLine;
ok : aliased ASimpleButton;
DT : aDialogTaskRecord;
begin
StartupCommon( "TIA", "tia" );
StartupOS;
StartupUserIO;
StartupControls;
StartupWindows;
OpenWindow( "Basic Window 2", 0, 0, 40, 20, normal, false );
DrawWindow;
Init( line1, 2, 2, 38, 2 );
SetText( line1, "This is a basic TextTools window." );
AddControl( line1'unchecked_access );
Init( line2, 2, 3, 38, 3 );
SetText( line2, "It contains controls." );
AddControl( line2'unchecked_access );
Init( ok, 2, 18, 30, 18, 'o' );
SetText( ok, "OK" );
AddControl( ok'unchecked_access );
DoDialog( DT );
pragma Unreferenced (DT);
CloseWindow;
ShutdownWindows;
ShutdownControls;
ShutdownUserIO;
ShutdownOS;
ShutdownCommon;
end basic2;
texttools/examples/listinfo.adb 0000664 0000764 0000764 00000002136 11774715706 015407 0 ustar ken ken with Common, OS, UserIO, Controls, Windows;
use Common, OS, UserIO, Controls, Windows;
procedure listinfo is
line1 : aliased AStaticLine;
line2 : aliased AStaticLine;
ok : aliased ASimpleButton;
DT : aDialogTaskRecord;
list : Strlist.Vector;
begin
StartupCommon( "TIA", "tia" );
StartupOS;
StartupUserIO;
StartupControls;
StartupWindows;
OpenWindow( "ShowListInfo Demo", 0, 0, 60, 20, normal, false );
DrawWindow;
Init( line1, 2, 2, 58, 2 );
SetText( line1, "This a demonstration of ShowListInfo." );
AddControl( line1'unchecked_access );
Init( line2, 2, 3, 58, 3 );
SetText( line2, "It displays a list that the user can view." );
AddControl( line2'unchecked_access );
Init( ok, 2, 18, 30, 18, 'o' );
SetText( ok, "OK" );
AddControl( ok'unchecked_access );
DoDialog( DT );
pragma Unreferenced (DT);
LoadList( "listinfo.adb", list );
ShowListInfo( "Source code for this program", 0, 1, 79, 24, list );
pragma Unreferenced (List);
CloseWindow;
ShutdownWindows;
ShutdownControls;
ShutdownUserIO;
ShutdownOS;
ShutdownCommon;
end listinfo;
texttools/examples/alert.adb 0000664 0000764 0000764 00000002552 11774715706 014671 0 ustar ken ken with Common, OS, UserIO, Controls, Windows;
use Common, OS, UserIO, Controls, Windows;
procedure alert is
line1 : aliased AStaticLine;
line2 : aliased AStaticLine;
ok : aliased ASimpleButton;
DT : aDialogTaskRecord;
b : boolean;
pragma Unreferenced (B);
id : AControlNumber;
pragma Unreferenced (Id);
begin
StartupCommon( "TIA", "tia" );
StartupOS;
StartupUserIO;
StartupControls;
StartupWindows;
OpenWindow( "Alert Demo", 0, 0, 40, 20, normal, false );
DrawWindow;
Init( line1, 2, 2, 38, 2 );
SetText( line1, "This a demonstration of alerts." );
AddControl( line1'unchecked_access );
Init( line2, 2, 3, 38, 3 );
SetText( line2, "There are 7 types of alert windows." );
AddControl( line2'unchecked_access );
Init( ok, 2, 18, 30, 18, 'o' );
SetText( ok, "OK" );
AddControl( ok'unchecked_access );
DoDialog( DT );
pragma Unreferenced (DT);
CloseWindow;
NoteAlert( "This is a note alert" );
CautionAlert( "This is a caution alert" );
StopAlert( "This is a stop alert" );
b := YesAlert( "This is a yes alert", warning );
b := YesAlert( "This is a no alert", warning );
b := CancelAlert( "This is a cancel alert", "Do it", warning );
id := YesCancelAlert( "This is a yes/cancel alert", warning );
ShutdownWindows;
ShutdownControls;
ShutdownUserIO;
ShutdownOS;
ShutdownCommon;
end alert;
texttools/examples/uio2_demo.adb 0000664 0000764 0000764 00000001062 11774715706 015437 0 ustar ken ken with common, userio;
use common, userio;
procedure uio2_demo is
ch : character;
pragma Unreferenced (Ch);
r : aRect;
begin
StartupCommon( "uio2_demo", "User IO Demo 2" );
StartupUserIO;
SetPenColour( white );
Draw( "There should be a brief pause before the rectangle appears" );
WaitToReveal;
SetRect( r, 10, 10, 20 , 20 );
MoveToGlobal( 0, 9 );
Draw( "FrameRect" );
FrameRect( r );
WaitFor( 200 );
Reveal;
MoveToGlobal( 0, 23 );
Draw( "Press a key" );
GetKey( ch );
ShutdownUserIO;
ShutdownCommon;
end uio2_demo;
texttools/examples/try_unix.adb 0000664 0000764 0000764 00000000242 11774715706 015435 0 ustar ken ken with Os;
procedure Try_Unix is
-- CGetUNIX
S1 : constant String := Os.UNIX ("echo hello");
pragma Assert (S1 = "hello");
begin
null;
end Try_Unix;
texttools/doc/ 0000775 0000764 0000764 00000000000 11774715706 012035 5 ustar ken ken texttools/doc/usermanual.html 0000664 0000764 0000764 00000047114 11774715706 015106 0 ustar ken ken
TextTools User Manual
TextTools 2.0
Copyright (c) 1999-2003 PegaSoft Canada.
Designed and Programmed by Ken O. Burtch
Home Page: http://www.pegasoft.ca/tt.html
The Texttools packages are a GPL, ncurses-based library for the Linux
console. Texttools contain more than 600 procedures and functions to
create windows, draw scroll bars, handle the mouse and keyboard events,
play sounds, and much more. The Texttools package also provides a
thick binding to Linux kernel calls. You can create a wide
variety of application programs using Texttools alone.
TextTools is written in Ada 95 and C. You'll need to download the
Gnat compiler to use TextTools.
RECENT CHANGES
The change logs are now online at the PegaSoft Linux Cafe
http://www.pegasoft.ca/docs/discus/index.html.
Partial C++ support added.
If you're looking to contribute to the Texttools project, here are
some outstanding jobs that need to be done:
- A GUI Window Editor should be written. Texttools is designed to
load windows saved as a file.
- The Window Manager should be rewritten to use tagged record features
when working with controls. The enumerated control type should be
discarded so users can create their own controls using child packages.
- Regions and clipping need to be implemented to allow writing to
windows other than the top window.
- Support for AU sounds should be added.
- Support for modification keys (control, alt, etc) on mouse clicks
should be added.
- Resizing by SIGWINCH isn't finished, primarily because of the
tasking problems in the ALT version of Gnat.
- Multiline text pasting sometimes crashes on small files (or is
it because of pasting at the end of the text?) in EditList's.
INSTALLATION
- Install the GNAT compiler (or in GCC 3.1 or newer, make sure
Ada is enabled).
- Edit C_code/curses.c If you are using NCURSES3, uncomment the NCURSES3
define. If using NCURSES4, comment out the NCURSES5 define.
- Type "make" in the topmost Texttools directory.
- Test the examples by running them. (Note: Red Hat's console is not
fully VT-102 compatible. Use xterm instead.)
The cpp directory contains C++ examples.
The examples directory contains Ada examples.
USING TEXTTOOLS IN YOUR OWN PROJECTS
- If TextTools are installed in a different
directory than your project, you will need to use the
gnatmake -I switch.
- When linking, you'll need to include the "-lm" and
"-lcurses" switches. TextTools uses the C math library
and ncurses 3.x, 4.x or 5.x.
INTRODUCTION
Although there are over 600 procedures and functions in TextTools,
to open window is fairly uncomplicated. Detailed explanations of
all TextTools procedures and functions are located in texttools.txt.
Everything in TextTools is drawn in a window. Everything in a
window is a control (sometimes called a "widget"). To display
a window, you must create a window, fill in the window with
controls to display, and run the window manager's DoDialog
command.
The following program opens a simple window.
with common, os, userio, controls, windows;
use common, os, userio, controls, windows;
procedure demo is
-- Define Window Controls
OKButton : aliased ASimpleButton;
MessageLine : aliased AStaticLine;
-- The Dialog Record
DT : ADialogTaskRecord;
begin
-- Start TextTools
StartupCommon( "demo", "demo" );
StartupOS;
StartupUserIO;
StartupControls;
StartupWindows;
-- Create a new window. The window will not appear until the
-- DoDialog procedure is used.
OpenWindow( To255( "Demo Window" ), -- title at top of window
0, 0, 78, 23, -- the coordinates of the window
Style => normal, -- type of window, usually "normal"
HasInfoBar => true ); -- true if control information is
-- displayed at the bottom of the
-- window
-- Setup the controls in the window
-- OK Button located near bottom of window
Init( OKButton,
36, 20, 44, 20, -- coordinates in window
'o' ); -- hot key for OK button
SetText( OKButton, "OK" ); -- button will have "OK"
SetInfo( OKButton, To255( "Select me to quit" ) );
AddControl( SimpleButton, OKButton'unchecked_access, IsGlobal => false );
-- Message at top of window in bright red
Init( MessageLine,
1, 1, 78, 1 );
SetText( MessageLine, "Welcome to TextTools" );
SetStyle( MessageLine, Bold );
SetColour( MessageLine, Red );
AddControl( SimpleButton, MessageLine'unchecked_access, IsGlobal => false );
-- Display the window and handle any input events. When dialog
-- is finished, return control which completed the dialog.
loop
DoDialog( DT );
exit when DT.Control = 1; -- first control is the OK button
end loop;
-- close the window
CloseWindow;
-- Shutdown TextTools
ShutdownWindows;
ShutdownControls;
ShutdownUserIO;
ShutdownOS;
ShutdownCommon;
end demo;
PACKAGE OVERVIEW
TextTools is broken into 5 main packages, based on what they do.
- Common - this package contains all the basic data types used by
TextTools, plus subprograms that work with those types.
In particular, two important types are defined:
- Str255 - most TextTools subprograms use this bounded,
255 character string type instead of the standard Ada
fixed strings. The function To255 converts an Ada
string to a Str255. ToString converts in the other
direction.
- Str255List - some list controls display a block of
text. These controls use the Str255List.List type, a
linked list of Str255 strings. The subprograms
for this type are defined the generic package gen_list.
- Most TextTools calls do not return errors. There are
some exceptions, such in the OS package. Error numbers
are returned in the LastError variable. LastError is
0 if there is no error.
-
OS - this package contains subprograms for working with the Linux
operating system: that is, for reading the current
time, deleting files, and the like.
Texttools pathnames are defined in this package. A
path is a Str255 string. The OS package can define
path prefixes, beginning with a "$". For example,
"$HOME" is predefined as the user's home directory.
To delete a file called "temp.txt" from the user's
home directory, you can use the OS erase command:
Erase( To255( "$HOME/temp.txt" ) );
$SYS is another predefined prefix. This refers to
a directory in the user's home directory named with
the "short name" you specify in the StartupCommon
procedure. Sounds, keyboard macros and the
session_log file are located here.
-
UserIO - this package contains all the input/output routines
for TextTools: it handles mouse clicks, draws text,
and so forth. Normally, only people writing controls
will need access to this package. However, the pen
colours, beep sounds and text styles, are also defined
here.
-
Controls - this package contains all the window controls and
related subprograms. Currently defined controls are:
Thermometer
ScrollBar
StaticLine
EditLine (and family)
CheckBox
RadioButton
WindowButton
Rectangle
Line
HorizontalSep
VerticalSep
StaticList
CheckList
RadioList
EditList
SourceCodeList (used by PegaSoft's TIA)
-
Windows - this is the window manager. It creates and draws windows,
and DoDialog procedure lets a user interact with the window.
It also handles the "Accessories" window that appears when
ESC is pressed.
Each package is started with a "Startup" procedure, and shutdown with
a "Shutdown" procedure. The only procedure to take parameters is
StartupCommon: you need to specify a program name and a short name to
use for temporary files.
WINDOW OVERVIEW
The Window Manager draws all the windows on the screen. For simple
programs, you will need to use only four Window Manager procedures.
OpenWindow - this procedure creates a new window. Each window has
a title, coordinates on the screen, a "style", and an optional
info bar.
AddControl - adds a control to the current window. If IsGlobal is
false, the coordinates you specified in the control's Init
call will be treated as relative to the top-left corner of the
window, as opposed to the top left corner of the screen.
CloseWindow - closes the last window you created
DoDialog - this procedure displays the window and handles all
interaction between the user and the window. It has one
parameter, ADialogTaskRecord, which lets you set up callbacks
(if necessary) and returns the number of the control which
terminated the dialog.
Other Useful Window Manager Subprograms
Windows can be saved using the SaveWindow command, and loaded again
using LoadWindow. When a window is loaded with LoadWindow, you
don't need to open the window or set up the controls--the Window
Manager does this automatically for you.
ShellOut will close the windows, run a shell command, and reopen
the windows.
RefreshDesktop will redraw all the windows on the screen.
SetWindowTimeout will set a default control to be selected if there
is no response after a certain amount of time.
Alerts
Alerts are small windows that show a short message.
NoteAlert - displays a message with an "OK" button. The status sound
is played, if installed.
CautionAlert - displays a message with an "OK" button. The text is drawn
to emphasize the message. The warning sound is played, if installed.
StopAlert - displays a message with an "OK" button. The text is drawn
to emphasize the message. The warning sound is played, if installed.
YesAlert - display a message with "yes" (default) and "no" buttons.
Plays an optional sound.
NoAlert - display a message with "yes" and "no" (default) buttons.
Plays an optional sound.
CancelAlert - display a message with cancel button and a customized
button (default). Plays an optional sound.
YesCancelAlert - display a message with "yes", "no", and "cancel"
buttons and returns the number of the button selected. Plays an
optional sound.
Example:
NoteAlert( "The database has been updated" );
Other Predefined Windows
SelectOpenFile - displays a dialog for opening files. It has
one parameter, ASelectOpenFileRec. You have to fill in certain
details before displaying this window.
SelectSaveFile - displays a dialog for saving files. It has
one parameter, ASelectSaveFileRec. You have to fill in certain
details before displaying this window.
ShowListInfo - displays a Str255List list in a window
EditListInfo - displays a Str255List list in a window and let's
the user edit the list.
Example:
sof : ASelectOpenFileRec;
...
sof.prompt := To255( "Select a file to open" );
sof.direct := false; -- can't select directories
SelectOpenFile( sof );
if sof.replied then
FilePath := sof.path & "/" & sof.fname;
else
-- user cancelled
end if;
CONTROL OVERVIEW
Every control must be initialized with the Init procedure. Init
positions the control in the window and assigns a "hot key", a
short cut key for moving to the control.
You can turn a control off (make it unselectable) using SetStatus.
Setting the control's status to Standby will make it selectable.
Some controls are automatically turned off, such as the static
line control.
The following controls can be used in a TextTools window:
Thermometer - This is a thermometer bar graph. It shows the percentage between
the maximum value and the current value, and is filled based on the
percentage.
ScrollBar - This is a scroll bar. A thumb is drawn at the relative location
of the thumb value to the maximum value of the bar. The bar will
be horizontal or vertical depending on the shape specified in the
Init procedure.
StaticLine - This is an unchanging line of text.
EditLine (and family) - This is an editable line of text.
- AdvanceMode - if set, the cursor will move to the next control
when the edit field is full. This is useful in business
applications where fixed-length product numbers are typed in.
- BlindMode - if set, hides the characters typed. This is
useful for typing in passwords.
SimpleButton - This is a button that, when selected, terminates the dialog.
- Instant - if set, the button acts like a menu item. Pressing
the hot key will immediately select the button and terminate
the dialog. Otherwise, pressing the hot key only moves the
cursor to the button.
CheckBox - A check box is an option which may be turned on or off.
RadioButton - A radio button is one of a set of options which may be turned
on or off. Every radio button has a family number defined in
the Init procedure. When a radio button is turned on, all
other buttons in the family are turned off.
WindowButton - Loads a window from disk and displays it. The window must
have been saved with the Window Manager's SaveWindow procedure.
Rectangle - A box which can be drawn around controls.
Line - A line--what else would it be--drawn between two corners of the
enclosing rectangle defined by the Init procedure.
HorizontalSep - A horizontal line, often used to separate controls into groups.
VerticalSep - A vertical line, often used to separate controls into groups.
StaticList - A scrollable box of unchanging text.
CheckList - A scrollable box of check boxes.
RadioList - A scrollable box of radio buttons.
EditList - A scrollable box of editable text.
SourceCodeList (used by PegaSoft's TIA) - A scrollable box containing source code.
OS Package
This package contains various calls for working with the operating
system. All calls support path prefixes as described above. Here
are some of the subprograms:
UNIX - run a UNIX shell command. The function variations return
the result of the command.
RunIt - runs a UNIX program.
ValidateFilename - check for a syntactically correct filename.
NotEmpty - true if a file is not empty
IsDirectory - true if file is a directory
IsFile - true if file is a "regular" file
MakeTempFileName - creates a random file name for a temporary file
Erase - deletes a file
LoadList - load a Str255List list from a file
SaveList - save a Str255List list to a file
MyID - return the PID for your program
SessionLog - write to the session log. If a $SYS directory exists,
SessionLog creates a file called "session_log" in that directory.
All SessionLog calls write to this file.
UserIO Overview
The UserIO package handles all the input and output for TextTools.
Unless you are writing a game or new controls, you'll probably
won't need to use UserIO at all. However, there are a few useful
subprograms to be aware of:
Beep - play a .wav file. Requires Warren Gay's wavplay program.
These files must be saved in the $SYS directory, with the name
of the beep sound in upper case.
Keypress - get a keypress
DrawErr - draw an error message. DrawErr draws the text on the left-side
screen in white. Use only for emergencies.
GetDisplayInfo - retrieve information about the current screen, such
as whether it supports colour, and it's dimensions. Use this
information to resize your windows for different screens.
Example:
Beep( Startup ); -- play startup sound
Keyboard Macros
UserIO will load a set of keyboard macros at startup. These must
be saved in the $SYS directory, in a file called macro_file. The
first letter of each line is the key for the macro, and the rest
of the line is the expanded macro. For example, if a line in
macro_file contained
pPegaSoft
then typing control-A followed by "p" would put the word "PegaSoft"
in the input queue as if the person had typed "PegaSoft".
Appearance and Keys
Most of the objects on the screen should be easily understood, the
majority designed after their GUI counterparts. Here is a list:
- < > Text - A button. Press Return to activate. Type the hilighted
letter to go immediately to this button.
- | > Text - An menu button. Enter Return to activate. Type the
hilighted letter to immediately activate.
- ( ) Text - A radio button. Press Return to select this item and
deselect the previous item in the group.
- [ ] Text - A check box. Press Return to switch on or off.
- -----#------- - A scroll bar.
- -----50%----- - A thermometer graph.
Buttons with hyphens in them are not selectable.
Basic Keyboard Shortcuts:
Movement Keys
-
Up/Down Arrow - move up or down to the next menu item
- in lists - move up or down one line in the list
- in scroll bars - adjust up or down by 10%
-
Left/Right Arrows - move left or right to the next menu item
- in lists - move up or down one line in the list
- in scroll bars - adjust up or down by 1
-
Page Up (or Control-P) - move up one page in a list
- in scroll bars - same as up and down arrows
-
Page Down (or Control-N) - move down one page in a list
- in scroll bars - same as up and down arrows
-
Home Key (or Control-Y) - move to the top of a list
- in scroll bars - go to the top
-
End Key (or Control-E) - move to the bottom of a list
- in scroll bars - go to the bottom
-
Tab Key - move to the next item in the window
-
Control-T - move to the previous item in the window
-
Return Key (or Spacebar) - activate a button
When inside of a list box, the movement keys move you around the list.
If you are on the Linux console, pressing alt and the hilighted letter
will always jump to the appropriate object, even if you're inside a
list box or the notepad.
Editing Keys
-
Control-6 - mark text
* only works in edit lists
-
Control-X - clear text
* in lists, clear the current line (or lines, if control-6 used)
-
Control-B - copy text
* in lists, copy the current line (or lines, if control-6 used)
-
Control-V - paste text
* in notepad, paste the last line copied
Misc. Keys
- ESC Key (or F1) - bring up the accessories menu
- Control-L - redraw the screen
- Control-A (or F2) - execute a keyboard macro
For more detailed information, consult the TextTools reference manual.
End of Document
texttools/doc/refmanual.html 0000664 0000764 0000764 00000264171 11774715706 014710 0 ustar ken ken
TextTools Reference Manual
TextTools 2.0
Copyright (c) 1999-2003 PegaSoft Canada.
Designed and Programmed by Ken O. Burtch
Home Page: http://www.pegasoft.ca/tt.html
The Texttools packages are a GPL, ncurses-based library for the Linux
console. Texttools contain more than 600 procedures and functions to
create windows, draw scroll bars, handle the mouse and keyboard events,
play sounds, and much more. The Texttools package also provides a
thick binding to Linux kernel calls. You can create a wide
variety of application programs using Texttools alone.
TextTools is written in Ada 95 and C. You'll need to download the
Gnat compiler to build TextTools. You can write programs in Ada or C++
when you use TextTools.
Note: C++ support is not fully implemented in this version of TextTools
The Common Package
Housekeeping
StartupCommon (startup_common)
Initialize the common package. The names are strings with a maximum of
255 characters.
Ada: StartupCommon( long_name, short_name );
C++: startup_common( long_name, short_name );
IdleCommon (idle_commom)
Perform idle-time tasks (if any).
ShutdownCommon (shutdown_common)
Shut down the common package.
Global variables
IsFinder (is_finder)
Reserved for future use. False if this is a Texttools server. Currently
always true.
ProgramName (Ada only)
The program name specified in StartupCommon.
ShortProgramName (Ada only)
The short program name specified in StartupCommon.
Error Codes
There is a global LastError (or last_error in C++) variable which is
set to a non-zero value if an error occurred during the last TextTools
function. These error codes are the same no matter what operating
system you are using.
The exception is the common package functions. These are considered
so primitive that they never return an error.
If you have a directory in your home directory with the same name as
the "short name" in StartupCommon, errors will be saved in a file
called "session_log".
General Errors
| Ada Name | C++ Name | Explaination |
| TT_NotYetImplemented | TT_not_yet_implemented | routine doesn't exist |
| TT_OK | TT_ok | success (value of 0) |
| TT_MemoryLeak | TT_memory_leak | memory leak detected |
| TT_LowMemory | TT_low_memory | low / out of memory |
| TT_TestData | TT_test_data | test data in operation |
Operating System Errors
| Ada Name | C++ Name | Explaination |
| TT_SystemError | TT_system_error | O/S command failed |
| TT_ParamError | TT_param_error | param too long |
| TT_FileExistance | TT_file_existance | file found/not found |
| TT_PathExistance | TT_path_existance | path found/not found |
| TT_VolExistance | TT_vol_existance | disk volume found/not found |
| TT_DevExistance | TT_dev_existance | device found/not found |
| TT_FileStatus | TT_file_status | file open/not open |
| TT_FileLocking | TT_file_locking | file locked/unlocked |
| TT_FileAccess | TT_file_access | file is un/accessible |
| TT_VolLocking | TT_vol_locking | disk volume is (not) readonly |
| TT_VolAccess | TT_vol_access | disk volume is un/accessible |
| TT_VolFull | TT_vol_full | disk volume is full |
| TT_DevSequential | TT_dev_sequential | tape device (un)expected |
| TT_IOError | TT_io_error | hardware or media error |
| TT_PathError | TT_path_error | bad path or file sys |
| TT_FileBounds | TT_file_bounds | file position out of bounds |
| TT_OSOld | TT_os_old | O/S too old to support |
| TT_OSService | TT_os_service | O/S service missing |
| TT_Integrity | TT_integrity | O/S integrity is bad |
Window Errors
| Ada Name | C++ Name | Explaination |
| TT_WindowExistance | TT_window_existance | window found/not found |
| TT_NoControls | TT_no_controls | no controls in the window |
| TT_ControlExistance | TT_control_existance | control found/not found |
| TT_NoDialogTaskCB | TT_no_dialog_task_cb | no manual handler installed |
Using the Error Functions
You can use error handling functions in the common package for your
own applications.
NoError (no_error)
Clear the error variable. Usually, this is the first call in any
TextTools function.
Ada: NoError;
C++: no_error(); [ Doesn't work ]
Error (error)
Report an error with one of the TextTools error codes.
Ada: Error( TT_SomeErrorCode );
C++: error( TT_some_error_code ); [ Doesn't work ]
RaisingErrors (Ada only)
Raise a GeneralError exception when an error is reported using Error.
Ada: RaisingErrors;
TrapErrors (Ada only)
Don't raise a GeneralError exception when an error is reported using
Error.
Ada: TrapErrors;
RaiseErrors (Ada only)
Return true if an error will raise an GeneralError exception.
Ada: bool := RaiseErrors;
TrapErrors (Ada only)
Return true if an error will not raise an GeneralError exception.
Ada: bool := TrapErrors;
RestoreRaising (Ada only)
Restore the old value of RaisingErrors/TrapErrors.
Ada: RestoreRaising ( RaiseErrorsValue );
Standard String Functions
These are an Ada-only feature. The common package contains an
instantiated version of 255 character bounded strings. There are also
ToInteger and ToLongInteger functions defined.
String Lists
Some TextTools functions use a list of strings. Strings are declared in
the common/str255list package. (In C++, the str255list functions are included
in common.h.) List of strings are used for window controls containing
multiple lines of text, including editable text boxes and lists of check
boxes.
The generic package (template) on which the strings list is based is in the
file gen_list.adb.
If you're using C++, make sure you assign string list variables a null value
before using them.
str255list_list sl = str255list_null;
Memory Leak Detection
The string lists have simple memory leak detection functions. GetAllocation
will report the amount of memory allocated by all string lists. The memory
leak function will check to see if the amount of memory has changed.
For example, use GetAllocation when your program starts and there are no lists.
Use MemoryLeak when your program completes execution and all string lists
should be cleared and empty. If there are any string lists that contain
items, MemoryLeak will be true.
GetAllocation (str255list_get_allocation)
Return the amount of memory allocated in the list.
Ada: Str255List.GetAllocation( bytes );
C++: str255list_get_allocation( &bytes );
Errors: none
MemoryLeak (str255list_memory_leak)
True if there is a the difference in memory compared to the amount returned
by GetAllocation.
Ada: b := Str255List.MemoryLeak( bytes );
C++: b = str255list_memory_leak( bytes );
Errors: none
List Operations
Here are some list operations that affect on or more entire lists, including
clearing, copying and swapping lists.
Compact (str255list_compact)
Deallocate all non-essential memory (for example, by discarding cache items).
This potentially reduces performance but also reduces memory use.
Ada: Str255List.Compact( list );
C++: str255list_compact( &list );
Errors: none
Clear (str255list_clear)
Discard an entire list.
Ada: Str255List.Clear( list );
C++: str255list_clear( &list );
Errors: none
Copy (str255list_copy/copy2)
Create one or two duplicate copies of a list.
Ada: Str255List.Copy( FromList, ToList ); or
Str255List.Copy( FromList, ToList1, ToList2 );
C++: str255list_copy( &FromList, &ToList ); or
str255list_copy2( &FromList, &ToList1, &ToList2 );
Errors: Ada STORAGE_ERROR exception if out of memory
Move (str255list_move)
Copy one list to another.
Ada: Str255List.Move( FromList, ToList );
C++: str255list_move( &FromList, &ToList );
Errors: Ada STORAGE_ERROR exception if out of memory
Swap (str255list_swap)
Swap one list for another.
Ada: Str255List.Swap( List1, List2 );
C++: str255list_swap( &List1, &List2 );
Errors: none
Is_Empty (str255list_is_empty)
True if the list is empty (has no items).
Ada: b := Str255List.IsEmpty( TheList );
C++: b = str255list_is_empty( &TheList );
Errors: none
Length (str255list_length)
Returns the number of items in the list.
Ada: n := Str255List.Length( TheList );
C++: n = str255list_length( &TheList );
Errors: none
Concat (str255list_concat)
Append one list to another returning the new list.
Ada: Str255List.Concat( List1, List2, NewList );
C++: str255list_concat( &list1, &list2, &new_list);
Errors: Ada STORAGE_ERROR exception if out of memory
Working with String List Items
This section lists the string list functions for adding or removing
individual items from a string list.
Push (str255list_push)
Add an item to the top of the list as if the list was a stack.
Ada: Str255List.Push( TheList, str255 );
C++: str255list_push( &TheList, str255 );
Errors: Ada STORAGE_ERROR exception if out of memory
Queue (str255list_queue)
Add an item to the bottom of the list as if the list was a queue.
Ada: Str255List.Queue( TheList, str255 );
C++: str255list_queue( &TheList, str255 );
Errors: Ada STORAGE_ERROR exception if out of memory
Insert (str255list_insert/2)
Add an item sorted alphabetically to the list, or at a specific position.
Ada: Str255List.Insert( TheList, str255 ); or
Str255List.Insert( TheList, index, str255 );
C++: str255list_insert( &TheList, str255 ); or
str255list_insert2( &TheList, index, str255 );
Errors: Ada STORAGE_ERROR exception if out of memory
Pull (str255list_pull/discard)
Remove a item from the top of the list and return it (if desired).
Ada: Str255List.Pull; or
Str255List.Pull( TheList, str255 );
C++: str255list_discard(); or
str255list_pull( &TheList, &str255 );
Errors: none
Cut (str255list_cut)
Remove an item from an index in the list and return it.
Ada: Str255List.Cut( TheList, index, str255 );
C++: str255list_cut( &TheList, index, &str255 );
Errors: none
Clear (str255list_clear_item)
Remove an item from a particular list position without returning it.
Ada: Str255List.Clear( TheList, Index );
C++: str255list_clear_item( &TheList, index );
Errors: none
Search and Replace Operations
Find (str255list_find/lookup)
Locate an item in the list and return the position (or look up a position
and return the item). The Ada version of position lookup has a default
starting index of 1. If the item is not found, the position will be zero.
Ada: Str255List.Find( TheList, Index, Item ); or
Str255List.Find( TheList, Item, StartIndex, Index );
C++: str255list_find( &TheList, Index, &Item ); or
str255list_lookup( &TheList, startindex, &item, &index );
Errors: none
Replace (str255list_replace)
Replace one item with a new item.
Ada: Str255List.Replace( TheList, index, item );
C++: str255list_replace( &TheList, index, &item );
Errors: none
Sublists are new lists created by removing a set of items from another list. There are two subprograms for creating and working with sublists.
Sublist (str255list_sublist)
Copy a set of items and create a new list. The items are not removed from
the original list.
Ada: Str255List.Sublist( TheList, startindex, len, Sublist );
C++: str255list_sublist( &TheList, startindex, len, &Sublist );
Errors: Ada STORAGE_ERROR exception if out of memory
Standard Math Functions
These are mostly obsolete.
RND (CRnd)
Generate a uniformally distributed random number between 1 and a limit.
Ada: num := RND( limit );
C++: num = Crnd( limit );
NormalRND (Cnormalrnd)
Generate a normal (Gaussian) distributed random number between 1 and a limit.
Ada: num := NormalRND( limit );
C++: num = Cnormalrnd( limit );
Odds (Coods)
Randomly true based on the indicated percent.
Ada: bool := Odds( percent );
C++: bool = odds( percent );
SetRNDSeed (Csetrndseed)
Set a random number seed.
Ada: SetRNDSeed( seed );
C++: Csetrndseed( seed );
Working with Rectangles
Texttools uses many rectangles. Windows are rectangular. OK buttons are
surrounded by invisible bounding rectangles.
A recntangle is described by the coordinates of its sides: the left side,
the top side, the right side and the bottom side. The upper-left corner
of a rectangle is (left, top) and the bottom-right corner is (right, bottom).
For example, a rectangle drawn from (5, 10) to (15, 20) has a left side
at 5, a top side at 10, a right side at 15 and a bottom side at 20.
Rectangles have their own record structure.
In C++, a rectangle is
struct a_rect {
int left;
int top;
int right;
int bottom;
}
In Ada, a rectangle is
type aRect is record
left, top, right, bottom : integer;
end record;
There is one predefined rectangle, nullRect (or null_rect) that
represents an empty rectangle (the sides are 0, 0, -1 and -1).
There is not data structure for a single point. A 2-D point is
represented by a pair of integers in a function's parameters.
Because rectangles are used so often when drawing to the screen,
TextTools has a set of rectangle subprograms to create, change and
test rectangles.
SetRect (set_rect)
Create a new rectangle from the coordinates of the sides.
Ada: SetRect( r, 1, 10, 15, 20 );
C++: set_rect( &r, 1, 10, 15, 20 );
OffsetRect (offset_rect)
Displace/slide a rectangle by a certain distance. If returning a value
in Ada, the new rect is returned (instead of altering the original rect).
Ada: OffsetRect( r, 10, -1 ); or r2 := OffsetRect( r, 10, -1 );
C++: r2 = offset_rect( &r, 10, -1 );
InsetRect (inset_rect)
Move the parallel sides of a rectangle in or out from the center by a
certain distance. A negative distance makes the rectangle smaller.
If returning a value in Ada, the new rect is returned (instead of altering
the original rectangle).
Ada: InsetRect( r, -5, -5 ); or r2 := InsetRect( r, -5, -5 );
C++: r2 = inset_rect( &r, -5, -5 );
InsideRect (inside_rect)
True if one rectangle is inside of another.
Ada: bool := InsideRect( inner, outer );
C++: int = inside_rect( inner, outer );
InRect (in_rect)
True if a point is inside a rectangle.
Ada: bool := InRect( 5, 10, r );
C++: int = in_rect( 5, 10, r );
IsEmptyRect (is_empty_rect)
True if a rectangle is empty (that is, if the bottom is less than the
top or the right side is less than the left side).
Ada: bool := IsEmptyRect( r );
C++ int = is_empty_rect( r ); [Needs fixing for C++]
Rectangle Lists
[to be finished]
The O/S Package
The O/S package was indended as a thick binding to the operating system.
This would have allowed TextTools to be portable across a variety of
operating systems. Since the time the O/S package was started, GCC
Ada has included its own O/S library package, making the TextTools O/S
package obsolete. However, the O/S package is still used by TextTools
and contains useful O/S utilities.
HouseKeeping
StartupOS (startup_os)
Initialize the O/S package. It creates a new session_log file if the
session log directory exists, initializes pathname aliases. This should
be the first subprogram called in the O/S package.
Ada: StartupOS;
C++: startup_os();
Errors: TT_OSService (no tty device for TextTools)
ShutdownOS (shutdown_os)
Stop the O/S package. It discards memory allocated at startup. This
should be the final subprogram called in the O/S package.
Ada: ShutdownOS;
C++ shutdown_os;
Errors: none
IdleOS (idle_os )
Performs any idle-time tasks. This is normally called for the application
by the Window manager.
Ada: IdleOS( idlePeriod );
C++: idle_os( idlePeriod );
Errors: none
Session Logs
StartupCommon contains both a long name and a short name for the
application. If the user, in his home directory, has a subdirectory
with the same name as the application short name, the O/S package
will create a file called "session_log" containing information about
the last run of the program.
For example, if the short name for a program is "small_demo", then
the application log will be stored in "~/small_demo/session_log".
If the small_demo directory is missing, there will be no session log.
Many of the TextTools functions record debugging information into a
session log if it exists. Your program can also write to the session
log.
SessionLog (session_log)
Append a message to the session log.
Ada: SessionLog( msg ); or
SessionLog( fixedstring_msg ); or
SessionLog( msg, errorccode ); or
SessionLog( fixedstring_msg, errorcode );
C++: SessionLog( str255_msg );
Errors: none
Pathname Aliases
O/S pathnames can contain aliases for common directories. If the pathname
starts with a "$", the first word (up to a '/') indicates an alias.
The O/S package defines the following aliases on startup:
- $tmp - the temp directory (the value of TMPDIR or "/tmp/")
- $home - the user's home directory
- $sys - the working directory for TextTools (the same directory that contains the session long)
There are 6 predefined file systems:
- UNIXFS - 255 character UNIX names
- UNIX14FS - 14 character UNIX names
- DOSFS - DOS 8 character / 2 character suffix names
- OS/2 - 255 character O/S names
- NONE - an undefined file system
Pathnames are 255 character bounded strings.
UNIX
Call the standard C library system() function. Start an O/S shell and
run the specified command(s). If a boolean result, return true on
success. If a string result, return the first string of the output.
Ada: UNIX( cmd ); or
b := UNIX( cmd ); or
s := UNIX( cmd );
C++: N/A (use system() directly)
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
RunIt
Run ("spawn") a command without invoking a shell. This is a binding to the
UNIX fork(), dup() and exec() syscalls. The command takes up to 3 parameters.
The output of the command is returned as a list of str255 strings.
Ada: RunIt( cmd, parm1 := "", parm2 := "", parm3 := "", results );
C++: N/A
Errors: TT_SystemError (unable to run command / command failed )
ValidateFilename (validate_filename)
Ensure that a filename is syntactically correct for a particular file
system. If the filename is unacceptable, the reason is outlined in errmsg
and a legal filename (with the problem characters replaced by underscores)
is returned. If the filename is acceptable, errmsg is empty.
Ada: ValidateFilename( fs, filename, new_filename, errmsg );
C++: validate_filename( fs, str255_fn, str255_newfn, &errmsg );
Errors: none
ValidatePathname (validate_pathname)
Same as ValidateFilename but validates an entire path.
Ada: ValidatePathname( fs, pathname, new_pathname, errmsg );
C++: validate_pathname( fs, str255_pn, str255_newpn, &errmsg );
Errors: none
SetPath (set_path)
Change the default path (the present/current working directory).
Ada: SetPath( path );
C++: set_path( str255_path );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
GetPath (get_path)
Return the current default path (the present/current working directory).
Ada: path := GetPath;
C++: str255_path := get_path();
Errors: none;
PathAlias (path_alias)
Create a new path alias (like $tmp, $home, etc.).
Ada: PathAlias( alias, path );
C++: path_alias( str255_alias; str255_path );
Errors: Ada STOARGE_ERROR exception will occur if memory is low
ExpandPath (expand_path)
Return a path with the path aliases replaced with actual directories.
Ada: fullpath := ExpandPath( aliasedpath );
C++: str255_fullpath = expand_path( str255_aliasedpath );
Errors: none
SplitPath (split_path)
Separate a path into the directory name and the filename.
Ada: SplitPath( path, dirname, filename );
C++: split_path( path, dirname, filename );
Errors: none
DecomposePath (decompose_path)
Separate a pathname or URL into its components. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
Working with Files
All O/S package file functions accept pathname aliases.
NotEmpty (not_empty)
Return true if the file exists and has a length greater than zero.
Ada: b := NotEmpty( path );
C++: b = not_empty( str255_path );
Errors: TT_ParamError (the path is too long)
IsDirectory (is_dir)
Return true if the file is a directory.
Ada: b := IsDirectory( path );
C++: b = is_dir( str255_path );
Errors: none
IsFile (is_file)
Return true if the pathname specifies a readable, existing file.
Ada: b := IsFile( path );
C++: b = is_file( str255_path );
Errors: none
MakeTempFileName (make_temp_file_name)
Create a new path for a temporary file.
Ada: MakeTempFileName( newpath );
C++: make_temp_file_name( str255_newpath );
Errors: none
Lock (lock)
Not completed.
Ada: N/A
C++: N/A
Errors: N/A
Unlock (unlock)
Not completed.
Ada: N/A
C++: N/A
Erase (erase)
Permanently delete a file.
Ada: erase( path );
C++: erase( str255_path );
Errors: TT_FileAccess (permission denied)
TT_FileExistance (no such file)
TT_PathExistance (no such path)
TT_VolAccess (no such volume)
TT_SystemError (other error)
Trash (trash)
Remove a file by moving it to $HOME/.Trash/. If unable to trash the file,
it will be removed with Erase.
Ada: Trash( path );
C++: trash( path );
Errors: TT_FileAccess (permission denied)
TT_FileExistance (no such file)
TT_PathExistance (no such path)
TT_VolAccess (no such volume)
TT_SystemError (other error)
EmptyTrash (empty_trash)
Remove old files from the trash. Performs a UNIX "find -mtime +3".
Ada: EmptyTrash;
C++: empty_trash();
Errors: TT_SystemError (unable to run command / command failed)
Move (move)
Rename or move a file. Runs UNIX "mv" command.
Ada: Move( oldpath, newpath);
C++: move( str255_oldpath, str255_newpath );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Shrink (shrink)
Compresses a file using UNIX "zoo" command. Returns the pathname
of the compressed file.
Ada: compressedpath := Shrink( path );
C++: str255_compressedpath = shrink( str255_path );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Expand (expand)
Expand a file that was compressed with Shrink. Uses "zoo" command.
Ada: pathname := Expand( compressedpath );
C++: str255_pathname = expand( str255_compressedpath );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Archive (archive)
Compress and add a file to an archive containing several compressed
files. Uses "zoo" command.
Ada: Archive( archivepath, filename );
C++: archive( str255_archivepath, str255_filename );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Extract (extract)
Extract a file from an Archive archive. Uses "zoo" command.
Ada: Extract( archivepath, filename );
C++: extract( str255_archivepath, str255_filename );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Armour (armour)
Encrypt binary file as plain text. Not completed.
Ada: N/A
C++: N/A
Errors: N/A
Disarmour (disarmour)
Decrypt a binary file encrypted as plain text. Not completed.
Ada: N/A
C++: N/A
Errors: N/A
Usage (usage)
Change the access permissions on a file. Defaults are user=normal,
group=ReadOnly, others=ReadOnly. Runs "chmod" command.
Ada: Usage( path, me := normal, us := ReadOnly, everyone = ReadOnly );
C++: N/A
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
BeginSession (begin_session)
Begin a series of optimized O/S calls. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
EndSession (end_session)
Complete a series of optimized O/S calls. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
Working with Directories
SpaceUsed (space_used)
Return the number of bytes used in a directory. Uses "df" command,
Ada: bytes := SpaceUsed( dir );
C++: byes = space_used( dir );
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Working with Volumes/Devices
SpaceFree (space_free)
Return the space free on a volume/device. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
TotalSpace (total_space)
Return the total capacity of a volume/device. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
EntriesFree (entries_space)
Return the free directory entries (inodes) of a volume/device. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
TotalEntries (total_space)
Return the total directory entries (inodes) of a volume/device. Not complete.
Ada: N/A
C++: N/A
Errors: N/A
OnDevice (on_device)
Return the device path for the device/volume that a file resides on. Not
complete.
Ada: N/A
C++: N/A
Errors: N/A
Working with Memory
TotalMem (Ctotalmem)
Return the total memory of the computer (including virtual memory). Uses
the proc filesystem.
Ada: bytes := TotalMem;
C++: bytes = Ctotalmem();
Errors: none
FreeMem (Cfreemem)
Return the free memory of the computer (including virtual memory). Uses the
proc filesystem.
Ada: bytes := FreeMem;
C++: bytes = Cfreemem();
Errors: none
RealTotalMem (Crealtotalmem)
Return the total memory of the computer (not virtual memory). Uses the proc
filesystem.
Ada: bytes := RealTotalMem;
C++: bytes = Crealtotalmem();
Errors: none
RealFreeMem (Crealfreemem)
Return the free memory of the computer (not virtual memory). Uses the proc
filesystem.
Ada: bytes := RealFreeMem;
C++: bytes = Crealfreemem();
Errors: none
Working with Processes
MyID
Return your process identification number (PID).
Ada: pid := MyID;
C++: N/A (use getpid)
Errors: none
Nice
Change the priority of your process. Same as C nice().
Ada: Nice ( change );
C++: N/A (use nice)
Erros: none
IsLocal (is_local)
Return true if program is running on a virtual console.
Ada: b := IsLocal;
C++: b = is_local();
Errors: none
Working with Distributed Clusters
GetFreeClusterHost (get_free_cluster_host)
Return an idle host in a computer cluster. Not complete, but will return the
name of the current host using "uname" command.
Ada: N/A
C++: N/A
Errors: TT_ParamError (cmd is over 255 characters)
TT_SystemError (unable to run command / command failed)
Working with Dates and Times
A time is represented by a ATime record (struct):
| Ada | C++ | Description |
| seconds | seconds | number of seconds since Epoch |
| microseconds | microseconds | number of additional microseconds |
GetDate (get_date)
Return the date in dd/mm/yy format.
Ada: s := GetDate;
C++: str255 = get_date();
Errors: none
GetTime (get_time)
Return the time in hh:mm:ss format.
Ada: s := GetTime;
C++: str255 = get_time();
Errors: none
GetClock
Get the current time and date. Uses C's gettimeofday().
Ada: GetClock( time, timezone );
C++: N/A (use gettimeofday)
Errors: none
GetLongDate (get_long_date)
Return the full english date (in the ctime() format).
Ada: s := GetLongDate;
C++: str255 = get_long_date();
Errors: none
GetTimeStamp (get_time_stamp)
Return the current date and time in a format that can be sorted. In this
case, the number of microseconds since the Epoch.
Ada: s := GetTimeStamp;
C++: str255 = get_time_stamp();
Errors: none;
Wait (os_wait)
Wait for at least the specific number of seconds. Uses C usleep().
Ada: Wait (float_seconds);
C++: os_wait (float_seconds);
Errors: none
Loading and Saving Text Files
-- to be filled in
AddFile (add_file)
Append a string to a file. Includes an end-of-line character.
Ada: AddFile( file, string );
C++: add_file( str255_file, str255_string );
The User IO Package
The UserIO package performs all the low-level drawing and reads the keyboard
and mouse. It is TextTools' interface to the curses/ncurses library.
Normally, a TextTools application doesn't need to use the UserIO package
directly. The Windows package makes all the necessary TextTools calls
to draw your windows.
Housekeeping
StartupUserIO (startup_userio)
Initialize the UserIO package. It starts curses, resets the drawing
defaults and reads any macro file. The background colour is set to blue.
When it is finished, it clears the window and positions the pen at the
upper-left corner. This should be the first subprogram called in the
UserIO package.
Ada: StartupUserIO;
C++: startup_userio();
Errors: none
ShutdownUserIO (shutdown_userio )
Stop the UserIO package. It stops curses, discards the macro file and
any unprocessed input. It flushes any unrevealed drawing to the screen.
This should be the last subprogram called in the UserIO package.
Ada: ShutdownUserIO;
C++ shutdown_userio;
Errors: none
IdleUserIO (idle_userio )
Performs any idle-time tasks. After 60 seconds of no activity, UserIO
will discard any non-essential allocated memory. This is normally called
for the application by the Window manager.
Ada: IdleUserIO( idlePeriod );
C++: idle_userio( idlePeriod );
Errors: none
ResetUserIO (reset_userio)
Reinitializes curses. Called by the Window manager when refreshing the
entire desktop after the screen has been clobbered by another program. The
drawing defaults are left unchanged.
Ada: ResetUserIO;
C++ reset_userio();
Errors: none
BlueBackground (blue_background)
TextTools normally has a blue background. The call can change the
background colour to black background instead of blue.
Ada: BlueBackground( bool );
C++" blue_background( int );
Errors: none
IsBlueBackground (is_blue_background)
True if the background is current blue instead of black.
Ada: bool := IsBlueBackground;
C++: uchar = is_blue_background();
Errors: none
Getting Information about the I/O Hardware
The display is the current screen or window that TextTools is drawing on.
TextTools can return statistics about the current display device.
The information about the display device is returned as a aDisplayInfoRec
(or C++ a_display_info_rec) record. The record has these fields:
| Ada | C++ | Description | VT-100 Example |
| Fields | fields | fiends in this record | 8 |
| TextBased | text_based | true if text-based display | true (or 1) |
| H_Res | h_res | horizontal columns | 80 |
| V_Res | v_res | vertical rows | 24 |
| C_Res | c_res | RGB bits (or 0) | 0 |
| P_Len | p_len | palette length (or 0) | 0 |
| D_Buf | d_buf | number of display buffers | 1 |
| S_Res | s_res | sound resolution (or 0) | 0 |
| Y_Res | y_res | sound voices/channels (or 0) | 0 |
Likewise, information about the input hardware can be obtained in a
anInputInfoRec (or C++ an_input_info_rec):
| Ada | C++ | Description | VT-100 Example |
| Fields | fields | fiends in this record | 4 |
| HasKeyboard | has_keyboard | true if has a keyboard | true (or 1) |
| HasDirection | has_direction | true if has a game pad | false (or 0) |
| HasVelocity | has_velocity | true if has a joystick | false (or 0) |
| HasLocator | has_locator | true if has a mouse | false (or 0) |
TextTools supports ncurses-compatible mice, but there is currently no
game pad or joystick support.
GetDisplayInfo (get_display_info)
Return information about the video display and sound hardware.
Ada: GetDisplayInfo( dspinforec );
C++: get_display_info( &dspinforec );
Errors: none
GetInputInfo (get_input_info)
Return information about the input devices.
Ada: GetInputInfo( inpinforec );
C++: get_input_info( &inpinforec );
Errors: none
The Pen
UserIO draws everything on the screen using an imaginary pen. The pen
has a location, an angle and a default colour.
When the UserIO package is started, the pen is at the top-left corner
of the display and has an angle of 0 degrees (see turtle graphics). The
colour is "outline".
The pen position is set by moving or drawing with the pen.
GetPenPos (get_pen_pos)
Return the pen position.
Ada: GetPenPos( x, y );
C++: get_pen_pos( &x, &y );
Errors: none
GetPixel (get_pixel)
Return RGB (0,0,0) or (100,100,100) depending on whether or not a
screen position has a character in it.
Ada: GetPixel( x, y, R, G, B );
C++: GetPixel( x, y, &R, &G, &B );
Errors: none
MoveToGlobal (move_to_global)
Move the pen to a particular screen position.
Ada: MoveToGlobal( x, y );
C++: move_to_global( x, y );
Errors: none
Notes: local move to is defined in the window manager.
CLS (Cls)
Clear the screen to the background colour. Cls changes the pen colour.
Ada: CLS;
C++: Cls();
Errors: none
The Pen Colours
On most text-based screens, the pen colour can be one of several predefined
colour names:
| Ada | C++ | Description |
| None | none | an undefined colour |
| Outline | outline | the thin, bright pen for drawing windows |
| ScrollBack | scroll_back | the background colour of a scroll bar |
| ScrollThumb | scroll_thumb | the colour of a scroll bar thumb |
| ThermBack | therm_back | the background colour of a thermometer |
| ThermFore | therm_fore | the foreground colour of a thermometer |
| White | white | white |
| Red | red | red |
| Purple | purple | purple |
| Green | green | green |
| Blue | blue | blue |
| Yellow | yellow | yellow |
| Black | black | black |
The first few colour names are logical colours: their actual value may
change depending on the TextTools background colour (blue or black).
The pen colour can also be set using RGB (red, green and blue) percentages.
TextTools will attempt to match the RGB value to the nearest pen colour name.
If the text display is monochrome, TextTools attempts to draw with characters
representing different colours.
SetPenColour (set_pen_colour):
Change the pen to a certain colour or colour name.
Ada: SetPenColour( colour_name ); or
SetPenColour( R, G, B );
C++: ?
Errors: none
GetPenColour (get_pen_colour)
Return the current pen colour or the closest colour name.
Ada: colour_name := GetPenColour(); or
GetPenColour( R, G, B );
C++: ?
Palette Colours
This feature is for future expansion.
Pen Size
This feature is for future expansion.
Line Drawing
DrawLine (draw_line)
Draw a line between a pair of points. It never uses the terminal's line
drawing characters.
Ada: DrawLine( x1, y1, x2, y2 );
C++: draw_line( x1, y1, x2, y2 );
Errors: none
DrawHorizontalLine (draw_horizontal_line)
Draw a horizontal line. It uses the terminal's line drawing characters
if available.
Ada: DrawHorizontalLine( x1, x2, y );
C++: draw_horizontal_line( x1, x2, y );
Errors: none
DrawVerticalLine (draw_vertical_line)
Draw a vertical line. It uses the terminal's line drawing characters if
available.
Ada: DrawVerticalLine( y1, y2, x );
C++: draw_vertical_line( y1, y2, x );
Errors: none
Rectangle Drawing
FrameRect (frame_rect)
Draw the outline of a rectangle in the current pen colour.
Ada: FrameRect( r );
C++: frame_rect( &r );
Errors: none
FrameRect3D (frame_rect_3d)
Draw the outline of a rectangle with 3D lighting effects in the current
pen colour.
Ada: FrameRect3D( r );
C++: frame_rect_3d( &r );
Errors: none
PaintRect (paint_rect)
Fill a rectangle in the current pen colour.
Ada: PaintRect( r );
C++: paint_rect( &r );
Errors: none
FillRect (fill_rect)
Fill a rectangle with a specific colour.
Ada: FillRect( r, colour_name );
C++: fill_rect( &r, colour_name );
Errors: none
FramedRect (framed_rect)
Frame and fill a rectangle with specific colours.
Ada: FramedRect( r, frame, background );
C++: framed_rect( &r, frame, background );
Errors: none
EraseRect (erase_rect)
Erase a rectangle with the background colour.
Ada: EraseRect( r );
C++: EraseRect( &r );
Errors: none
Turtle Graphics
TextTools can perform Logo-style turtle graphics. The pen has a drawing
angle and it can draw forward along the angle.
SetPenAngle (set_pen_angle)
Set the current drawing angle (in degrees).
Ada: SetPenAngle( degrees );
C++: set_pen_angle( degrees );
Errors: none (angle is contrained to >=0 and < 360)
ChangePenAngle (change_pen_angle)
Add to or subtract from the pen angle.
Ada: ChangePenAngle( change );
C++: change_pen_angle( change );
Errors: none (angle is contrained to >=0 and < 360)
GetPenAngle (get_pen_angle)
Return the current pen angle.
Ada: float := GetPenAngle;
C++: float = get_pen_angle();
Errors: none
MoveForward (move_forward)
Move forward in the current pen angle direction without drawing.
Ada: MoveForward( pixels );
C++: move_forward( pixels );
Errors: usual things may happen when trying to draw off the screen
DrawForward (draw_forward)
Draw forward in the current pen angle direction.
Ada: DrawForward( pixels );
C++: draw_forward( pixels );
Errors: usual things may happen when trying to draw off the screen
Drawing Text
Text is drawn at the current position of the pen and the pen advances
when the text is drawn. However, the text is not affected by the pen
angle or colour.
The text is displayed according to the current text style:
| Ada | C++ | Description |
| Normal | normal | Default pen style |
| Bold | bold | boldface |
| Underline | underline | underlined text |
| Italic | italic | italic text |
| BoldUnderline | bold_underline | bold and underline |
| BoldItalic | bold_italic | bold and italic |
| ItalicUnderline | italic_underline | italic and underline |
| boldUnderlineItalic | bold_underline_italic | bold, underline & italic |
The text style is an enumerated type. Not all displays will support every
one of these modes.
There are also a large set of logical styles. TextTools tries to use the
most appropriate text colour and attribute for a particular style.
| Ada | C++ | Description |
| Success | success | successful operation |
| Failure | failure | failed operation |
| Warning | warning | user warning |
| Status | status | status information |
| Citation | citation | a quote or citation |
| SectionHeading | section_heading | a document section heading |
| SubHeading | sub_heading | a document subheading |
| Heading | heading | a document heading |
| Title | title | a document title |
| Emphasis | emphasis | an emphasized word or phrase |
| Input | input | UserIO input field colour |
| Marquee | marquee | an impressive announcement |
| Headline | headline | newspaper-style headline |
| FinePrint | fine_print | legal notices |
| DefinedTerm | defined_term | a definition |
| Footnote | footnote | a footnote |
| ToAddress | to_address | an envelope's destination |
| FromAddress | from_address | an envelope's source |
| SubScript | sub_script | a subscript |
| SuperScript | super_script | a superscript |
A text colour can be any pen colour name. The text colour is separate from
the pen's drawing colour.
SetTextStyle (set_text_style)
Sets the current text style. All future text will be drawn in this style.
Ada: SetTextStyle( style );
C++: set_text_style( style );
Errors: none
GetTextStyle (get_text_style)
Return the current text style.
Ada: style := GetTextStyle;
C++: style = get_text_style();
Errors: none
SetTextColour (set_text_colour)
Select the current text colour. All future text will be drawn in this colour.
Ada: SetTextColour( colour_name );
C++: set_text_colour( colour_name );
Errors: none
Draw (draw)
Draw text on the screen. The draw command doesn't recognize formatting
characters like tabs or C++ '\n'--it draws the raw ASCII characters.
Ada: Draw( str255 ); or
Draw( adastring ); or
Draw( str255, width, ellipsis ); or
Draw( ch ); or
Draw( int ); or
Draw( long ); or
Draw( float );
C++: draw_cstring( c_string *s );
Errors: none
DrawLn (draw_ln)
Start a new line, returning to the left side of the screen.
Ada: DrawLn;
C++: draw_ln();
Errors: none
DrawEdit (draw_edit)
Draw a text edit field.
Ada: DrawEdit( str255, width, am );
C++: draw_edit( str255, width, am );
Errors: none
Drawing Emergency Messages
These text drawing routines are for emergency situations, displaying
critical system errors. This are intended for internal use by TextTools.
DrawErr (draw_err)
Draw an emergency message. Always drawn in white and the normal text style.
Ada: DrawErr( str255 ); or
DrawErr( int ); or
DrawErr( long ); or
DrawErr( input_rec );
C++: draw_cerr( c_string *s );
Errors: none
DrawErrLn (draw_errln)
Draw a newline, returning to the left side of the screen.
Ada: DrawErrLn;
C++: draw_err_ln();
Errors: none
Text Fonts and Sizes
TextTools font and font list capabilities are for future expansion.
The height of text (on a text-based screen) is always 1. The width will be
1 for a single character, or the length of a string for the string.
GetTextHeight (get_text_height):
Return the height of a character or string (always 1).
Ada: int := GetTextHeight( ch ); or int := GetTextHeight( s255 );
C++: int := get_text_height( s255 );
Errors: none
GetTextWidth (get_text_width):
Return the width of a character (always 1) or a string.
Ada: int := GetTextWidth( ch ); or int := GetTextWidth( s255 );
C++: int = get_text_width( s255 );
Errors: none
Regions
Regions, arbitrarily shaped objects, are for future expansion. In
TextTools, they are represented as a linked list of rectangles.
Pictures
Pictures are copies of what is on the TextTools screen. Pictures
are not completely implemented.
ScreenDump (screen_dump)
Save a copy of the display in a file called "ScreenDump".
Ada: ScreenDump;
C++: screen_dump();
Errors: In Ada, STORAGE_ERROR exception if out of memory.
Output Spooling
Since TextTools is based on curses, TextTools applications can use
curses' delayed drawing features (called output spooling). TextTools
can delay displaying the screen until several drawing operations have
been done and then it will display the final result. When erasing and
drawing many items on the screen, this can reduce flicker and make the
display appear faster over slow connections to a video terminal.
Note: Spooling has been disabled because of problems with certain versions
of ncurses.
WaitToReveal (wait_to_reveal)
Begin output spooling. Don't draw anything.
Ada: WaitToReveal;
C++: wait_to_reveal();
Errors: none
Reveal (reveal)
Stop output spooling. Update the display to reflect what has been
secretly drawn.
Ada: Reveal;
C++: reveal();
Errors: none
RevealNow (reveal_now)
Show what has been drawn so far, but continue to spool.
Ada: RevealNow;
C++: reveal_now();
Errors: none
Playing Sounds
The music sound features of UserIO are for future expansion.
The beep command will play a beep through the system speaker.
If Warren Gay's wavplay is installed, beep will search for a play sound
samples for particular beep styles. The sound samples must be in uppercase
(with the Ada name) and stored in the session directory.
| Ada | C++ | Description |
| Normal | normal_beep | a default beep |
| Success | success_beep | successful operation |
| Failure | failure_beep | a failed operation |
| Warning | warning_beep | a warning to the user |
| Status | status_beep | status information |
| BadInput | bad_input | bad input into a window edit text field |
| HourChime | hour_chime | played by window manager at :00 |
| QuarterChime1 | quarter_chime1 | played by window manager at :15 |
| QuarterChime2 | quarter_chime2 | played by window manager at :30 |
| QuarterChime3 | quarter_chime3 | played by window manager at :45 |
| Alarm | alarm | timer ring |
| NewMail | new_mail | new email sound |
| LowPower | low_power | power failure |
| Startup | startup | played at UserIO startup |
| Shutdown | shutdown | played at UserIO shutdown |
Beep (beep)
Beep the speaker or play a .wav file for a particular sound.
Ada: Beep( style );
C++: beep( style );
Errors: TT_file_existance (the .wav file doesn't exist)
PlaySound (play_sound)
Play a .wav file using wavplay (if installed).
Ada: PlaySound( path_str255 );
C++: play_sound( path_str255 );
Errors: TT_file_existance (the .wav file doesn't exist)
The Event Queue
There are several kinds of events
| Ada | C++ | Description |
| NullInput | null_input | no input |
| KeyInput | key_input | keyboard input |
| HeldKeyInput | held_key_input | key held down |
| DirectionInput | direction_input | joystick direction |
| LocationInput | location_input | specific mouse position |
| ButtonDownInput | button_down_input | mouse button pressed |
| ButtonUpInput | button_up_input | mouse button released |
| HeartbeatInput | heartbeat_input | a "keep alive" event |
| MoveInput | move_input | mouse position change |
| UserInput | user_input | user-defined input |
An event is a variant record (in C++, a union) called AnInputRecord (or
an_input_record). The fields depends on the type of input.
| Ada | C++ | Description |
| - | - | no input |
| Key | key_data.key | keyboard input |
| HeldKey | held_key_data.held_key | key held down |
| Direction | direction_data.direction | joystick direction |
| Velocity | direction_data.velocity | joystick velocity |
| X | location_data.x | mouse X position |
| Y | location_data.y | mouse Y position |
| DownButtion | button_down_data.down_button | mouse button number |
| DownLocationX | button_down_data.down_location_y | mouse button down X |
| DownLocationY | button_down_data.down_location_x | mouse button down Y |
| UpButtion | button_up_data.up_button | mouse button number |
| UpLocationX | button_up_data.down_location_x | mouse button down X |
| UpLocationY | button_up_data.down_location_y | mouse button down Y |
| - | - | heart beat |
| MoveLocationX | move_data.move_location_x | move move X |
| MoveLocationY | move.data.move_location_y | move location Y |
| id | user_data.id | user-defined long int |
For better efficiency on multiuser systems, some keyboard functions
have a response time parameter. This can be set to blocking (wait
indefinitely for a keypress), erratic (wait a fraction of a second),
or instant (return immediately if there is no keypress).
GetInput (get_input)
Return the next event in the input event queue. Ada doesn't allow a
C++ default for response_time.
Ada: GetInput( input_rec, response_time := blocking );
C++: get_input( &input_rec, response_time ); // not working yet
Errors: In Ada, STORAGE_ERROR exception if out of memory.
SetInput (set_input)
Add an event to the input event queue. If usetime is true, use the
time in the record instead of the current time for the time stamp. Ada
doesn't allow a C++ default for usetime.
Ada: SetInput( input_rec, usetime := false );
C++: set_input( &input_rec, usetime );
Errors: In Ada, STORAGE_ERROR exception if out of memory.
HeartBeat (heart_beat)
Add a heartbeat event to the input event queue.
Ada: HeartBeat;
C++: heart_beat();
Errors: In Ada, STORAGE_ERROR exception if out of memory.
SetInputString (set_input_string)
Add a string to the input event queue as if the user had typed it in
from the keyboard.
Ada: SetInputString( str255 );
C++: set_input_string( str255 );
Errors: In Ada, STORAGE_ERROR exception if out of memory.
FlushInput (flush_input)
Discard all events in the input event queue.
Ada: FlushInput;
C++: flush_input;
Errors: none
GetInputLength (get_input_length)
Return the length of the input event queue.
Ada: long := GetInputLength;
C++: long = get_input_length;
Errors: none
WaitFor (wait_for)
Wait for the specific number of ticks (1/60th of a second). If any input
occurs, add it to the input event queue. WaitFor will wait for at least
the number of specified ticks, but it may wait for longer--it's not intended
for high precision waiting.
Ada: WaitFor( ticks );
C++: wait_for( ticks );
Errors: none
The Keyboard
FlushKeys (flush_keys)
Discard all pending keypresses that are not yet in the event queue.
Ada: FlushKeys;
C++: flush_keys;
Errors: none
Keypress (keypress)
Check for a keypress. Return ASCII 0 if there is none. If shortblock
is true, wait for a fraction of second instead of returning immediately
with an ASCII 0.
Ada: ch := Keypress( shortblock );
C++: ch = keypress( shortblock );
Errors: none
GetKey (get_key)
Wait for a keypress and return the character.
Ada: GetKey( ch );
C++: get_key( &ch );
The Mouse
GetLocation (get_location)
Return the current position of the locator device (usually a mouse).
Ada: Not Yet Implemented
C++: Not Yet Implemented
Errors: none
The Joystick
Joystick support is for future expansion.
The O/S Package
The Controls Package
Window controls (sometimes called "widgets") are items that appear in windows.
OK buttons, scroll bars, and text entry boxes are all controls.
In TextTools, controls are objects. Since Ada and C++ have slightly different
object oriented methodologies, the functions are slightly different between
the two languages.
Every control has a constructor and destructor. To use a control, declare it.
The constructor requires the bounding rectangle around the control and an
associated hot key (the quick select key on the keyboard).
a_simple_button sb1( 1, 1, 10, 1, 'o' );
// create a button in the window located between (1,1) and (10,1)
// with a hot key of 'o'.
In Ada, there is an additional Init function to set up the rectangle and hot
key.
sb1 : aliased aSimpleButton;
...
Init( sb1, 1, 1, 10, 1, 'o' );
If you don't want a hot key, use an ASCII NUL character for the key. Some
controls may have additional initialization values.
Once a control is created, it must be added to the window using the Window
Manager's AddControl (C++, add_control) function. The next time the window
is drawn, the control will appear.
All controls share certain common properties:
- 1. Frames - each control has a bounding rectangle.
- Hot Keys - each control has a hot key.
- Status - whether the control is selectable or not. The possible status
codes are off (unselectable), standby (selectable but not current) or
on (the control is the active one in use by the user).
- Tool Tips - messages that can appear in a window's info bar when a control
is selected.
- Scrolling - whether or not the control moves when the window contents
are scrolled (like a virtual window).
- Stickyness - whether or not a particular side of a control's frame
stretches when the window is resized (not fully implemented).
- Validity - whether or not a control should be (re)drawn
There are a number of elementary functions common to every control. Most of
these functions are used internally by TextTools.
SetInfo can be used to create "tool tips", messages that appear in a window's
info bar when the control is the current target of a user's actions. Initially
a control has no tool tip: when the control is selected, the contents of the
tool bar do not change. When a message is added using SetInfo and the control
is selected, the message appears in the tool bar. There is no way to turn off
a tool tip once it has been created: an empty string will simply erase the
previous contents of the info bar when the control is selected.
Hear (hear)
Used by Window Manager DoDialog. Give user to a control. For example, have
the control "hear" and respond to a keypress. The control will return a
dialog action if the Window Manager needs to respond to the control changes.
Ada: Hear( control, inputRec, dialogAction );
C++: control.hear( input_rec, &dialog_action );
Errors: none
Move (move)
Used by Window Manager DoDialog. Move a control to a new position in a
window. Indicate the horizontal and vertical change.
Ada: Move( control, dx, dy );
C++: control.move( dx, dy );
Errors: none
Resize (resize)
Used by Window Manager DoDialog. Resize the bounding box of a control,
possibly moving the control at the same time. Indicate the rectangle
coordinate changes.
Ada: Resize( control, dleft, dtop, dright, dbottom );
C++: control.resize( dleft, dtop, dright, dbottom );
Errors: none
Draw (draw)
Used by Window Manager DoDialog. Draw (or redraw) the control if it is
not invalid.
Ada: Draw( control );
C++: control.draw();
Errors: none
SetStatus (set_status)
Used by Window Manager DoDialog. Change the status of a control (whether it
is active or not, etc.)
Ada: SetStatus( control, status );
C++: control.set_status( status );
Errors: none
GetStatus (get_status)
Used by Window Manager DoDialog. Change the status of a control (whether it
is active or not, etc.)
Ada: status := GetStatus( control );
C++: status = control.get_status();
Errors: none
Encode (encode)
Used by Window Manager SaveWindow. Encode the control as a string for saving
to a text file. Note: This function is currently broken.
Ada: str255 := Encode( control );
C++: str255 = control.encode();
Errors: none
Decode (Decode)
Used by Window Manager LoadWindow. Create a control from a control saved by Encode. Note: This function is currently broken.
Ada: Decode( control, str255 );
C++: control.decode( str255 );
Errors: none
Invalid (invalid)
Used internally by controls or by Window Manager. Mark a control as needing
to be redrawn.
Ada: Invalid( control );
C++: control.invalid();
Errors: none
NeedsRedrawing (needs_redrawing)
Used internally by Window Manager. Check to see if a control needs redrawing
(if it has been marked invalid).
Ada: b := NeedsRedrawing( control );
C++: b = control.needs_redrawing();
Errors: none
GetHotKey (get_hot_key)
Used internally by Window Manager. Get the hot key for the control.
Ada: c := GetHotKey( control );
C++: c = control.get_hot_key();
Errors: none
SetInfo (set_info)
Used internally by Window Manager. Set the info bar text associated with
the control. Setting the info message to a blank string creates a blank
message in the info bar. (This is TextTools' equivalent to a "tool tip".)
Ada: SetInfo( control, str255 );
C++: control.set_info( str255 );
Errors: none
GetInfo (get_info)
Used internally by Window Manager. Get the info bar text associated with
the control.
Ada: str255 := GetInfo( control );
C++: str255 = control.get_info();
Errors: none
HasInfo (has_info)
Used internally by Window Manager. Determine if a info bar text should be
shown for the control (that is, whether or not SetInfo has ever been used for
this control).
Ada: b := HasInfo( control );
C++: b = control.has_info();
Errors: none
GetStickyness (get_stickyness)
Used internally by Window Manager. Return true if a side of a control is
sticky. Note: Stickyness is not fully implemented.
Ada: GetStickyness( control, left, top, right, bottom );
C++: control.get_stickyness( &left, &top, &right, &bottom );
Errors: none
SetStickyness (set_stickyness)
Make certain sides of a control's bounding box sticky (that is, the side
stretches when the window is stretched). Note: Stickyness is not fully
implemented.
Ada: SetStickyness( control, left, top, right, bottom );
C++: control.set_stickyness( left, top, right, bottom );
Errors: none
InControl (in_control)
Return true if a point is inside of the control's bounding retangle.
Ada: b := InControl( control, x, y );
C++: b = control.in_control( control, x, y );
Errors: none
GetFrame (get_frame)
Return a control's bounding retangle.
Ada: r := GetFrame( control );
C++: r = control.get_frame( control );
Errors: none
Scrollable (scrollable)
Mark a control as scrollable (able to be scrolled when a window's contents
are scrolled).
Ada: Scrollable( boolean );
C++: control.scrollable( bool );
Errors: none
Init (C++ N/A)
Set the bounding box, hot key and radio family for a control.
Ada: Init( control, left, top, right, bottom, key [, family] );
C++: N/A (part of the constructor)
Errors: none
Window Control Categories
Unless you are creating new types of controls, you don't have to worry about
the control categories.
There are two categories of controls: window controls and iconic controls.
Iconic controls are controls which represent information to the user or that
allow the user to control an application. A static line of text is an iconic
control. "Window controls" are controls that affect the window and its
contents. A check box is a window control. Any iconic control can be linked
to another TextTools window (they are "hypertext-enabled", like items in a
web browsers window) as opposed to window controls that never lead anywhere
else when clicked.
All controls are either extended from anIconicControl or aWindowControl, two
window tagged types (ie. classes in C++). Iconic controls have two special
fields:
| Ada | C++ | Type | Description
| link | link | str255 | the location being linked to |
| closeBeforeFollow | close_before_follow | boolean | close window first (if true) |
|
A regular window control has no special fields.
Iconic control links are in URL format and can be one of the following:
- window:// - open a window saved in a SaveWindow file
- http:// - shell out to the lynx browser to display web page
- file:// - shell out to the lynx browser to display a text file
- unix:// - shell out and run the specified O/S command
Controls: Themometers
A thermometer is a bar graph indicating progress information or a percentage
value. Thermometers can be horizontal or vertical: if the control frame is
narrow, the thermometer will be vertical.
Thermometers have a maximum value and a current value. The difference
between the two will be displayed as a bar graph. For example, if the max is
10 and the current value is 5, the thermometer will show 50%.
Values less than zero or larger than the maximum value will be truncated
accordingly.
Here are the specific thermometer control methods:
GetMax (get_max)
Return the maximum value of the thermometer.
Ada: long := GetMax( control );
C++: long = control.get_max();
Errors: none
GetValue (get_value)
Return the current value of the thermometer.
Ada: long := GetValue( control );
C++: long = control.get_value();
Errors: none
SetMax (set_max)
Set the maximum value of the thermometer. The initial value is 0.
Ada: SetMax( control, long );
C++: control.set_max( long );
Errors: none
SetValue (set_value)
Set the current value of the thermometer. The initial value is 0.
Ada: SetValue( control );
C++: control.set_value();
Errors: none
Controls: Scroll Bars
A scroll bar is a bar containing a position marker called a "thumb" used to
represent a relative position or value. They are commonly used to scroll
through a window's contents. A scroll bar can be horizontal or vertical: if
the scroll bar frame is narrow, the scroll bar will be vertical.
Scroll bars have a maximum position and a thumb position. The thumb ranges
between zero and the maximum position. For example, if the maximum position
is 50 and the thumb position is 25, the thumb shows 50% progress.
Values less than zero or larger than the maximum position will be truncated
accordingly.
When a scroll bar is "owned" by a list control, the scroll bar is automatically updated when the list control is scrolled.
Here are the specific scroll bar control methods:
GetMax (get_max)
Return the maximum position of the scroll bar.
Ada: long := GetMax( control );
C++: long = control.get_max();
Errors: none
GetThumb (get_thumb)
Return the current position of the thumb.
Ada: long := GetThumb( control );
C++: long = control.get_thumb();
Errors: none
SetMax (set_max)
Set the maximum position of the thumb for the scroll bar. The initial value
is 0.
Ada: SetMax( control, maxval );
C++: control.set_max( maxval );
Errors: none
SetThumb (set_thumb)
Set the position of the thumb, between 0 and the current maximum. The
initial value is 0.
Ada: SetThumb( control, thumbval );
C++: control.set_thumb( thumbval );
Errors: none
SetOwner (set_owner)
Assign the number of the control that owns the scroll bar so that, when the
owner is changed, the scroll bar is updated automatically by the Window Mgr.
The initial value is 0 (no owner).
Ada: SetOwner( control, ownerid );
C++: control.set_owner( ownerid );
Errors: none
GetOwner (get_owner)
Return the previously assigned owner id for the scroll bar.
Ada: ownerid := GetOwner( control );
C++: control.get_owner();
Errors: none
Controls: Static Lines
A static line is a single line of unchanging text. The text can be assigned
colours and styles. The default control status is off (that is, that the
static line cannot be selected by the user).
GetText (get_text)
Return the static text.
Ada: str255 := GetText( control );
C++: str255 = control.get_text();
Errors: none
SetText (set_text)
Assign the static text to be displayed.
Ada: SetText( control, str255 ) or SetText( control, fixedstr );
C++: control.set_text( str255 ) or control.set_text( char *str );
Errors: none
GetStyle (get_style)
Return the text style.
Ada: style := GetStyle( control );
C++: style = control.get_style();
Errors: none
SetStyle(set_style)
Set the text style for the static text. The initial value is normal.
Ada: SetStyle( control, style );
C++: control.set_style( style );
Errors: none
GetColour (get_colour)
Return the name of the current text colour.
Ada: colour_name := GetColour( control );
C++: colour_name = control.get_colour();
Errors: none
SetColour (set_colour)
Assign the name of the colour for the static text. The initial value is
none.
Ada: SetColour( control, colour_name );
C++: control.set_colour( colour_name );
Errors: none
Controls: Edit Lines
An edit line is a line of text that, unlike a static line, can be edited by
the user. Edit lines (currently) do not scroll to allow text larger than
than size of the control--a 10 character edit line can hold a maximum of 10
characters.
The constructor has an additional maximum value parameter. Use 0 (or omit)
for the default.
Blind Mode: use this mode to enter passwords. The value of the edit line will
not be displayed.
Advance Mode: use this mode for entry of fixed length data on forms. This mode
will automatically advance to the next control when the edit line is full.
GetText (get_text)
Return the current value of the edit line.
Ada: str255 := GetText( control );
C++: str255 = control.get_text();
Errors: none
SetText (set_text)
Assign text to the edit line.
Ada: SetText( control, str255 );
C++: control.set_text( str255 );
Errors: none
GetAdvanceMode (get_advance_mode)
Return true if advanced mode is on.
Ada: bool := GetAdvanceMode( control );
C++: bool = control.get_advance_mode;
Errors: none
SetAdvanceMode (set_advance_mode)
Turn advance mode on or off. The initial value is off (false).
Ada: SetAdvanceMode( control, bool );
C++: control.set_advance_mode( bool );
Errors: none
GetBlindMode (get_blind_mode)
Return true if blind mode is on.
Ada: bool := GetBlindMode( control );
C++: bool = control.get_blind_mode();
Errors: none
SetBlindMode (set_blind_mode)
Turn blind mode on or off. The initial value is off (false).
Ada: SetBlindMode( control, bool );
C++: control.set_blind_mode( bool );
Errors: none
GetMaxLength (get_max_length)
Return the maximum length of text the edit line can hold.
Ada: len := GetMaxLength( control );
C++: len = control.get_max_length();
Errors: none
SetMaxLength (set_max_length)
Assign the maximum length of text the edit line can hold. The initial value
is the width of the edit control. Assigning a value larger than the width of
the control will have unpredictable results.
Ada: len := GetMaxLength( control );
C++: len = control.get_max_length();
Errors: none
Controls: Specialized Edit Lines
There are several edit lines customized for specific kinds of input.
- Integer Edit Lines: support integers instead of strings
- Long Integer Edit Lines: support long integers instead of strings.
- Float Edit Lines: support floating-point values instead of strings.
They are identical to a standard edit line except that they have GetValue
(get_value) and SetValue (set_value) functions instead of Get/SetText.
Controls: Check Boxes
Check boxes are controls that can be checked off like boxes on a form.
A check box can be true (if checked) or false (if unchecked). If a check
box is turned off (with SetStatus), a hypen indicates that the control
cannot be selected.
[ ] unchecked [X] checked [-] unselectable
GetText (get_text)
Return the text message of the check box.
Ada: s255 := GetText( control );
C++: s255 = control.get_text();
Errors: none
GetCheck (get_check)
Return true if the check box is checked.
Ada: bool := GetCheck( control );
C++: bool = control.get_check();
Errors: none
SetText (set_text)
Change the text message of the check box. The initial value is "Check".
Ada: SetText( control, s255 );
C++: control.set_text( s255 );
Errors: none
SetCheck (set_check)
Check or uncheck the check box. The initial value is undefined.
Ada: SetCheck( control, bool );
C++: control.set_check( bool );
Errors: none
Controls: Radio Buttons
Like a check box, radio buttons can be checked on or off. Radio buttons are
grouped into families so that turning on one radio button will automatically
turn off all others in the family. Users can select one option from a list
of options represented by the button family. When a radio button is turned
off (with SetStatus), a hypen indicates that the control cannot be selected.
(*) Draft quality (checked)
( ) Average quality
( ) Best quality
(-) Unselectable
Because radio buttons belong to families, the Init procedure (or C++
constructor) has a numeric family id.
GetText (get_text)
Return the text message of the radio button.
Ada: s255 := GetText( control );
C++: s255 = control.get_text();
Errors: none
GetCheck (get_check)
Return true if this button is checked.
Ada: bool := GetCheck( control );
C++: bool = control.get_check();
Errors: none
GetFamily (get_family)
Return the numeric family id for this radio button (0 if none).
Ada: id := GetFamily (control );
C++: id = control.get_family();
Errors: none
SetText (set_text)
Changes the text message for the radio button. The initial text is "Radio".
Ada: SetText( control, s255 );
C++: control.set_text( s255 );
Errors: none
SetCheck (set_check)
Check or uncheck the radio button. The initial value is undefined.
Ada: SetCheck( control, bool );
C++: control.set_check( bool );
Errors: none
Controls: Simple Buttons
A simple button is a button that can be selected in order to perform an action.
An "OK button" or a "Cancel button" are examples of simple buttons. When a
simple button is selected, the Window Manager's DoDialog function returns
control to your program. If a simple button is turned off (with SetStatus),
a hypen indicates that the control cannot be selected
< > OK <-> Unselectable
Normally, a simple button will not activate when selected by the user: after
pressing the button hot key, the user presses the Enter/Return key to
activate the button. (A mouse click will automatically activate the button.)
When a simple button is set to "instant", it acts like a menu item: if the
user presses the hot key for the button, it will automatically activate the
button.
| > Menu Item |-> Unselectable
GetText (get_text)
Return the text message of the simple button.
Ada: s255 := GetText( control );
C++: s255 = control.get_text();
Errors: none
SetText (set_text)
Change the text message of the simple button. The initial value is "OK".
Ada: SetText( control, s255 );
C++: control.set_text( s255 );
Errors: none
GetInstant (get_instant)
Return true if the instant hot key activation feature is on.
Ada: bool := GetInstant( control );
C++: bool = control.get_instant();
Errors: none
SetInstant (set_instant)
Turn the instant hot key activation on or off. The initial value is false.
Ada: SetInstant( control, bool );
C++: control.set_instant( bool );
Errors: none
GetColour (get_colour)
Return the colour name of the message text.
Ada: colname := GetColour( control );
C++: colname = control.get_colour();
Errors: none
SetColour (set_colour)
Change the colour name of the colour of the message text.
Ada: SetColour( control, colname );
C++: control.set_colour( colname );
Errors: none
Controls: Window Buttons
A window button is displayed the same as a simple button. Instead of
returning control to the application when activiated, the window button will
try to follow a TextTools URL (often to a window previously saved to a file
using SaveWindow). Use Window buttons to display static screens suck as
on-line help without adding extra work for your application.
To change the URL, use the link iconic control subprograms.
GetText (get_text)
Return the text message of the window button.
Ada: s255 := GetText( control );
C++: s255 = control.get_text();
Errors: none
SetText (set_text)
Change the text message of the window button. The initial value is "Help".
Ada: SetText( control, s255 );
C++: control.set_text( s255 );
Errors: none
GetInstant (get_instant)
Return true if the instant hot key activation feature is on.
Ada: bool := GetInstant( control );
C++: bool = control.get_instant();
Errors: none
SetInstant (set_instant)
Turn the instant hot key activation on or off. The initial value is false.
Ada: SetInstant( control, bool );
C++: control.set_instant( bool );
Errors: none
GetControlHit (get_control_hit)
Used by internally window manager. Restore the control id hit when returning
from a link.
Ada: cid := GetControlHit( control );
C++: cid = control.get_control_hit();
Errors: none
SetColour (set_colour)
Used by internally window manager. Save the control id hit when following
a link.
Ada: SetControlHit( control, cid );
C++: control.set_control_hit( cid );
Errors: none
Controls: Rectangles
A rectangle control draws a rectangle in the window. Although you could draw
a rectangle "manually" with TextTool's rectangle drawing functions, a
rectangle control will be automatically redrawn by the window manager when
needed.
+--------------------+
| |
| |
+--------------------+
Rectangles are often used surround related controls on the screen. Declaration
order is important: rectangles declared after the controls they surround will
be drawn after those controls, erasing them.
Rectangles are normally unselectable and have no hot key (but there's no reason
why they can't because they are normal window controls). The initial status is
off.
SetColours (set_colours)
Set the colour name of the frame and background colour for the rectangle.
The initial values are outline foreground and black background.
Ada: SetColours( control, fore_colname, back_colname );
C++: control.set_colours( fore_colname, back_colname );
Errors: none
GetColours (get_colours)
Return the colour names of the frame and background colour for the
rectangle.
Ada: GetColours( control, fore_colname, back_colname );
C++: control.get_colours( &fore_colname, &back_colname );
Errors: none
Controls: Lines
Link controls, like rectangle controls, are User IO lines that are managed by
the window manager, redrawn on command. Horizontal and vertical lines can be
drawn by controls described below.
The line is drawn either from top-left to bottom-right corner of the control
frame or from the opposite corners.
#
#
#
#
The initial status value is off (the line is not selectable).
SetColour (set_colour)
Change the colour name for the colour of the line.
Ada: SetColour( control, colname );
C++: control.set_colour( colname );
Errors: none
GetColour (get_colour)
Return the colour name of the line colour.
Ada: colname := GetColour( control );
C++: colname = control.get_colour();
Errors: none
SetDrawDir (set_draw_dir);
Select the drawing direction. True is down and to the right. The initial
value is false.
Ada: SetDrawDir( control, bool );
C++: control.set_draw_dir( bool );
Errors: none
Controls: Horizontal and Vertical Separators
Separators are horizontal or vertical lines. Horizontal separators can be
used to separate sets of menu items.
The line colour is always outline for separators. The default status is off
(unselectable). There are no properties that can be set.
Controls: Static Lists
The first kind of list control is a static list. Static lists are a list of
strings that cannot be edited by the user. The list appears in a rectangle
and can be scrolled by the user.
+----------------------------+
| Status log: |
| |
| First item |
+----------------------------+
If a scroll bar is associated with the list, it will be adjusted when the list
is scrolled and vice versa.
Basic Key assignments:
- Up Arrow / Control-J - move up one line
- Down Arrow / Control-K - move down one line
- Home Key / Control-Y - move to top
- End Key / Control-E - move to bottom
- Control-P - Page Up
- Control-N - Page Down
- Control-6 - Set Mark
Since all other list types are subclasses of static lists, there are many
subprograms defined here including search and replace. Programs can use
these features on any list even when keys are not defined for the user.
Basic List Subprograms
SetList (set_list)
Assign the text to the list, a linked list of 255 character strings. If
a list already exists, it will be deallocated first. The initial value is
an empty list.
Ada: SetList( control, str255list );
C++: controls.set_list( str255list );
Errors: none
SetOrigin (set_origin)
Change the origin point for the list (the index of the text line displayed
in the top line of the list control).
Ada: SetOrigin( control, line );
C++: control.set_origin( line );
Errors: none
GetList (get_list)
Return a pointer to the linked list being displayed in the control. It
doesn't make a copy of the list.
Ada: str255list := GetList( control );
C++: str255list = control.get_list();
Errors: none
GetOrigin (get_origin)
Return the origin point for the list (the index of the text line being
displayed in the top of the list control). The first line would be "1".
Ada: linenum := GetOrigin( control );
C++: linenum = control.get_origin( control );
Errors: none
GetCurrent (get_current)
Return the index of the line the cursor is currently on. The first line of
the list would be "1".
Ada: linenum := GetCurrent( control );
C++: linenum = control.get_current();
Errors: none
GetLength (get_length)
Return the number of lines of linked list text in the list control.
Ada: lines := GetLength( control );
C++: lines = control.get_length();
Errors: none
SetScrollBar (set_scroll_bar)
Record the control id for the scroll bar associated with this list.
Ada: SetScrollBar( control, cid );
C++: control.set_scroll_bar( cid );
Errors: none (if the control is not a scroll bar, there will be errors when
the Window Manager attempts to access the control)
GetScrollBar (get_scroll_bar)
Return the control id of the scroll bar associated with this list (0 if none).
Ada: cid := GetScrollBar( control );
C++: cid = control.set_scroll_bar();
Errors: none
Movement and Editing
JustifyText (justify_text)
Attempt to make the text fit into a specific width (usually the width of the
list control) by breaking long lines and concatenating them with following
line. This is performed recursively until the end of the linked list is
reached.
Ada: JustifyText( control, width, startingline );
C++: control.justify_text( width, startingline );
Errors: none (could raise an Ada STORAGE_ERROR exception)
MoveCursor (move_cursor)
Move the cursor to a new position in the list. In static lists, the cursor
is against the left margin no matter what the horizontal value is.
Ada: MoveCursor( control, dx, dy );
C++: control.move_cursor( dx, dy );
Errors: none (the cursor will be constrained to the limits of the list)
CopyLine (copy_line)
Return a copy of the line at the current cursor position in the list.
Ada: s255 := CopyLine( control );
C++: s255 = control.copy_line();
Errors: none
PasteLine (paste_line)
Inserts a line at the current cursor position in the list.
Ada: PasteLine( control, s255 );
C++: control.paste_line( s255 );
Errors: none (could raise an Ada STORAGE_ERROR exception)
FindText (find_text)
Search the linked list from the current position forward looking for a
string. If the regexp flag is true, the string is treated as a regular
expression. If backwards is true, the search will be conducted backwards from
the current position. If found, the search text will be hilighted. If not
found, there will be a failure beep.
Ada: FindText( control, s255, back_bool, regexp_bool := false );
C++: control.find_text( s255, back_book, regexp_bool = false );
Errors: none
ReplaceText (replace_text)
Like FindText, except replace the (first) occurrence of the string with a new
string.
Ada: ReplaceText( control, s255, new_s255, back_bool, regexp_bool := false );
C++: control.replace_text( s255, new_s255, back_book, regexp_bool = false );
Errors: none
SetFindPhrase (set_find_phrase)
Change the list text searched for by FindText. Changing the text to a null
string will turn off the hilighted search text.
Ada: SetFindPhrase( control, s255 );
C++: control.set_find_phrase( s255 );
Errors: none
SetMark (set_mark)
Mark (record) a linked list line. A -1 will remove the last mark.
The marked line will be hilighted. Only one mark can be placed at a time.
Ada: SetMark( control, linenum );
C++: control.set_mark( linenum );
Errors: none
GetMark (get_mark)
Return the last line marked (or -1 if none).
Ada: linenum := GetMark( control );
C++: linenum = control.get_mark();
Errors: non
CopyLines (copy_lines)
Copy a set of linked list lines and return the lines as a new linked list.
The first line to copy must be indicated by SetMark.
Ada: CopyLines( control, last_linenum, str255list );
C++: control.copy_lines( last_linenum, &str255list );
Errors: none (could raise an Ada STORAGE_ERROR exception)
Controls: Check Lists
A check list is a list of check boxes. Like a static list, the list cannot
be edited by the user can select individual boxes in the list. The boxes
are represented as a linked list of booleans.
+----------------------------+
|[#] Red |
|[#] Orange |
|[ ] Blue |
+----------------------------+
The subprograms are the same as static lists except:
SetChecks (set_checks)
Assign a boolean list representing the status of the check boxes. If the
boolean list is shorter than the list of strings, the remaining check boxes
are unselectable.
Ada: SetChecks( control, boolist );
C++: control.set_checks( boolist );
Errors: none
GetChecks (get_checks)
Return a pointer to the boolean list representing the status of the check
boxes.
Ada: boollist := GetChecks( control );
C++: boollist = control.get_checks();
Errors: none
Controls: Radio Lists
A check list is a list of radio buttons. Like a static list, the list cannot
be edited by the user can select individual boxes in the list. The boxes
are represented as a linked list of booleans. The buttons are implicitly
members of the same family.
+----------------------------+
|( ) Surface Mail |
|(*) FedEx |
|( ) UPS |
+----------------------------+
The subprograms are the same as static lists except:
SetChecks (set_checks)
Assign a boolean list representing the status of the check boxes. If the
boolean list is shorter than the list of strings, the remaining check boxes
are unselectable.
Ada: SetChecks( control, boolist );
C++: control.set_checks( boolist );
Errors: none
GetChecks (get_checks)
Return a pointer to the boolean list representing the status of the check
boxes. Only one boolean will be true.
Ada: boollist := GetChecks( control );
C++: boollist = control.get_checks();
Errors: none
GetCheck (get_check)
Return the button checked.
Ada: linenum := GetCheck( control );
C++: linenum = control.get_check();
Errors: none
Controls: Edit Lists
Edit lists contain lists of text that can be edited by the user. There is
a special edit list for source code editing.
The subprograms are the same as static lists except:
GetPosition (get_position)
Return the position in the list (the line and the character).
Ada: GetPosition( control, x, y );
C++: control.get_postion( &x, &y );
Errors: none
SetCursor (set_cursor)
Move the cursor to an exact position (MoveCursor uses a relative position).
Ada: SetCursor( control, x, y );
C++: control.set_cursor( x, y );
Errors: none (the cursor is constrained to reasonable positions)
Touch (touch)
Mark the text as changed (this is done automatically if the user changes
text).
Ada: Touch( control );
C++: control.touch():
Errors: none
ClearTouch (clear_touch)
Clear the touch flag so that the text doesn't need saving.
Ada: ClearTouch( control );
C++: control.clear_touch();
Errors: none
WasTouched (was_touched)
True if the text was touched (needs saving because it was changed).
Ada: b := WasTouched( control );
C++: b = control.was_touched();
Errors: none
Controls: Source Edit List
This is the list control used by PegaSoft's TIA IDE. It is designed to hold
programmer source code. It has all the features of an edit list but also
has keyword hilighting.
AddKeyword (add_keyword)
Add a word to the list of keywords to be hilighted. TextTools will only
hilight the word if it is separated from the rest of the text by spaces or
punctuation symbols.
Ada: AddKeyword( control, s255 );
C++: control.add_keyword( str255 );
Errors: none (could raise an Ada STORAGE_ERROR exception)
ClearKeywords (clear_keywords)
Remove all keywords.
Ada: ClearKeyword( control );
C++: control.clear_keywords();
Errors: none
Unfinished Controls
These controls are not complete:
- SimplePicture: ASCII art "bit-mapped" picture
- Picture: ASCII art "bit-mapped" picture, different "resolutions"
- Sketch: pre-recorded set of User IO drawing operations
- Animation: animated picture or sketch
- HTML Box: a web page
Window Manager
This section to be written
End of Document
texttools/build-lib-dynamic/ 0000775 0000764 0000764 00000000000 11774716122 014546 5 ustar ken ken texttools/build-obj-dynamic/ 0000775 0000764 0000764 00000000000 11774716122 014552 5 ustar ken ken texttools/template_for_installed_project 0000664 0000764 0000764 00000003001 11774715706 017453 0 ustar ken ken -- Texttools project file
-- Copyright (c) 2004, 2006, 2008 Ludovic Brenta
-- Copyright (C) 2007-2012 Nicolas Boulenguez
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see .
-- This project file is designed to help build applications that use
-- $(LIB_NAME). Here is an example of how to use this project file:
--
-- with "$(LIB_NAME)";
-- project Example is
-- for Object_Dir use "obj";
-- for Exec_Dir use ".";
-- for Main use ("example");
-- end Example;
project $(LIB_NAME) is
for Library_Name use "$(LIB_NAME)";
for Library_Kind use "dynamic";
for Source_Dirs use ("/$(SRC_DIR)/$(LIB_NAME)");
for Library_ALI_Dir use "/$(ALI_DIR)/$(LIB_NAME)";
for Library_Dir use "/$(LIB_DIR)";
for Externally_Built use "true";
package Linker is
for Linker_Options use ("$(LDLIBS)");
end Linker;
end $(LIB_NAME);
texttools/README 0000664 0000764 0000764 00000003543 11774423543 012150 0 ustar ken ken TextTools 2.1.0
Copyright (c) 1999-2012 PegaSoft Canada.
Designed and Programmed by Nicolas Boulenguez and Ken O. Burtch
Home Page: http://www.pegasoft.ca/tt.html
The Texttools packages are a GPL, ncurses-based library for the Linux
console. Texttools contain more than 600 procedures and functions to
create windows, draw scroll bars, handle the mouse and keyboard events,
play sounds, and much more. The Texttools package also provides a
thick binding to Linux kernel calls. You can create a wide
variety of application programs using Texttools alone.
TextTools is written in Ada 95 and C. You'll need to download the
Gnat compiler to use TextTools. You can write prograns in Ada or C++
that use TextTools.
DOCUMENTATION
usermanual.html - the TextTools User Manual
refmanual.html - the TextTools Reference Manual
RECENT CHANGES
The change logs are now online at the PegaSoft Linux Cafe
http://www.pegasoft.ca/docs/discus/index.html.
Version 2.1.0 has a new build process and conversion from bounded strings
to unbounded strings. The gen_list generic linked list package has been
deprecated in favour of the standard Ada list packages introduced in Ada 2005.
TIA 1.2.2 will not build with Texttools 2.1.0 due to these changes.
INSTALLATION
1. Install the GNAT compiler and the GNAT Project Studio.
3. Edit C_code/curses.c If you are using NCURSES3, uncomment the NCURSES3
define. If using NCURSES4, comment out the NCURSES5 define.
4. Type "make test" in the topmost Texttools directory.
5. Test the examples by running them. (For example, in an xterm window.)
If you are interested, type "make install" will make all development
tools available system-wide on your computer, see
$(DESTDIR)/usr/share/ada/adainclude/texttools.gpr for an example.
The cpp directory contains C++ examples. C++ support is incomplete.
The examples directory contains Ada examples.
texttools/src/ 0000775 0000764 0000764 00000000000 11774715706 012057 5 ustar ken ken texttools/src/controls.adb 0000664 0000764 0000764 00000441645 11774715706 014410 0 ustar ken ken ------------------------------------------------------------------------------
-- CONTROLS - Texttools control (widget) definitions --
-- --
-- Developed by Ken O. Burtch --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 PegaSoft Canada --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with Ada.Containers;
with os; use os; -- for SessionLog debug
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants;
with GNAT.RegExp; use GNAT.RegExp;
with ada.finalization; use Ada.Finalization;
with Ada.Unchecked_Deallocation;
with Ada.Environment_Variables;
-- Will be Ada.Strings.Fixed.Equal_Case_Insensitive one day.
with Equal_Case_Insensitive;
package body controls is
PackageRunning : boolean := false; -- true if package has been started
pragma suppress( range_check );
DisplayInfo : ADisplayInfoRec; -- display characteristics
IsConsoleEmu : boolean; -- true if TERM = linux or console
IsMonoXEmu : boolean; -- true if TERM = xterm
IsColourXEmu : boolean; -- true if TERM = xterm-color
-- For AutoSpell, strings used by AutoSpell
--
Strings_Used_By_Autospell : constant array (Positive range <>) of Unbounded_String
:= (To_Unbounded_String ("procedure"),
To_Unbounded_String ("function"),
To_Unbounded_String ("package"),
To_Unbounded_String ("exception"),
To_Unbounded_String ("terminate"),
To_Unbounded_String ("subtype"),
To_Unbounded_String ("end"),
To_Unbounded_String ("end if;"),
To_Unbounded_String ("end loop;"),
To_Unbounded_String ("end record;"),
To_Unbounded_String ("then"),
To_Unbounded_String ("else"),
To_Unbounded_String ("loop"));
---> Imports
--
-- Required for thermometers (used for Scroll Bar, too)
procedure CTextStyle( c1, c2, c3 : character );
pragma Import( C, CTextStyle, "CTextStyle" );
---> Source Edit Language Support
procedure init( languageData: in out languageDataArray ) is
begin
-- clear linked lists
for l in aSourceLanguage'range loop
for ch in keywordArray'range loop
languageData(l).functionBin( ch ) := null;
end loop;
for ch in keywordArray'range loop
languageData(l).keywordBin( ch ) := null;
end loop;
end loop;
-- specify language case sensitivity (default is not sensitive)
languageData( UNKNOWNLANGUAGE ).caseSensitive := true;
languageData( BUSH ).caseSensitive := true;
languageData( C ).caseSensitive := true;
languageData( CPP ).caseSensitive := true;
languageData( JAVA ).caseSensitive := true;
languageData( SHELL ).caseSensitive := true;
languageData( C ).commentStyle := CStyle;
languageData( CPP ).commentStyle := CStyle;
languageData( UNKNOWNLANGUAGE ).commentStyle := AdaStyle;
languageData( ADA_LANGUAGE ).commentStyle := AdaStyle;
languageData( BUSH ).commentStyle := AdaStyle;
languageData( PERL ).commentStyle := ShellStyle;
languageData( PHP ).commentStyle := PHPStyle;
languageData( HTML ).commentStyle := HTMLStyle;
languageData( SHELL ).commentStyle := ShellStyle;
end init;
procedure Slice (Inside : in StrList.Vector;
From : in Positive;
Length : in Natural;
Result : in out StrList.Vector) is
begin
Result.Clear;
Result.Reserve_Capacity (Ada.Containers.Count_Type (Length));
for I in From .. From + Length - 1 loop
Result.Append (Inside.Element (From));
end loop;
end Slice;
procedure Slice (Inside : in BooleanList.Vector;
From : in Positive;
Length : in Natural;
Result : in out BooleanList.Vector) is
begin
Result.Clear;
Result.Reserve_Capacity (Ada.Containers.Count_Type (Length));
for I in From .. From + Length - 1 loop
Result.Append (Inside.Element (From));
end loop;
end Slice;
-- IN BIN
--
-- Determine which bin string s will be stored in. The bins are
-- case-insensitive.
------------------------------------------------------------------------------
function in_bin( s : in string ) return aBinIndex is
begin
if S'Length = 0 then
return aBinIndex'first;
end if;
case S (S'First) is
when 'A'..'Z' =>
return S (S'First);
when 'a'..'z' =>
return character'Val (character'Pos (S(S'First)) - 32 );
when others =>
return aBinIndex'first;
end case;
end in_bin;
-- FIND FUNCTION DATA
--
-- Find data on a language's function by looking it up in the language data
-- record. Returns null if function doesn't exist.
------------------------------------------------------------------------------
function findFunctionData( languageData : languageDataArray; funcLang : aSourceLanguage; s : in string ) return functionDataPtr is
fp : functionDataPtr := null;
begin
if s'length = 0 then
fp := null;
else
fp := languageData( funcLang ).functionBin( in_bin( s ) );
while fp /= null loop
if languageData( funcLang ).caseSensitive then
if fp.all.FunctionName.all = s then
exit;
end if;
else
if fp.all.functionName.all = Ada.Characters.Handling.To_Lower (s) then
exit;
end if;
end if;
fp := fp.all.next;
end loop;
end if;
return fp;
exception when ada.strings.length_error => -- string too long?
SessionLog( "findFunctionData: length_error raised" );
return null;
when others =>
SessionLog( "findKeywordData: unknown exception raised" );
raise;
end findFunctionData;
-- FIND KEYWORD DATA
--
-- Find data on a language's keyword by looking it up in the language data
-- record. Returns null if keyword doesn't exist.
------------------------------------------------------------------------------
function findKeywordData( languageData : languageDataArray; funcLang : aSourceLanguage; s : string ) return keywordDataPtr is
kp : keywordDataPtr := null;
begin
if s'length = 0 then
kp := null;
else
kp := languageData( funcLang ).keywordBin( in_bin( s ) );
while kp /= null loop
if languageData( funcLang ).caseSensitive then
if kp.all.keywordName.all = s then
exit;
end if;
else
if kp.all.keywordName.all = Ada.Characters.Handling.To_Lower (s) then
exit;
end if;
end if;
kp := kp.all.next;
end loop;
end if;
return kp;
exception when ada.strings.length_error => -- string too long?
SessionLog( "findKeywordData: length_error raised" );
return null;
when others =>
SessionLog( "findKeywordData: unknown exception raised" );
raise;
end findKeywordData;
---> Housekeeping
procedure StartupControls is
-- Initialize this package, set defaults
begin
NoError;
-- if package is already running, don't start again
if PackageRunning then
return;
end if;
-- look up information on the display
GetDisplayInfo( DisplayInfo );
-- discover terminal emulation
IsConsoleEmu := false;
IsMonoXEmu := false;
IsColourXEmu := false;
if Ada.Environment_Variables.Exists ("TERM") then
declare
Termemu : constant String := Ada.Environment_Variables.Value ("TERM");
begin
if TermEmu = "linux" or TermEmu = "console" then
IsConsoleEmu := true;
SessionLog( "StartupControls: optimized for linux console emulation" );
elsif TermEmu = "xterm" or Termemu = "xterm-color" then
if DisplayInfo.C_Res = 0 then
IsMonoXEmu := true;
SessionLog( "StartupControls: optimized for monochrome X emulation" );
else
SessionLog( "StartupControls: optimized for colour X emulation" );
IsColourXEmu := true;
end if;
end if;
end;
end if;
PackageRunning := true;
end StartupControls;
procedure IdleControls( IdlePeriod : in Duration ) is
pragma Unreferenced (IdlePeriod);
begin
NoError;
end IdleControls;
procedure ShutdownControls is
-- Shut down this package
begin
NoError;
PackageRunning := false;
end ShutdownControls;
procedure FreeControlPtr is new Ada.Unchecked_Deallocation( RootControl'class,
AControlPtr );
procedure Free( cp : in out AControlPtr ) is
begin
FreeControlPtr( cp ); -- dispatch
end Free;
-- Utilities
procedure DrawHotKey( x, y : integer; key : character ) is
begin
MoveToGlobal( x, y );
if IsConsoleEmu or IsColourXEmu then
-- Linux VGA console and colour X don't show underline
CTextStyle( 'y', 'n', 'n' );
else
-- else do underlining
CTextStyle( 'n', 'n', 'y' );
end if;
Draw( key );
CTextStyle( 'n', 'n', 'n' );
end DrawHotKey;
---> Window Control Implementations
---> Inits
--
-- Initialize a control's variables to default values. Assign the
-- frame and hot key as given by the caller.
procedure Init( c : in out RootControl;
left, top, right, bottom : integer; HotKey : character ) is
begin
NoError;
SetRect( c.frame, left, top, right, bottom );
c.CursorX := 0;
c.CursorY := 0;
c.Status := Standby;
c.NeedsRedrawing := true;
c.HotKey := HotKey;
c.HasInfo := false;
c.InfoText := Null_Unbounded_String;
c.StickLeft := false;
c.StickTop := false;
c.StickRight := false;
c.StickBottom := false;
c.Scrollable := true;
end Init; -- RootControl
procedure Init( c : in out AnIconicControl;
left, top, right, bottom : integer; HotKey : character ) is
begin
Init( RootControl( c ), left, top, right, bottom, HotKey );
c.Link := Null_Unbounded_String;
end Init; -- IconicControl
procedure Init(c : in out AWindowControl;
left, top, right, bottom : integer; HotKey : character ) is
begin
Init( RootControl( c ), left, top, right, bottom, HotKey );
end Init; -- WindowControl
procedure Init( c : in out AThermometer;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
c.Value := 0;
c.Max := 0;
end Init; -- AThermometer
procedure Init( c : in out AScrollBar;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
c.owner := 0;
c.DirtyThumb := false;
c.Thumb := 0;
c.Max := 0;
end Init; -- AScrollBar
procedure Init( c : in out AStaticLine;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AnIconicControl( c ), left, top, right, bottom, HotKey );
c.Status := Off;
c.Style := Normal;
c.Colour := none;
end Init; -- AStaticLine
procedure Init( c : in out AnEditLine;
left, top, right, bottom : integer; Max : natural := 0;
HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
c.text := Null_Unbounded_String;
if c.Max = 0 then
c.Max := right - left + 1;
else
c.Max := Max;
end if;
c.AdvanceMode := false;
c.BlindMode := false;
c.DirtyText := false;
c.MaxLength := c.frame.right - c.frame.left + 1;
end Init; -- AnEditLine
procedure Init( c : in out AnIntegerEditLine;
left, top, right, bottom : integer; Max : natural := 0;
HotKey : character := NullKey ) is
begin
Init( AnEditLine( c ), left, top, right, bottom, Max, HotKey );
c.value := 0;
c.MaxLength := integer'width;
end Init; -- AnIntegerEditLine
procedure Init( c : in out ALongIntEditLine;
left, top, right, bottom : integer; Max : natural := 0;
HotKey : character := NullKey ) is
begin
Init( AnEditLine( c ), left, top, right, bottom, Max, HotKey );
c.value := 0;
c.MaxLength := long_integer'width;
end Init; -- ALongIntEditLine
procedure Init( c : in out AFloatEditLine;
left, top, right, bottom : integer; Max : natural := 0;
HotKey : character := NullKey ) is
begin
Init( AnEditLine( c ), left, top, right, bottom, Max, HotKey );
c.value := 0.0;
end Init; -- AFloatEditLine
procedure Init( c : in out ACheckBox;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
c.CursorX := 1;
Set_Unbounded_String (C.Text, "Check");
c.HotPos := 0;
end Init; -- ACheckBox
procedure Init( c : in out ARadioButton;
left, top, right, bottom : integer;
Family : integer := 0; HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
c.CursorX := 1;
c.Family := Family;
Set_Unbounded_String (C.Text, "Radio");
c.HotPos := 0;
end Init; -- ARadioButton
procedure Init( c : in out ASimpleButton;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
c.CursorX := 1;
Set_Unbounded_String (C.Text, "OK");
c.Instant := false;
c.HotPos := 0;
c.Colour := none;
end Init; -- ASimpleButton
procedure Init( c : in out AWindowButton;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AnIconicControl( c ), left, top, right, bottom, HotKey );
c.CursorX := 1;
Set_Unbounded_String (C.Text, "Help");
c.Instant := false;
c.HotPos := 0;
end Init; -- AWindowButton
procedure Init( c : in out ARectangle;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AnIconicControl( c ), left, top, right, bottom, HotKey );
c.Status := off;
c.FrameColour := Outline;
c.BackColour := Black;
c.Text := Null_Unbounded_String;
end Init; -- ARectangle
procedure Init( c : in out ALine'class;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AnIconicControl( c ), left, top, right, bottom, HotKey );
c.Status := Off;
c.Colour := Outline;
c.DownRight := true;
end Init; -- ALine
procedure Init( c : in out AStaticList;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AWindowControl( c ), left, top, right, bottom, HotKey );
C.List.Clear;
c.Origin := 0;
c.CursorX := 1;
c.CursorY := 1;
c.ScrollBar := 0;
c.Mark := -1;
end Init; -- AStaticList
procedure Init( c : in out ACheckList;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AStaticList( c ), left, top, right, bottom, HotKey );
C.Checks.Clear;
end Init; -- ACheckList
procedure Init( c : in out ARadioList;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AStaticList( c ), left, top, right, bottom, HotKey );
C.Checks.Clear;
c.LastCheck := 0;
end Init; -- ARadioList
procedure Init( c : in out AnEditList;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AStaticList( c ), left, top, right, bottom, HotKey );
c.DirtyLine := false;
end Init; -- ACheckList
procedure Init( c : in out ASourceEditList;
left, top, right, bottom : integer; HotKey : character := NullKey ) is
begin
Init( AStaticList( c ), left, top, right, bottom, HotKey );
c.KeywordList.Clear;
c.InsertedFirst := 0;
c.InsertedLines := 0;
end Init; -- ACheckList
---> Finalizations (formerly Clears)
--
-- Deallocate memory, etc. for the control
procedure Finalize( c : in out RootControl ) is
begin
NoError;
c.NeedsRedrawing := true;
end Finalize; -- RootControl
procedure Finalize( c : in out AnIconicControl ) is
begin
Finalize( RootControl( c ) );
c.link := Null_Unbounded_String;
end Finalize; -- AnIconicControl;
procedure Finalize( c : in out AWindowControl ) is
begin
Finalize( RootControl( c ) );
end Finalize; -- AWindowControl;
procedure Finalize( c : in out AThermometer ) is
begin
Finalize( AWindowControl( c ) );
end Finalize; -- AThermometer
procedure Finalize( c : in out AScrollBar ) is
begin
Finalize( AWindowControl( c ) );
end Finalize; -- AScrollBar
procedure Finalize( c : in out AStaticLine ) is
begin
Finalize( AnIconicControl( c ) );
end Finalize; -- AStaticLine
procedure Finalize( c : in out AnEditLine'class ) is
begin
Finalize( AWindowControl( c ) );
end Finalize; -- AnEditLine
procedure Finalize( c : in out ACheckBox ) is
begin
Finalize( AWindowControl( c ) );
end Finalize; -- ACheckBox
procedure Finalize( c : in out ARadioButton ) is
begin
Finalize( AWindowControl( c ) );
end Finalize; -- ARadioButton
procedure Finalize( c : in out ASimpleButton ) is
begin
Finalize( AWindowControl( c ) );
end Finalize; -- ASimpleButton
procedure Finalize( c : in out AWindowButton ) is
begin
Finalize( AnIconicControl( c ) );
end Finalize; -- AWindowButton
procedure Finalize( c : in out ARectangle ) is
begin
Finalize( AnIconicControl( c ) );
end Finalize; -- ARectangle
procedure Finalize( c : in out ALine'class ) is
begin
Finalize( AnIconicControl( c ) );
end Finalize; -- ALine
procedure Finalize( c : in out AStaticList ) is
begin
c.List.Clear;
Finalize( AWindowControl( c ) );
end Finalize; -- AStaticList
procedure Finalize( c : in out ACheckList ) is
begin
Finalize( AStaticList( c ) );
end Finalize; -- ACheckList
procedure Finalize( c : in out ARadioList ) is
begin
C.Checks.Clear;
Finalize( AStaticList( c ) );
end Finalize; -- ARadioList
procedure Finalize( c : in out AnEditList ) is
begin
Finalize( AStaticList( c ) );
end Finalize; -- AnEditList
procedure Finalize( c : in out ASourceEditList ) is
begin
c.KeywordList.Clear;
Finalize( AnEditList( c ) );
end Finalize; -- ASourceEditList
---> Common Calls
function GetHotPos( HotKey : character; thetext : in string) return natural is
-- find position in string of the "Hot Key" character, else 0
-- no check for out of bounds
begin
if HotKey = NullKey then
return 0;
else
return Ada.Strings.Fixed.Index
(Source => Thetext,
Pattern => (1 => Hotkey),
Mapping => Ada.Strings.Maps.Constants.Lower_Case_Map);
end if;
end GetHotPos;
procedure Invalid( c : in out RootControl'class ) is
-- mark a control as dirty (ie. needs redrawing)
begin
NoError;
c.NeedsRedrawing := true;
end Invalid;
function NeedsRedrawing( c : RootControl'class ) return boolean is
-- return dirty flag
begin
NoError;
return c.NeedsRedrawing;
end NeedsRedrawing;
procedure Move( c : in out RootControl'class; dx, dy : integer ) is
begin
NoError;
OffsetRect( c.frame, dx, dy );
Invalid( c );
end Move;
function GetHotKey( c : in RootControl'class ) return character is
-- return hot key
begin
NoError;
return c.HotKey;
end GetHotKey;
procedure SetInfo( c : in out RootControl'class; text : in string ) is
-- Set info bar text
begin
NoError;
c.HasInfo := true;
Set_Unbounded_String (C.InfoText, Text);
end SetInfo;
function GetInfo( c : in RootControl'class ) return string is
-- return info bar text
begin
NoError;
return To_String (C.InfoText);
end GetInfo;
function HasInfo( c : in RootControl'class ) return boolean is
-- true if info bar text as assigned
begin
NoError;
return c.HasInfo;
end HasInfo;
procedure GetStickyness( c : in RootControl'class; left, top, right, bottom
: in out boolean ) is
-- return true for each direction that's sticky
begin
NoError;
left := c.StickLeft;
top := c.StickTop;
right:= c.StickRight;
bottom := c.StickBottom;
end GetStickyness;
procedure SetStickyness( c : in out RootControl'class; left, top, right,
bottom : boolean ) is
-- set stickyness for each direction
begin
NoError;
c.StickLeft := left;
c.StickTop := top;
c.StickRight := right;
c.StickBottom := bottom;
end SetStickyness;
function InControl( c : in RootControl'class; x, y : integer )
return boolean is
begin
return InRect( x, y, c.frame );
end InControl;
function GetFrame( c : in RootControl'class ) return ARect is
begin
return c.frame;
end GetFrame;
procedure Scrollable( c : in out RootControl'class; b : boolean ) is
begin
c.scrollable := b;
end Scrollable;
function CanScroll( c : in RootControl'class ) return boolean is
begin
return c.scrollable;
end CanScroll;
---> Iconic control calls
procedure SetLink( c : in out AnIconicControl'class; link : in string ) is
-- Set the pathname of the window the iconic control refers to
begin
Set_Unbounded_String (C.Link, Link);
c.NeedsRedrawing := true;
end SetLink;
function GetLink( c : in AnIconicControl'class ) return string is
-- Return pathname to the window the iconic control refers to
begin
return To_String (C.Link);
end GetLink;
procedure SetCloseBeforeFollow( c : in out AnIconicControl'class;
close : boolean := true ) is
begin
c.CloseBeforeFollow := close;
end SetCloseBeforeFollow;
function GetCloseBeforeFollow( c : in AnIconicControl'class ) return boolean
is
begin
return c.CloseBeforeFollow;
end GetCloseBeforeFollow;
---> Thermometer Calls
procedure SetMax( c : in out AThermometer; max : integer ) is
begin
NoError;
if c.Max < 0 then
c.Max := 0;
else
c.max := max;
end if;
c.NeedsRedrawing := true;
end SetMax;
function GetMax( c : in AThermometer ) return integer is
begin
NoError;
return c.max;
end GetMax;
procedure SetValue( c : in out AThermometer; value : integer ) is
begin
NoError;
if c.Value < 0 then
c.Value := 0;
else
c.value := value;
end if;
c.NeedsRedrawing := true;
end SetValue;
function GetValue( c : in AThermometer ) return integer is
begin
NoError;
return c.value;
end GetValue;
---> Scroll Bar Calls
procedure SetMax( c : in out AScrollBar; max : in integer ) is
begin
NoError;
if c.Max < 0 then
c.Max := 0;
else
c.max := max;
end if;
c.NeedsRedrawing := true;
end SetMax;
function GetMax( c : in AScrollBar ) return integer is
begin
NoError;
return c.max;
end GetMax;
procedure SetThumb( c : in out AScrollBar; thumb : in integer ) is
begin
NoError;
if Thumb < 0 then
c.thumb := 0;
else
c.thumb := thumb;
end if;
c.DirtyThumb := true;
end SetThumb;
function GetThumb( c : in AScrollBar ) return integer is
begin
NoError;
return c.thumb;
end GetThumb;
procedure SetOwner( c : in out AScrollBar; Owner : AControlNumber ) is
begin
NoError;
c.owner := owner;
end SetOwner;
function GetOwner( c : in AScrollBar ) return AControlNumber is
begin
NoError;
return c.owner;
end GetOwner;
---> Static Line Calls
procedure SetText( c : in out AStaticLine; text : in String) is
begin
NoError;
if c.text /= text then
Set_Unbounded_String (C.Text, Text);
c.NeedsRedrawing := true;
end if;
end SetText;
function GetText( c : in AStaticLine ) return String is
begin
NoError;
return To_String (C.Text);
end GetText;
procedure SetStyle( c : in out AStaticLine ; style : ATextStyle ) is
begin
NoError;
if c.style /= style then
c.style := style;
c.NeedsRedrawing := true;
end if;
end SetStyle;
function GetStyle( c : in AStaticLine ) return ATextStyle is
begin
NoError;
return c.style;
end GetStyle;
procedure SetColour( c : in out AStaticLine; colour : APenColourName ) is
begin
NoError;
if c.colour /= colour then
c.colour := colour;
c.needsRedrawing := true;
end if;
end SetColour;
function GetColour( c : in AStaticLine ) return APenColourName is
begin
NoError;
return c.colour;
end GetColour;
---> Edit Line Calls
procedure SetText( c : in out AnEditLine'class; text : in String) is
begin
NoError;
if c.text /= text then
c.text := To_Unbounded_String (Text);
c.NeedsRedrawing := true;
c.cursorX := 0;
end if;
end SetText;
function GetText( c : in AnEditLine'class ) return String is
begin
NoError;
return To_String (C.Text);
end GetText;
procedure SetAdvanceMode( c : in out AnEditLine'class; mode : boolean ) is
begin
NoError;
c.AdvanceMode := mode;
end SetAdvanceMode;
function GetAdvanceMode( c : in AnEditLine'class ) return boolean is
begin
NoError;
return c.AdvanceMode;
end GetAdvanceMode;
procedure SetBlindMode( c : in out AnEditLine'class; mode : boolean ) is
begin
NoError;
c.NeedsRedrawing := c.NeedsRedrawing or (mode xor c.BlindMode);
c.BlindMode := mode;
end SetBlindMode;
function GetBlindMode( c : in AnEditLine'class ) return boolean is
begin
NoError;
return c.BlindMode;
end GetBlindMode;
procedure SetMaxLength( c : in out AnEditLine'class; MaxLength : integer ) is
begin
NoError;
c.MaxLength := MaxLength;
end SetMaxLength;
function GetMaxLength( c : in AnEditLine'class ) return integer is
begin
NoError;
return c.MaxLength;
end GetMaxLength;
---> Integer Edit Lines
procedure SetValue( c : in out AnIntegerEditLine; value : integer ) is
begin
NoError;
c.value := value;
end SetValue;
function GetValue( c : in AnIntegerEditLine ) return integer is
begin
NoError;
return integer'Value (To_String (C.Text));
exception when others => return 0;
end GetValue;
---> Long Integer Edit Lines
procedure SetValue( c : in out ALongIntEditLine; value : in Long_Integer ) is
begin
NoError;
c.value := value;
end SetValue;
function GetValue( c : in ALongIntEditLine ) return Long_Integer is
begin
NoError;
return Long_Integer'value( To_String( c.Text ) );
exception when others => return 0;
end GetValue;
---> Float Edit Lines
procedure SetValue( c : in out AFloatEditLine; value : float ) is
begin
NoError;
c.value := value;
end SetValue;
function GetValue( c : in AFloatEditLine ) return float is
begin
NoError;
return c.value;
end GetValue;
---> Check Box Calls
procedure SetText( c : in out ACheckBox; text : in String ) is
begin
NoError;
if c.text /= text then
c.NeedsRedrawing := true;
c.text := To_Unbounded_String (Text);
c.HotPos := GetHotPos( c.HotKey, text );
end if;
end SetText;
function GetText( c : in ACheckBox ) return String is
begin
NoError;
return To_String (C.Text);
end GetText;
procedure SetCheck( c : in out ACheckBox; checked : boolean ) is
begin
NoError;
c.NeedsRedrawing := c.NeedsRedrawing or c.checked /= checked;
c.checked := checked;
end SetCheck;
function GetCheck( c : in ACheckBox ) return boolean is
begin
NoError;
return c.checked;
end GetCheck;
---> Radio Button Calls
procedure SetText( c : in out ARadioButton; text : in String) is
begin
NoError;
if c.text /= text then
c.text := To_Unbounded_String (Text);
c.HotPos := GetHotPos( c.HotKey, text );
c.NeedsRedrawing := true;
end if;
end SetText;
function GetText( c : in ARadioButton ) return String is
begin
NoError;
return To_String (C.Text);
end GetText;
procedure SetCheck( c : in out ARadioButton; checked : boolean ) is
begin
NoError;
c.NeedsRedrawing := c.NeedsRedrawing or c.checked /= checked;
c.checked := checked;
end SetCheck;
function GetCheck( c : in ARadioButton ) return boolean is
begin
NoError;
return c.Checked;
end GetCheck;
function GetFamily( c : in ARadioButton ) return integer is
begin
NoError;
return c.Family;
end GetFamily;
---> Simple Button Calls
procedure SetText( c : in out ASimpleButton; text : in String) is
begin
NoError;
if c.text /= text then
Set_Unbounded_String (C.Text, Text);
c.HotPos := GetHotPos( c.HotKey, text );
c.NeedsRedrawing := true;
end if;
end SetText;
function GetText( c : in ASimpleButton ) return String is
begin
NoError;
return To_String (C.Text);
end GetText;
procedure SetInstant( c : in out ASimpleButton; instant : boolean := true ) is
begin
NoError;
if c.Instant /= Instant then
c.Instant := Instant;
c.NeedsRedrawing := true;
end if;
end SetInstant;
function GetInstant( c : in ASimpleButton ) return boolean is
begin
NoError;
return c.Instant;
end GetInstant;
procedure SetColour( c : in out ASimpleButton; colour : APenColourName ) is
begin
NoError;
if c.colour /= colour then
c.colour := colour;
c.NeedsRedrawing := true;
end if;
end SetColour;
function GetColour( c : in ASimpleButton ) return APenColourName is
begin
NoError;
return c.colour;
end GetColour;
---> Window Button Calls
procedure SetText( c : in out AWindowButton; text : in String) is
begin
NoError;
if c.text /= text then
Set_Unbounded_String (C.Text, Text);
c.HotPos := GetHotPos( c.HotKey, text );
c.NeedsRedrawing := true;
end if;
end SetText;
function GetText( c : in AWindowButton ) return String is
begin
NoError;
return To_String (C.Text);
end GetText;
procedure SetInstant( c : in out AWindowButton; instant : boolean := true ) is
begin
NoError;
c.instant := Instant;
end SetInstant;
function GetInstant( c : in AWindowButton ) return boolean is
begin
NoError;
return c.instant;
end GetInstant;
procedure SetControlHit( c : in out AWindowButton; chit : AControlNumber ) is
begin
NoError;
c.chit := chit;
end SetControlHit;
function GetControlHit( c : in AWindowButton ) return AControlNumber is
begin
NoError;
return c.chit;
end GetControlHit;
---> Rectangles
procedure SetColours( c : in out ARectangle;
FrameColour, BackColour : APenColourName ) is
begin
NoError;
c.FrameColour := FrameColour;
c.BackColour := BackColour;
c.NeedsRedrawing := true;
end SetColours;
procedure GetColours( c : in ARectangle;
FrameColour, BackColour : in out APenColourName ) is
begin
NoError;
FrameColour := c.FrameColour;
BackColour := c.BackColour;
end GetColours;
procedure SetText( c : in out ARectangle; text: in string) is
begin
NoError;
Set_Unbounded_String (C.Text, Text); -- assign new text
c.NeedsRedrawing := true;
end SetText;
function GetText( c : ARectangle) return string is
begin
NoError;
return To_String (C.Text);
end GetText;
---> Lines
procedure SetColour( c : in out ALine'class; Colour : APenColourName ) is
begin
NoError;
c.Colour := Colour;
end SetColour;
function GetColour( c : in ALine'class ) return APenColourName is
begin
NoError;
return c.Colour;
end GetColour;
procedure SetDrawDir( c : in out ALine; DownRight : boolean ) is
begin
NoError;
c.DownRight := DownRight;
end SetDrawDir;
function GetDrawDir( c : in ALine ) return boolean is
begin
NoError;
return c.DownRight;
end GetDrawDir;
---> Static Lists
procedure SetList( c : in out AStaticList'class; list : in out StrList.Vector ) is
begin
NoError;
C.List := List;
if not C.List.Is_Empty then
c.origin := 1;
else
c.origin := 0;
end if;
c.CursorY := 1;
c.Mark := -1; -- mark no longer valid
c.NeedsRedrawing := true;
end SetList;
function GetList( c : in AStaticList'class ) return StrList.Vector is
begin
NoError;
return c.list;
end GetList;
-- CROP TEXT
--
-- Crop long lines, returning the amount that won't fit in overflow.
-- Utility procedure for JustifyText.
procedure CropText (text : in out unbounded_string;
overflow: out unbounded_string;
width : in integer ) is
CropIndex : integer;
ch : character;
begin
CropIndex := length( text ); -- start at right end
<> while CropIndex > 0 loop -- unless we run out
ch := Element( text, CropIndex );
exit when ch = ' '; -- stop looking at a space
CropIndex := CropIndex - 1; -- else keep backing left
end loop;
if CropIndex = 0 then -- hard break
Overflow := Tail( text, length(text) - width );
Delete( text, width+1, length( text ));
elsif CropIndex > Width then -- not good enough?
CropIndex := CropIndex - 1; -- keep backing left
goto Crop;
else -- normal break (on a space)
Overflow := Tail( text, length( text ) - CropIndex );
Delete( text, CropIndex + 1, length( text ) ); -- leave space
end if;
exception when others =>
DrawErrLn;
DrawErr( "CropText exception: Info dumped to session log" );
SessionLog( "CropText exception" );
SessionLog( "text=" ); SessionLog( To_String (Text));
SessionLog( "overflow=" ); SessionLog( To_String (Overflow));
raise;
end CropText;
------------------------------------------------------------------------------
-- JUSTIFY TEXT (Static)
--
-- Crop long lines and wrap text in a static list control. Understands that
-- blank lines and indented words are new paragraphs. If one line is
-- justified, only continue until the text is adjust for that one line.
-- Otherwise, continue to check all lines in the document.
--
-- width => width of the window to justify to
-- startingAt = 0 => Justify entire document, else the line to justify
-- ToDo: Recursive Justify when overflow exceeds max line length
procedure JustifyText( c : in out AStaticList;
width : integer;
startingAt : Natural := 0 ) is
Text : Unbounded_String := Null_Unbounded_String;
function isParagraphStart( text : in String ) return boolean is
-- does the line of text look like the start of a paragraph (blank line or
-- indented)
begin
return Text'Length = 0
or else Text (Text'First) = ' ';
end isParagraphStart;
Overflow : Unbounded_String := Null_Unbounded_String; -- no overflow yet
Index : Natural := StartingAt; -- top-most line
CarryCursor : boolean := false; -- no carry fwd
CarryAmount : integer;
begin
NoError; -- assume OK
c.Mark := -1; -- mark invalid
if Index = 0 then -- none?
Index := 1; -- default line 1
end if;
while Index <= Natural (C.List.Length) loop
Set_Unbounded_String (Text, c.List.Element (Index)); -- get this line
-- Handle Overflow
--
-- Was there extra text after the last line was justified? Prefix it
-- to the current line. If we're leaving the insert block area, then
-- we don't want the text to flow beyond the insert block: insert a
-- new line to hold the extra text.
if length( Overflow ) > 0 then -- carry fwd?
--SessionLog( "Overflow: " & ToString( Overflow ) ); -- DEBUG
if IsParagraphStart (To_String (Text)) then -- new para?
C.List.Insert (index, ""); -- push text down
Text := Overflow; -- ln contents
--SessionLog( "Ending paragraph: " & ToString( Text ) ); -- DEBUG
else -- otherwise
if length( Overflow ) + length( Text ) < 256 then -- emergency handling
C.List.Insert (Index, To_String (Overflow) ); -- this is not right!
Overflow := Null_Unbounded_String;
else
Insert (Text, 1, To_String (Overflow)); -- carry fwd
end if;
--SessionLog( "Carring forward normally: " & ToString( text ) ); -- DEBUG
end if;
end if;
-- Save and Split
--
-- If the length of the text (or the cursor position which may be 1 beyond
-- the end of the line) is over the length of the line, split the line
-- and remember to move the cursor when we're through.
if length( text ) > width or (Index = startingAt and c.CursorX > width) then
-- new line too big?
CropText( text, overflow, width ); -- cut the text in two
SessionLog( "Cropped to " & To_String (Text)); -- DEBUG
C.List.Replace_Element (index, To_String (Text)); -- and save it
-- recursion will go here (if overflow still bigger)
-- reposition the cursor
-- Is this the cursor line? Mark the cursor for moving (if it needs
-- to move). It will have to move back by the length of the new
-- line of text. Note: Never move cursor until all justification is
-- complete.
if Index = startingAt and then c.CursorX > length(text) then
CarryCursor := true;
CarryAmount := length( text );
end if;
c.NeedsRedrawing := true;
elsif startingAt > 0 then
Overflow := null_unbounded_string;
--SessionLog( ToString( Text) & " fits, exiting" ); -- DEBUG
C.List.Replace_Element (index, To_String (Text)); -- update list
c.NeedsRedrawing := true;
exit;
else
Overflow := null_unbounded_string;
--SessionLog( "No Overflow" ); -- DEBUG
end if;
Index := Index + 1;
end loop;
-- Final Line
--
-- Clean up the final line
if length( Overflow ) > 0 then
--SessionLog( "Final overflow: " & ToString( Overflow ) ); -- DEBUG
if index <= Natural (C.List.Length) then
C.List.Replace_Element (index, To_String (Text));
else
C.List.Append (To_String (Overflow));
end if;
end if;
-- if cursor was on last line, will have to move it forward now
if CarryCursor then
MoveCursor( c, -CarryAmount, +1); -- move down a line
end if;
exception when others =>
DrawErrLn;
DrawErr( "JustifyText exception: list dumped to session log" );
for i in 1 .. Natural (C.List.Length) loop
SessionLog (C.List.Element (I));
end loop;
SessionLog( "index is " & Natural'image( index ) );
raise;
end JustifyText;
------------------------------------------------------------------------------
-- JUSTIFY TEXT (Edit)
--
-- Crop long lines and wrap text in a edit list control. Understands that
-- blank lines and indention indicates new paragraphs.
-- If one line is justified, only continue until the text is adjust for that
-- one line. Otherwise, continue to check all lines in the document.
--
-- width => width of the window to justify to
-- startingAt => Justify entire document (0) else the line to justify
-- ToDo: Recursive Justify when overflow exceeds max line length
procedure JustifyText( c : in out AnEditList;
width : integer;
startingAt : Natural := 0 ) is
begin
-- Same justification policy as static lists.
JustifyText( AStaticList( c ), width, startingAt );
end JustifyText;
-- JUSTIFY TEXT (SourceEdit)
--
-- Crop long lines and wrap text in a source edit control. Understands that
-- the area where text is being inserted must be treated as its own paragraph.
-- If one line is justified, only continue until the text is adjust for that
-- one line. Otherwise, continue to check all lines in the document.
--
-- width => width of the window to justify to
-- startingAt => Justify entire document (0) else the line to justify
-- ToDo: Recursive Justify when overflow exceeds max line length
procedure JustifyText( c : in out ASourceEditList;
width : integer;
startingAt : Natural := 0 ) is
Overflow : Unbounded_String := Null_Unbounded_String; -- no overflow yet
Index : Natural := StartingAt; -- top-most line
Text : Unbounded_String;
CarryCursor : Boolean := false; -- no carry fwd
CarryAmount : integer;
insertedFirst : Natural := c.insertedFirst;
insertedLast : Natural := c.insertedFirst + c.InsertedLines - 1;
begin
NoError; -- assume OK
c.Mark := -1; -- mark invalid
if Index = 0 then -- none?
Index := 1; -- default line 1
end if;
-- Justifying an insert block is different from justifying an entire
-- document. So determine where we're justifying. If in an insert block,
-- determine extend of block.
if startingAt < insertedFirst or startingAt > insertedLast then
insertedFirst := 0;
insertedLast := 0;
end if;
while Index <= Natural (C.List.Length) loop
Text := To_Unbounded_String (C.List.Element (Index)); -- get this line
-- Handle Overflow
--
-- Was there extra text after the last line was justified? Prefix it
-- to the current line. If we're leaving the insert block area, then
-- we don't want the text to flow beyond the insert block: insert a
-- new line to hold the extra text.
if length( Overflow ) > 0 then -- carry fwd?
--SessionLog( "Overflow: " & ToString( Overflow ) ); -- DEBUG
if insertedFirst > 0 then -- in ins area?
if index > insertedLast then -- leaving it?
C.list.Insert (index, "" ); -- push text down
c.insertedLines := c.insertedLines + 1; -- inc ins area
Text := Overflow; -- ln contents
if length( text ) <= width then -- all fits?
insertedFirst := 0; -- we've left the
insertedLast := 0; -- insert area
--SessionLog( "Leaving insert area" ); -- DEBUG
else
insertedLast := insertedLast + 1; -- still in area
--SessionLog( "Extending insert area" ); -- DEBUG
end if;
else -- not leaving?
Insert (Text, 1, To_String (Overflow)); -- carry fwd
-- SessionLog( "Carring forward in insert area: " & ToString( text ) ); -- DEBUG
end if;
else -- not ins area?
Insert (Text, 1, To_String (Overflow)); -- carry fwd
--SessionLog( "Carring forward normally: " & ToString( text ) ); -- DEBUG
end if;
end if;
-- Save and Split
--
-- If the length of the text (or the cursor position which may be 1 beyond
-- the end of the line) is over the length of the line, split the line
-- and remember to move the cursor when we're through.
if length( text ) > width or (Index = startingAt and c.CursorX > width) then
-- new line too big?
CropText( text, overflow, width ); -- cut the text in two
--SessionLog( "Cropped to " & ToString( Text ) ); -- DEBUG
C.List.Replace_Element (index, To_String (Text)); -- and save it
-- recursion will go here (if overflow still bigger)
-- reposition the cursor
-- Is this the cursor line? Mark the cursor for moving (if it needs
-- to move). It will have to move back by the length of the new
-- line of text. Note: Never move cursor until all justification is
-- complete.
if Index = startingAt and then c.CursorX > length(text) then
CarryCursor := true;
CarryAmount := length( text );
end if;
c.NeedsRedrawing := true;
elsif startingAt > 0 then
Overflow := Null_Unbounded_String;
--SessionLog( ToString( Text) & " fits, exiting" ); -- DEBUG
C.List.Replace_Element (index, To_String (Text)); -- update list
c.NeedsRedrawing := true;
exit;
else
Overflow := Null_Unbounded_String;
--SessionLog( "No Overflow" ); -- DEBUG
end if;
Index := Index + 1;
end loop;
-- Final Line
--
-- Clean up the final line
if length( Overflow ) > 0 then
--SessionLog( "Final overflow: " & ToString( Overflow ) ); -- DEBUG
if index <= Natural (C.List.Length) then
C.List.Replace_Element (index, To_String (Text));
else
C.List.Append (To_String (Overflow));
end if;
end if;
-- if cursor was on last line, will have to move it forward now
if CarryCursor then
MoveCursor( c, -CarryAmount, +1); -- move down a line
end if;
exception when others =>
DrawErrLn;
DrawErr( "JustifyText exception: list dumped to session log" );
for i in 1 .. Natural (C.List.Length) loop
SessionLog (C.List.Element (I));
end loop;
SessionLog( "index is " & Natural'image( index ) );
raise;
end JustifyText;
------------------------------------------------------------------------------
-- WRAP TEXT (Static)
--
-- Wrap long lines
procedure WrapText( c : in out AStaticList ) is
line : Natural := 1;
text : Unbounded_String;
overflow : Unbounded_String;
width : constant Integer := c.frame.right - c.frame.left + 1;
offset : Natural;
begin
NoError;
while line <= Natural (C.List.Length) loop
Text := To_Unbounded_String (C.List.Element (line));
if length( text ) > width then
CropText ( text, overflow, width );
C.List.Replace_Element (line, To_String (Text));
else
Overflow := Null_Unbounded_String;
end if;
offset := 1;
if length( overflow ) > 0 then
loop
text := overflow;
exit when length(text) <= width;
CropText( text, overflow, width );
C.List.Insert (line+offset, To_String (Text));
offset := offset + 1;
end loop;
C.List.Insert (line+offset, To_String (Text));
offset := offset + 1;
end if;
line := line + offset;
end loop;
end WrapText;
------------------------------------------------------------------------------
-- MOVE CURSOR
--
-- Move the cursor and scroll the list as necessary. Sound simple? Not
-- really. Constrain the cursor to reasonable positions and don't allow
-- the text area to move beyond the top or bottom of the control. Do so
-- in a way that the user doesn't lose their context.
--
-- dx and dy are the change in X and Y position.
procedure MoveCursor( c : in out AStaticList'class;
dx : integer;
dy : integer ) is
NewLine : integer; -- the line being moved to
TempOrigin : integer; -- possible new origin
TempY : integer; -- possible new cursor position
VisibleLines : integer; -- number of lines visible within list frame
ScrollArea : integer; -- number of lines in which to trigger scrol
LastLine : integer; -- last line in the list (or total # lines)
LastScrollLine : integer; -- last line that can be scrolled to
OriginalOrigin : Natural;
OffsetY : integer;
text : unbounded_string;
-- These functions are provided to make MoveCursor easier to read.
-- That's why they are inlined.
function TooSmallToScroll return boolean is
-- If the last scrollable line on screen is < 1, the text is smaller
-- than the bounding rectangle; if 1, it fits exactly.
begin
return LastScrollLine < 2;
end TooSmallToScroll;
pragma Inline( TooSmallToScroll );
-- function InLast3QuartersOfRect( rectline : integer) return boolean is
-- -- If line rectline is in the bottom of the list rectangle, where
-- -- rectline 1 is the top of the rectangle's drawing area.
-- begin
-- return ( rectline >= VisibleLines - ScrollArea + 1 );
-- end InLast3QuartersOfRect;
-- pragma Inline( InLast3QuartersOfRect );
begin
NoError;
-- Calculate some basic numbers that we will need.
VisibleLines := integer( c.frame.bottom - c.frame.top ) - 1;
ScrollArea := VisibleLines/4;
LastLine := Natural (C.List.Length);
LastScrollLine := LastLine - VisibleLines + 1;
OriginalOrigin := c.Origin;
-- Constrain DY: it must not move the cursor of the list.
if c.Origin + c.CursorY + dy <= 1 then
OffsetY := -(c.Origin + c.CursorY) + 2;
elsif C.Origin + c.CursorY +
dy - 1 > LastLine then
OffsetY := LastLine - c.Origin - c.CursorY + 1;
else
OffsetY := dy;
end if;
-- The line the cursor will now fall on. We don't know yet which line
-- in the control will have the cursor (TempY).
NewLine := c.Origin + c.CursorY + OffsetY - 1;
TempY := c.CursorY + OffsetY;
-- Constrain Top of List
--
-- Is the cursor moving beyond top of list frame? Near top 1/4 of control?
-- Scroll. Moving into first lines? Constrain. Otherwise move cursor.
if OffsetY < 0 then -- Moving up?
if TempY > ScrollArea then -- Not top of
c.CursorY := TempY; -- of list? OK
else -- else scroll
TempOrigin := NewLine - ScrollArea + 1; -- +1 so no 0
if TempOrigin > 0 then -- in list?
c.NeedsRedrawing := c.Origin /= TempOrigin or c.NeedsRedrawing;
c.Origin := TempOrigin;
c.CursorY := NewLine - TempOrigin + 1;
else -- constrain
c.NeedsRedrawing := c.Origin /= 1 or c.NeedsRedrawing;
c.Origin := 1;
c.CursorY := NewLine;
end if;
end if;
-- Constrain Bottom of List
--
-- Is the cursor moving below the bottom of list frame? Near bottom 3/4
-- of control? Scroll. Moving into final lines? Constrain. Otherwise
-- move cursor. Special case: don't scroll down if document is too short
-- to fit in the control.
elsif OffsetY > 0 then -- moving down?
if TooSmallToScroll then -- Too short?
c.CursorY := TempY; -- No scrolling
elsif TempY <= VisibleLines - ScrollArea + 1 then -- Not end
c.CursorY := TempY; -- of list? OK
else -- else scroll
TempOrigin := NewLine - (VisibleLines-ScrollArea);
if TempOrigin <= LastScrollLine then
c.NeedsRedrawing := c.Origin /= TempOrigin or c.NeedsRedrawing;
c.Origin := TempOrigin;
c.CursorY := NewLine - TempOrigin + 1;
else
c.NeedsRedrawing := c.Origin /= LastScrollLine or c.NeedsRedrawing;
c.Origin := LastScrollLine;
c.CursorY := NewLine - LastScrollLine + 1;
end if;
end if;
else
-- Always check if origin needs to be fixed due to LastScrollLine
-- (even if no y motion)
if LastScrollLine > 0 and then NewLine > LastScrollLine then
if OriginalOrigin /= LastScrollLine then
c.NeedsRedrawing := true;
c.Origin := LastScrollLine;
c.CursorY := integer( NewLine - LastScrollLine + 1 );
end if;
end if;
end if;
-- move x-ward
--
-- constrain the cursor to the line of text
c.CursorX := c.CursorX + dx;
Text := To_Unbounded_String (C.List.Element (GetCurrent( c )));
if c.CursorX > length( text ) + 1 then
c.CursorX := length( text ) + 1;
end if;
-- further constrain the cursor to control frame
if c.CursorX > c.frame.right - c.frame.left - 1 then
c.CursorX := c.frame.right - c.frame.left - 1;
elsif c.CursorX < 1 then
c.CursorX := 1;
end if;
exception when others =>
DrawErrLn;
DrawErr( "MoveCursor exception" );
SessionLog( "MoveCursor exception" );
SessionLog( "dx=" );
SessionLog( integer'image( dx ) );
SessionLog( "dy=" );
SessionLog( integer'image( dy ) );
raise;
end MoveCursor;
procedure SetOrigin( c : in out AStaticList'class; origin :
Natural ) is
Height : integer;
begin
NoError;
if c.origin /= 0 and c.origin /= origin then
if not C.List.Is_Empty then
Height := c.frame.bottom - c.frame.top;
if origin <= Natural (C.List.Length) - (Height-2) then
c.origin := origin;
elsif Natural (C.List.Length) <= (Height - 2) then
c.origin := 1; -- short list? constrain to first line
else -- beyond last possible origin? constrain to l.p.o.
c.origin := Natural (C.List.Length) - (Height - 2);
end if;
c.NeedsRedrawing := true;
end if;
end if;
exception when others => DrawErrLn;
DrawErr("SetOrigin RT error");
raise;
end SetOrigin;
function GetOrigin( c : in AStaticList'class ) return
Natural is
begin
NoError;
return c.origin;
end GetOrigin;
function GetCurrent( c : in AStaticList'class ) return Natural is
begin
NoError;
if C.List.Is_Empty then
return 0;
else
return c.Origin + c.CursorY - 1;
end if;
end GetCurrent;
function GetLength( c : in AStaticList'class ) return Natural is
begin
NoError;
return Natural (C.List.Length);
end GetLength;
function GetPositionY( c : in AStaticList'class ) return integer is
begin
NoError;
return c.CursorY;
end GetPositionY;
procedure SetScrollBar( c : in out AStaticList'class; bar : AControlNumber ) is
begin
NoError;
c.ScrollBar := bar;
end SetScrollBar;
function GetScrollBar( c : in AStaticList'class ) return AControlNumber is
begin
NoError;
return c.ScrollBar;
end GetScrollBar;
procedure FindText( c : in out AStaticList'class; str2find : in string;
Backwards, IsRegExp : boolean := false ) is
OldLine, Line : Integer;
Criteria : RegExp;
begin
NoError;
if IsRegExp then
Criteria := Compile( str2find, true, true );
elsif c.FindPhrase /= str2find then
c.FindPhrase := To_Unbounded_String (Str2find); -- hilight, if available
c.NeedsRedrawing := true;
end if;
OldLine := GetCurrent( c );
Line := 0;
if Backwards then
for i in reverse 1 .. OldLine-1 loop
declare
Tempstr : constant String := C.List.Element (I);
begin
if IsRegExp then
if Match( TempStr, Criteria ) then
Line := i;
exit;
end if;
elsif Ada.Strings.Fixed.Index( TempStr, str2find) > 0 then
Line := i;
exit;
end if;
end;
end loop;
else
for i in OldLine + 1 .. Natural (C.list.Length) loop
declare
TempStr : constant String := C.List.Element (I);
begin
if IsRegExp then
if Match( TempStr, Criteria ) then
Line := i;
exit;
end if;
elsif Ada.Strings.Fixed.Index( TempStr, str2find) > 0 then
Line := i;
exit;
end if;
end;
end loop;
end if;
if Line > 0 then
MoveCursor( c, 0, Line - OldLine );
else
Beep( Failure );
end if;
end FindText;
procedure ReplaceText( c : in out AStaticList'class; str2find,
str2repl : in string; Backwards, IsRegExp : boolean := false ) is
pragma Unreferenced (Isregexp);
OldLine, Line : integer;
Loc : integer;
begin
NoError;
c.NeedsRedrawing := true; -- always redraw
--if (c.FindPhrase /= str2find ) then
-- c.FindPhrase := str2find; -- hilight, if available
-- c.NeedsRedrawing := true;
--end if;
OldLine := GetCurrent( c );
Line := 0;
if Backwards then
for i in reverse 1..OldLine-1 loop
declare
Tempstr : constant String := C.List.Element (I);
begin
Loc := Ada.Strings.Fixed.Index( TempStr, str2find);
if Loc > 0 then
C.List.Replace_Element (i, Ada.Strings.Fixed.Replace_Slice (Tempstr, Loc, Loc + Str2find'Length - 1, str2repl));
Line := i;
exit;
end if;
end;
end loop;
else
for i in OldLine + 1 .. Natural (C.List.Length) loop
declare
Tempstr : constant String := C.List.Element (I);
begin
Loc := Ada.Strings.Fixed.Index ( TempStr, str2find);
if Loc > 0 then
C.List.Replace_Element (I, Ada.Strings.Fixed.Replace_Slice (Tempstr, Loc, Loc + Str2find'Length - 1, Str2repl));
Line := i;
exit;
end if;
end;
end loop;
end if;
if Line > 0 then
MoveCursor( c, 0, Line - OldLine );
else
Beep( Failure );
end if;
end ReplaceText;
procedure SetFindPhrase( c : in out AStaticList'class; phrase : in string) is
begin
NoError;
if c.FindPhrase /= phrase then
c.FindPhrase := To_Unbounded_String (Phrase);
c.NeedsRedrawing := true;
end if;
end SetFindPhrase;
procedure SetMark( c : in out AStaticList'class; mark : integer ) is
begin
NoError;
if Mark >= -1 and Mark <= Natural (C.list.Length) then
c.Mark := Mark;
else
c.Mark := -1;
end if;
c.NeedsRedrawing := true;
end SetMark;
function GetMark( c : in AStaticList'class ) return integer is
begin
NoError;
return c.Mark;
end GetMark;
function CopyLine (c : in AStaticList'Class) return String is
Current : constant Natural := GetCurrent (C);
begin
NoError;
if Current > 0 then
return C.List.Element (Current);
else
return "";
end if;
end CopyLine;
procedure PasteLine( c : in out AStaticList'class; Text : in String ) is
Current : Natural;
-- insert a line into the current position, fix cursor if necessary
begin
NoError;
Current := GetCurrent( c );
if Current > 0 then
C.List.Insert (Current, text);
else
C.List.Append (Text);
c.origin := 1;
c.cursorY := 1;
c.cursorX := Text'length + 1;
end if;
MoveCursor( c, 0, 0 ); -- make sure cursor is in valid position
c.Mark := -1; -- mark no longer valid
c.NeedsRedrawing := true;
end PasteLine;
procedure ReplaceLine( c : in out AStaticList'class; Text : in String ) is
Current : Natural;
-- insert a line into the current position, fix cursor if necessary
begin
NoError;
Current := GetCurrent( c );
if Current > 0 then
C.List.Replace_Element (Current, text );
else
C.List.Append (text);
c.origin := 1;
c.cursorY := 1;
c.cursorX := Text'Length + 1;
end if;
c.NeedsRedrawing := true;
MoveCursor( c, 0, 0 );
end ReplaceLine;
procedure CopyLines( c : in out AStaticList'class; mark2 : integer;
Lines : in out StrList.Vector ) is
-- copy lines at between mark and mark2
StartPoint, EndPoint : Natural;
begin
NoError;
if c.Mark /= -1 then -- no mark set?
if c.Mark < Mark2 then
Startpoint := c.mark;
Endpoint := mark2;
else
Startpoint := mark2;
Endpoint := c.mark;
end if;
if EndPoint > Natural (C.List.Length) then
EndPoint := Natural (c.list.Length);
end if;
Slice (C.List, Startpoint, Endpoint-Startpoint+1, Lines);
else
Lines.Clear;
end if;
end CopyLines;
procedure PasteLines( c : in out AStaticList'class; Lines : in out
StrList.Vector ) is
begin
NoError;
if not c.List.Is_Empty then
for i in 1 .. Natural (Lines.Length) loop
PasteLine( c, Lines.Element (i));
MoveCursor( c, 0, +1 );
end loop;
else
SetList( c, Lines );
end if;
-- c.Mark := -1; done by SetList and PasteLine
end PasteLines;
---> Check List Calls
procedure SetChecks( c : in out ACheckList ; Checks : in out BooleanList.Vector ) is
begin
NoError;
C.Checks := Checks;
c.NeedsRedrawing := true;
if Checks.Is_Empty then
c.CursorX := 1;
else
c.CursorX := 2;
end if;
end SetChecks;
function GetChecks( c : in ACheckList ) return BooleanList.Vector is
begin
NoError;
return c.Checks;
end GetChecks;
---> Radio List Calls
procedure SetChecks( c : in out ARadioList ;
checks : in out BooleanList.Vector;
Default : Natural := 1 ) is
begin
NoError;
C.Checks := Checks;
c.NeedsRedrawing := true;
if Checks.Is_Empty then
c.CursorX := 1;
c.LastCheck := 0;
else
c.CursorX := 2;
c.LastCheck := Default;
C.Checks.Replace_Element (Default, True);
end if;
SetOrigin( c, Default);
end SetChecks;
function GetChecks( c : in ARadioList ) return BooleanList.Vector is
begin
NoError;
return c.Checks;
end GetChecks;
function GetCheck( c : in ARadioList ) return Natural is
begin
NoError;
return C.LastCheck;
end GetCheck;
---> Edit List Calls
function GetPosition( c : in AnEditList'class ) return integer is
begin
NoError;
return c.CursorX;
end GetPosition;
procedure SetCursor( c : in out AnEditList'class; x : integer;
y : Natural ) is
begin
NoError;
c.cursorX := 1; -- home cursor to top of document
c.cursorY := 1;
MoveCursor( c, x - 1, y - 1 ); -- amount to move from home position
c.NeedsRedrawing := true;
end SetCursor;
procedure Touch( c : in out AnEditList'class ) is
begin
NoError;
c.Touched := true;
end Touch;
procedure ClearTouch( c : in out AnEditList'class ) is
begin
NoError;
c.Touched := false;
end ClearTouch;
function WasTouched( c : AnEditList'class ) return boolean is
begin
NoError;
return c.Touched;
end WasTouched;
--> Source Edit List Calls
procedure SetHTMLTagsStyle( c : in out ASourceEditList; hilight : boolean ) is
begin
NoError;
c.HTMLTagStyle := hilight;
end SetHTMLTagsStyle;
procedure SetLanguageData( c : in out ASourceEditList; p : languageDataPtr ) is
begin
NoError;
c.languageData := p;
end SetLanguageData;
procedure SetSourceLanguage( c : in out ASourceEditList; l : ASourceLanguage ) is
begin
NoError;
c.sourceLanguage := l;
end SetSourceLanguage;
procedure SetKeywordHilight( c : in out ASourceEditList; pcn : aPenColourName ) is
begin
NoError;
c.keywordHilight := pcn;
end SetKeywordHilight;
procedure SetFunctionHilight( c : in out ASourceEditList; pcn : aPenColourName ) is
begin
NoError;
c.functionHilight := pcn;
end SetFunctionHilight;
---> Drawing Controls
procedure Draw( c : in out RootControl ) is
begin
NoError;
c.NeedsRedrawing := false;
if c.Status = On then
MoveToGlobal( c.frame.left + c.CursorX, c.frame.top + c.CursorY );
end if;
end Draw;
procedure Draw( c : in out AnIconicControl ) is
begin
Draw( RootControl( c ) );
end Draw;
procedure Draw( c : in out AWindowControl ) is
begin
Draw( RootControl( c ) );
end Draw;
procedure Draw( c : in out AThermometer ) is
CenterX : integer;
CenterY : integer;
LengthX : integer;
LengthPercent : integer;
Percent : integer;
FirstTextChar : integer;
LastTextChar : integer;
Text : string(1..8);
TextSize : integer;
frame : ARect renames c.frame;
procedure SetPercentText( p : string ) is
-- Linux 2.03 gives constraint error on string-of-different-len assignment
max : integer;
begin
max := Text'last;
if p'last < Text'last then
max := p'last;
end if;
for i in 1..max loop
Text(i) := p(i);
end loop;
for i in max+1..Text'last loop
Text(i) := ' ';
end loop;
end SetPercentText;
begin
NoError;
if c.needsRedrawing then
SetTextStyle(Normal);
-- compute postion
LengthX := frame.right - frame.left + 1;
CenterX := LengthX / 2 + frame.left;
CenterY := (frame.bottom - frame.top ) / 2 + frame.top;
if c.max = 0 then
LengthPercent := 1;
else
LengthPercent := LengthX * c.value / c.max + 1;
-- chars included
end if;
-- compute text
if LengthX > 3 then
if c.Max > 0 then
Percent := 100 * c.value / c.max;
else
Percent := 0;
end if;
if Percent < 10 then
TextSize := 2;
elsif Percent < 100 then
TextSize := 3;
else
TextSize := 4;
end if;
SetPercentText( integer'image( Percent ) );
-- Text := integer'image( Percent );
FirstTextChar := CenterX - frame.left - TextSize / 2;
LastTextChar := FirstTextChar + TextSize - 1;
else
FirstTextChar := integer'last;
LastTextChar := integer'last;
end if;
MoveToGlobal( frame.left, CenterY );
if DisplayInfo.C_Res = 0 then -- monochrome display
CTextStyle( 'y', 'y', 'n');
else
SetPenColour( thermFore );
end if;
for x in 1..LengthX loop
if x = LengthPercent then
if DisplayInfo.C_Res = 0 then
CTextStyle( 'n', 'y', 'n' );
else
SetPenColour( thermBack );
end if;
end if;
if x >= FirstTextChar and x <= LastTextChar then
Draw( text( x-FirstTextChar+1) );
elsif x = LastTextChar + 1 then
Draw( '%' );
elsif IsMonoXEmu and x < LengthPercent then
-- x doesn't do dim/bold inversing
Draw( '-' ); -- so we need to draw a line of minuses
else
Draw( ' ' );
end if;
end loop;
end if;
Draw( AWindowControl( c ) );
exception when others => DrawErrLn;
DrawErr("DrawTherm RT error" );
raise;
end Draw; -- AThermometer
procedure Draw( c : in out AScrollBar ) is
CenterX : integer;
CenterY : integer;
BarLength : integer; -- length of bar (in characters)
Thumb : integer; -- position of the thumb
frame : ARect renames c.frame;
begin
NoError;
if c.needsRedrawing or c.DirtyThumb then
SetTextStyle( Normal );
SetPenColour( scrollBack );
if (frame.right-frame.left) > (frame.bottom-frame.top) then
-- Horizontal Scroll Bar
-- compute position
BarLength := frame.right - frame.left + 1;
CenterX := BarLength / 2 + frame.left;
CenterY := (frame.bottom - frame.top ) / 2 + frame.top;
if c.max = 0 then
Thumb := 0;
else
Thumb := BarLength * c.thumb /
c.max + 1; -- chars included
if Thumb > BarLength then
Thumb := BarLength;
end if;
end if;
if c.DirtyThumb and not c.needsRedrawing then
-- if only a dirty thumb on horizontal bar
if Thumb /= c.OldThumb then
if DisplayInfo.C_Res = 0 then
CTextStyle( 'n', 'y', 'n' );
else
SetPenColour( scrollBack );
end if;
MoveToGlobal( frame.left + c.OldThumb - 1, CenterY );
Draw( ' ' );
MoveToGlobal( frame.left + Thumb - 1, CenterY );
if DisplayInfo.C_Res = 0 then
CTextStyle( 'y', 'y', 'n' );
Draw( '#' );
else
SetPenColour( scrollThumb );
Draw( ' ' );
end if;
Draw( '#' );
end if;
else -- draw whole thing
MoveToGlobal( frame.left, CenterY );
if DisplayInfo.C_Res > 0 then
SetpenColour( scrollBack );
else
CTextStyle( 'n', 'y', 'n' );
end if;
for x in 1..BarLength loop
if x = Thumb then
if DisplayInfo.C_Res > 0 then
SetPenColour( scrollThumb );
Draw( ' ' );
else
CTextStyle( 'y', 'y', 'n');
Draw( '#' );
end if;
else
if x = Thumb + 1 then
if DisplayInfo.C_Res > 0 then
SetPenColour( scrollBack );
else
CTextStyle( 'n', 'y', 'n');
end if;
end if;
Draw( ' ' );
end if;
end loop;
end if;
else
-- Vertical Scroll Bar
-- compute position
BarLength := frame.bottom - frame.top + 1;
CenterY := BarLength / 2 + frame.top;
CenterX := (frame.right - frame.left ) / 2 + frame.left;
if c.max = 0 then
Thumb := 0;
else
Thumb := BarLength * c.thumb / c.max + 1; -- chars included
if Thumb > BarLength then
Thumb := BarLength;
end if;
end if;
if c.DirtyThumb and not c.needsRedrawing then
-- if only a dirty thumb on horizontal bar
if Thumb /= c.OldThumb then
MoveToGlobal( CenterX, frame.top + c.OldThumb - 1 );
if DisplayInfo.C_Res = 0 then
CTextStyle( 'n', 'y', 'n' );
else
SetPenColour( scrollBack );
end if;
Draw( ' ' );
MoveToGlobal( CenterX, frame.top + Thumb - 1 );
if DisplayInfo.C_Res = 0 then
CTextStyle( 'y', 'y', 'n' );
Draw( '#' );
else
SetPenColour( scrollThumb );
Draw( ' ' );
end if;
end if;
else -- draw whole vertical scroll bar
if DisplayInfo.C_Res > 0 then
SetPenColour( scrollBack );
else
CTextStyle( 'n', 'y', 'n' );
end if;
for y in 1..BarLength loop
MoveToGlobal( CenterX, frame.top + y - 1 );
if y = Thumb then
if DisplayInfo.C_Res > 0 then
SetPenColour( scrollThumb );
Draw( ' ' );
else
CTextStyle( 'y', 'y', 'n' );
Draw( '#' );
end if;
else
if y = Thumb + 1 then
if DisplayInfo.C_Res > 0 then
SetPenColour( scrollBack );
else
CTextStyle( 'n', 'y', 'n' );
end if;
end if;
Draw( ' ' );
end if;
end loop;
end if;
end if;
c.DirtyThumb := false;
c.OldThumb := Thumb;
end if;
Draw( AWindowControl( c ) );
exception when others => DrawErrLn;
Draw("DrawScroll RT error");
raise;
end Draw; -- AScrollBar
procedure Draw( c : in out AStaticLine ) is
begin
NoError;
if c.needsRedrawing then
if c.colour /= none then
SetPenColour( c.colour );
else
SetPenColour( white );
end if;
SetTextStyle( c.style );
-- kludge because of problem iwth settextstyle
if c.colour /= none then
SetPenColour( c.colour );
else
SetPenColour( white );
end if;
MoveToGlobal( c.frame.left, c.frame.top );
Draw(To_String (C.Text), c.frame.right - c.frame.left + 1, true );
end if;
Draw( AnIconicControl( c ) );
end Draw; -- AStaticLine
procedure Draw( c : in out AnEditLine ) is
left : integer;
text : Unbounded_String;
begin
NoError;
if c.needsRedrawing or c.DirtyText then
SetTextStyle( Input );
if c.DirtyText and not c.needsRedrawing then
-- redraw only text from cursor - 1 to right
-- the -1 is in case of a single character insert
if c.cursorx >= 1 then
left := c.frame.left + c.cursorx - 1;
text := Tail( c.text, length(c.text) - c.cursorx + 1 );
else
left := c.frame.left;
text := c.text;
end if;
else
left := c.frame.left;
text := c.text;
end if;
if c.BlindMode then
for i in 1..length( text ) loop
if Element( text, i ) /= ' ' then
Replace_Element( text, i, '*' );
end if;
end loop;
end if;
MoveToGlobal( left, c.frame.top );
if c.Status = On then
DrawEdit( To_String (Text), c.frame.right - left + 1, c.AdvanceMode );
else
DrawEdit( To_String (Text), c.frame.right - left + 1, false );
end if;
c.DirtyText := false;
end if;
Draw( AWindowControl( c ) );
end Draw; -- AnEditLine
procedure Draw( c : in out AnIntegerEditLine ) is
begin
Draw( AnEditLine( c ) );
end Draw; -- AnIntegerEditLine
procedure Draw( c : in out ALongIntEditLine ) is
begin
Draw( AnEditLine( c ) );
end Draw; -- ALongIntEditLine
procedure Draw( c : in out AFloatEditLine ) is
begin
Draw( AnEditLine( c ) );
end Draw; -- AFloatEditLine
procedure Draw( c : in out ACheckBox ) is
begin
NoError;
if c.needsRedrawing then
SetTextStyle( Normal );
SetPenColour( white );
MoveToGlobal( c.frame.left, c.frame.top );
if c.Status = Off then
Draw( "[-] ");
elsif c.checked then
Draw( "[#] " );
else
Draw( "[ ] " );
end if;
Draw( To_String (C.Text), c.frame.right - c.frame.left - 3, true );
if c.HotPos > 0 and c.HotPos < c.frame.right - c.frame.left - 3 then
DrawHotKey( c.frame.left+3+c.HotPos, c.frame.top,
Element( c.text, c.HotPos ) );
end if;
end if;
Draw( AWindowControl( c ) );
end Draw; -- ACheckBox
procedure Draw( c : in out ARadioButton ) is
begin
NoError;
if c.needsRedrawing then
SetTextStyle( Normal );
SetPenColour( white );
MoveToGlobal( c.frame.left, c.frame.top );
if c.Status = Off then
Draw( "(-) ");
elsif c.checked then
Draw( "(*) " );
else
Draw( "( ) " );
end if;
Draw( To_String (C.Text), c.frame.right - c.frame.left - 3, true );
if c.HotPos > 0 and c.HotPos < c.frame.right - c.frame.left - 3 then
DrawHotKey( c.frame.left+3+c.HotPos, c.frame.top,
Element( c.text, c.HotPos ) );
end if;
end if;
Draw( AWindowControl( c ) );
end Draw; -- ARadioButton
procedure Draw( c : in out ASimpleButton ) is
begin
NoError;
if c.needsRedrawing then
SetTextStyle( Normal );
if c.colour = none then
SetPenColour( white );
end if;
if c.colour /= none then
SetPenColour( c.colour );
end if;
MoveToGlobal( c.frame.left, c.frame.top );
if c.Instant then
if c.Status = Off then
Draw( "|-> " );
else
Draw( "| > " );
end if;
else
if c.Status = Off then
Draw( "<-> ");
else
Draw( "< > ");
end if;
end if;
Draw( To_String (C.Text), c.frame.right - c.frame.left - 3, true );
if c.HotPos > 0 and c.HotPos < c.frame.right - c.frame.left - 3 then
DrawHotKey( c.frame.left+3+c.HotPos, c.frame.top,
Element( c.text, c.HotPos ) );
end if;
end if;
Draw( AWindowControl( c ) );
end Draw;
procedure Draw( c : in out AWindowButton ) is
begin
NoError;
if c.needsRedrawing then
SetTextStyle( Normal );
SetPenColour( white );
MoveToGlobal( c.frame.left, c.frame.top );
if c.Instant then
if c.Status = Off then
Draw( "|-> " );
else
Draw( "| > " );
end if;
else
if c.Status = Off then
Draw( "<-> ");
else
Draw( "< > ");
end if;
end if;
Draw( To_String (C.Text), c.frame.right - c.frame.left - 3, true );
if c.HotPos > 0 and c.HotPos < c.frame.right - c.frame.left - 3 then
DrawHotKey( c.frame.left+3+c.HotPos, c.frame.top,
Element( c.text, c.HotPos ) );
end if;
end if;
Draw( AnIconicControl( c ) );
end Draw;
procedure Draw( c : in out ARectangle ) is
begin
NoError;
if c.needsRedrawing then
SetPenColour( c.FrameColour );
FrameRect3D( c.frame );
if c.BackColour /= None then
FillRect( InsetRect( c.frame, 1, 1), c.BackColour );
end if;
end if;
Draw( AnIconicControl( c ) );
end Draw; -- ARectangle
procedure Draw( c : in out ALine ) is
begin
NoError;
if c.needsRedrawing then
SetPenColour( c.Colour );
if c.DownRight then
DrawLine( c.frame.left, c.frame.top, c.frame.right, c.frame.bottom );
else
DrawLine( c.frame.left, c.frame.bottom, c.frame.right, c.frame.top );
end if;
end if;
Draw( AnIconicControl( c ) );
end Draw; -- ALine
procedure Draw( c : in out AnHorizontalSep ) is
begin
NoError;
SetPenColour( c.Colour );
if c.needsRedrawing then
DrawHorizontalLine( c.frame.left, c.frame.right, c.frame.top );
end if;
Draw( AnIconicControl( c ) );
end Draw; -- AnHorizontalSep
procedure Draw( c : in out AVerticalSep ) is
begin
NoError;
SetPenColour( c.Colour );
if c.needsRedrawing then
DrawVerticalLine( c.frame.top, c.frame.bottom, c.frame.left );
end if;
Draw( AnIconicControl( c ) );
end Draw; -- AVerticalSep
procedure Draw( c : in out AStaticList ) is
Contents : StrList.Vector;
Offset : integer := 1;
begin
NoError;
if c.needsRedrawing then
SetPenColour( outline );
FrameRect3D( c.frame );
SetPenColour( white );
if C.List.Is_Empty then
null;
else
SetTextStyle( normal );
-- if list is smaller than box, erase box before redrawing
-- in case text was changed to a different number of lines
if Natural (C.List.Length) < c.frame.bottom-c.frame.top-1 then
FillRect( InsetRect( c.frame, 1, 1 ), black );
end if;
Slice (C.List, C.Origin, C.Frame.Bottom - C.Frame.Top - 1, Contents);
while Ada.Containers.">" (Contents.Length, 0) loop
declare
Temp_Line : constant String := Contents.Last_Element;
begin
Contents.Delete_Last;
MoveToGlobal( c.frame.left + 1, c.frame.top + offset );
Draw (Temp_Line, c.frame.right - c.frame.left - 1, true );
Offset := Offset + 1;
end;
end loop;
Contents.Clear;
end if;
end if;
Draw( AWindowControl( c ) );
end Draw; -- AStaticList
procedure Draw( c : in out ACheckList ) is
Contents : StrList.Vector;
Offset : integer := 1;
Selections:BooleanList.Vector;
IsSelected : constant boolean := false;
begin
NoError;
if c.needsRedrawing then
SetPenColour( outline );
FrameRect3D( c.frame );
SetPenColour( white );
if C.List.Is_Empty then
Null;
else
SetTextStyle( normal );
-- if list is smaller than box, erase box before redrawing
-- in case text was changed to a different number of lines
if Natural (C.List.Length) < c.frame.bottom-c.frame.top-1 then
FillRect( InsetRect( c.frame, 1, 1 ), black );
end if;
Slice (c.list, c.origin, c.frame.bottom - c.frame.top - 1, Contents);
Slice (c.checks, C.Origin, c.frame.bottom - c.frame.top -1, Selections);
while not Contents.Is_Empty loop
declare
Temp_Line : constant String := Contents.Last_Element;
begin
Contents.Delete_Last;
MoveToGlobal( c.frame.left + 1, c.frame.top + offset );
if not Selections.Is_Empty then
Selections.Append (IsSelected);
if DisplayInfo.C_Res > 0 then
SetTextStyle( normal );
SetPenColour( white );
end if;
Draw("[ ] ");
else
Draw("[-] ");
end if;
Draw( Temp_Line, c.frame.right - c.frame.left - 5, true );
Offset := Offset + 1;
end;
end loop;
end if;
end if;
Draw( AWindowControl( c ) );
end Draw; -- ACheckList
procedure Draw( c : in out ARadioList ) is
Contents : Strlist.Vector;
Offset : integer := 1;
Selections:BooleanList.Vector;
IsSelected : boolean := false;
begin
NoError;
if c.needsRedrawing then
SetPenColour( outline );
FrameRect3D( c.frame );
SetPenColour( white );
if C.List.Is_Empty then
Null;
else
SetTextStyle( normal );
-- if list is smaller than box, erase box before redrawing
-- in case text was changed to a different number of lines
if Natural (C.list.Length) < C.frame.bottom-c.frame.top-1 then
FillRect( InsetRect( c.frame, 1, 1 ), black );
end if;
Slice (C.List, C.Origin, C.Frame.Bottom - C.Frame.Top - 1, Contents);
Slice (C.checks, C.Origin, c.frame.bottom - c.frame.top -1, Selections );
while not Contents.Is_Empty loop
declare
Temp_Line : constant String := Contents.Last_Element;
begin
Contents.Delete_Last;
MoveToGlobal( c.frame.left + 1, c.frame.top + offset );
if not Selections.Is_Empty then
Isselected := Selections.Last_Element;
Selections.Delete_Last;
if DisplayInfo.C_Res > 0 then
SetTextStyle( normal );
SetPenColour( white );
end if;
if IsSelected then
Draw("(*) ");
if DisplayInfo.C_Res > 0 then
SetPenColour( yellow );
end if;
else
Draw("( ) ");
end if;
else
Draw("(-) ");
end if;
Draw (Temp_Line, c.frame.right - c.frame.left - 5, true );
Offset := Offset + 1;
end;
end loop;
end if;
end if;
Draw( AWindowControl( c ) );
exception when others => DrawErrLn;
DrawErr( "Draw(rl) exception" );
raise;
end Draw; -- ARadioList
procedure Draw( c : in out AnEditList ) is
Contents : Strlist.Vector;
Offset : integer := 1;
Line : integer;
MarkedLine : integer;
begin
NoError;
if c.needsRedrawing or c.DirtyLine then
SetTextStyle( normal );
SetPenColour( white );
MarkedLine := c.Mark - c.origin + 1;
if c.DirtyLine and not c.needsRedrawing then -- just do the line
line := c.origin + c.CursorY - 1;
declare
Temp_Line : constant String := c.List.Element (line);
begin
MoveToGlobal( c.frame.left+1, c.frame.top + c.CursorY );
if line = MarkedLine then
SetTextStyle( Emphasis );
end if;
Draw( Temp_Line, c.frame.right - c.frame.left - 1, true );
if line = MarkedLine then
SetTextStyle( Normal );
end if;
end;
else
SetPenColour( outline );
FrameRect3D( c.frame );
SetPenColour( white );
if C.List.Is_Empty then
FillRect( InsetRect( c.frame, 1, 1 ), black );
else
Slice ( c.list, c.origin,
Natural( c.frame.bottom - c.frame.top - 1),
Contents );
if Natural (Contents.Length) < c.frame.bottom - c.frame.top - 1 then
FillRect( InsetRect( c.frame, 1, 1 ), black );
end if;
for i in 1 .. Natural (Contents.Length) loop
declare
Temp_Line : constant String := Contents.Last_Element;
begin
Contents.Delete_Last;
MoveToGlobal( c.frame.left + 1, c.frame.top + offset );
if i = MarkedLine then
SetTextStyle( Emphasis );
Draw( Temp_Line, c.frame.right - c.frame.left - 1, true );
SetTextStyle( Normal );
else
Draw (Temp_Line, c.frame.right - c.frame.left - 1, true );
end if;
Offset := Offset + 1;
end;
end loop;
end if;
end if;
end if;
c.DirtyLine := false;
Draw( AWindowControl( c ) );
end Draw; -- AnEditList
procedure Draw( c : in out ASourceEditList ) is
Contents : Strlist.Vector;
Line255 : Unbounded_String; -- temporary
Offset : integer := 1;
Line : integer;
MarkedLine : integer;
TreatAsTitle : boolean := false; -- treat next as title of something
procedure HilightFindPhrase( basex, basey : integer ) is
VisibleTextLength : integer := 0;
ch : character;
begin
VisibleTextLength := c.frame.right - c.frame.left - 1;
ch := Element( c.FindPhrase, 1 );
for i in 1..Length( Line255 ) - length( c.FindPhrase ) loop
if Element( Line255, i ) = ch then
if Slice( Line255, i, i+length( c.FindPhrase )-1 ) = c.FindPhrase then
if i+length( c.FindPhrase)-1 <= VisibleTextLength then
SetTextStyle( bold );
MoveToGlobal( basex + i-1, basey );
Draw( To_String (C.FindPhrase) );
SetTextStyle( normal );
end if;
end if;
end if;
end loop;
end HilightFindPhrase;
procedure HilightKeyword( basex, basey, offset : integer;
word : string ) is
kp : keywordDataPtr;
fp : functionDataPtr;
Found : boolean := false;
begin
kp := findKeywordData( c.languageData.all, c.sourceLanguage, word );
if kp /= null then
found := true;
if DisplayInfo.C_Res > 0 then
SetPenColour( c.keywordHilight );
MoveToGlobal( basex + offset, basey );
Draw( word );
SetPenColour( white );
else
SetTextStyle( underline );
MoveToGlobal( basex + offset, basey );
Draw( word );
SetTextStyle( normal );
end if;
else
fp := findFunctionData( c.languageData.all, c.sourceLanguage, word );
if fp /= null then
found := true;
if DisplayInfo.C_Res > 0 then
SetPenColour( c.functionHilight );
MoveToGlobal( basex + offset, basey );
Draw( word );
SetPenColour( white );
else
SetTextStyle( underline );
MoveToGlobal( basex + offset, basey );
Draw( word );
SetTextStyle( normal );
end if;
end if;
end if;
--for i in 1 .. c.keywordlist.Length loop
-- word2test := c.KeywordList.element (i);
-- if word = word2test then
-- if DisplayInfo.C_Res > 0 then
-- SetPenColour( yellow );
-- MoveToGlobal( basex + offset, basey );
-- Draw( word );
-- SetPenColour( white );
-- else
-- SetTextStyle( underline );
-- MoveToGlobal( basex + offset, basey );
-- Draw( word );
-- SetTextStyle( normal );
-- end if;
-- Found := true;
-- exit;
-- end if;
--end loop;
if not Found and TreatAsTitle then
if DisplayInfo.C_Res > 0 then
SetPenColour( green );
MoveToGlobal( basex + offset, basey );
Draw( word );
SetPenColour( white );
else
SetTextStyle( bold );
MoveToGlobal( basex + offset, basey );
Draw( word );
SetTextStyle( normal );
end if;
TreatAsTitle := false;
elsif Found and TreatAsTitle then
TreatAsTitle := Equal_Case_Insensitive (Word, "body"); -- if body, still may be coming
elsif c.SourceLanguage = Ada_Language or c.SourceLanguage = BUSH then
if Equal_Case_Insensitive (Word, "procedure") or
Equal_Case_Insensitive (Word, "function") or
Equal_Case_Insensitive (Word, "package") or
Equal_Case_Insensitive (Word, "task") then
TreatAsTitle := true;
end if;
elsif c.SourceLanguage = Perl then
if Equal_Case_Insensitive (Word, "function") or
Equal_Case_Insensitive (Word, "sub") then
TreatAsTitle := true;
end if;
elsif c.SourceLanguage = Shell or c.SourceLanguage = PHP then
if Equal_Case_Insensitive (Word, "function") then
TreatAsTitle := true;
end if;
end if;
end HilightKeyword;
procedure HilightAllKeywords is
-- locate potential keywords and pass them to HilightKeyword
VisibleTextLength : integer := 0;
LastSpacePos : integer := 0;
WillBeLastSpacePos : integer := 0;
InStr : boolean := false;
InStr2 : boolean := false;
InStr3 : boolean := false;
--NextIsTitle : boolean := false;
keywordBreakChar : boolean;
ch : character;
begin
VisibleTextLength := c.frame.right - c.frame.left - 1;
Append (Line255, " ");
if length( Line255 ) < VisibleTextLength then
VisibleTextLength := length( Line255 );
end if;
-- Note: this won't hilight at end of line; eol requires
-- special handling, but I can't be bothered right now
for i in 1..VisibleTextLength loop
ch := Element( Line255, i );
keywordBreakChar := ( ch < 'a' or ch > 'z') and
( ch < 'A' or ch > 'Z' ) and
( ch < '0' or ch > '9' ) and
( ch /= '_' ) and ( ch /= '.' );
-- Hilighting HTML tags? Allow <,/,& and ?.
if c.HTMLTagStyle then
keywordBreakChar := keywordBreakChar and ( ch /= '<' ) and
( ch /= '/' ) and ( ch /= '&' ) and ( ch /= '?' ) and ( ch /= '.' );
end if;
-- // is a comment in PHP, but we want /XYZ to be treated as a keyword
if ch = '/' and ( c.LanguageData.all ( c.SourceLanguage ).CommentStyle = PHPStyle and c.HTMLTagStyle ) then
if i > 1 then -- test for // comment
if ch = '/' and then Element( Line255, i-1 ) = '/' then
exit; -- the rest is C-style line comment
end if;
end if;
end if;
if keywordBreakChar then
if c.LanguageData.all ( c.SourceLanguage ).CommentStyle = AdaStyle then
if i > 1 then -- test for comment
if ch = '-' and then Element( Line255, i-1 ) = '-' then
exit; -- exit on Ada-style comment
elsif ch = '>' and then Element( Line255, i-1 ) = '=' then
-- special handling for => arrows
MoveToGlobal( c.frame.left + i-1,
c.frame.top + offset );
SetPenColour( yellow );
Draw( "=>" );
SetPenColour( white );
end if;
end if;
elsif C.LanguageData.all ( c.SourceLanguage ).CommentStyle = ShellStyle then
if ch = '#' then
exit; -- the rest is Shell-style comment
end if;
elsif C.LanguageData.all ( c.SourceLanguage ).CommentStyle = HTMLStyle then
null;
elsif C.LanguageData.all ( c.SourceLanguage ).CommentStyle = CStyle then
if i > 1 then -- test for // comment
if ch = '/' and then Element( Line255, i-1 ) = '/' then
exit; -- the rest is C-style line comment
end if;
end if;
elsif C.LanguageData.all ( c.SourceLanguage ).CommentStyle = PHPStyle then
if ch = '#' then
exit; -- exit on Shell-style comment
elsif i > 1 then -- test for // comment
if ch = '/' and then Element( Line255, i-1 ) = '/' then
exit; -- the rest is C-style line comment
end if;
end if;
else
null; -- unknown
end if;
LastSpacePos := WillBeLastSpacePos;
WillBeLastSpacePos := i;
if not (InStr or InStr2 or Instr3) and then LastSpacePos < i - 1 then
HilightKeyword( c.frame.left + 1,
c.frame.top + offset, LastSpacePos,
Slice( Line255, LastSpacePos+1, i - 1 )
);
end if;
-- toggle string literals
if ch = '"' and not Instr2 then
InStr := not InStr;
end if;
if C.LanguageData.all ( c.SourceLanguage ).CommentStyle /= AdaStyle then
if ch = ''' and not InStr then -- toggle singe quote literal
InStr2 := not InStr2;
end if;
if C.LanguageData.all ( c.SourceLanguage ).Commentstyle = ShellStyle and not InStr then
if ch = '`' then -- toggle singe quote literal
InStr3 := not InStr3;
end if;
end if;
end if;
end if;
end loop;
end HilightAllKeywords;
begin
NoError;
if c.needsRedrawing or c.DirtyLine then
SetTextStyle( normal );
SetPenColour( white );
MarkedLine := c.Mark - c.origin + 1;
if c.DirtyLine and not c.needsRedrawing then -- just do the line
line := c.origin + c.CursorY - 1;
Line255 := To_Unbounded_String (C.List.Element (Line));
MoveToGlobal( c.frame.left+1, c.frame.top + c.CursorY );
if line = MarkedLine then
SetTextStyle( Emphasis );
end if;
Draw( To_String (Line255), c.frame.right - c.frame.left - 1, true );
if line = MarkedLine then
SetTextStyle( Normal );
end if;
offset := c.CursorY; -- needed for HilightAllKeywords
HilightAllKeywords;
if length( c.FindPhrase ) > 0 then
HilightFindPhrase( c.frame.left+1, c.frame.top + c.CursorY );
end if;
else
SetPenColour( outline );
FrameRect3D( c.frame );
SetPenColour( white );
if C.List.Is_Empty then
FillRect( InsetRect( c.frame, 1, 1 ), black );
else
Slice ( c.list, c.origin,
Natural( c.frame.bottom - c.frame.top - 1),
Contents );
if Natural (Contents.Length) < c.frame.bottom - c.frame.top - 1 then
FillRect( InsetRect( c.frame, 1, 1 ), black );
end if;
for i in 1 .. Natural (Contents.Length) loop
Line255 := To_Unbounded_String (Contents.Last_Element);
Contents.Delete_Last;
MoveToGlobal( c.frame.left + 1, c.frame.top + offset );
if i = MarkedLine then
SetTextStyle( Emphasis );
Draw( To_String (Line255), c.frame.right - c.frame.left - 1, true );
SetTextStyle( normal );
else
Draw( To_String (Line255), c.frame.right - c.frame.left - 1, true );
HilightAllKeywords;
if length( c.FindPhrase ) > 0 then
HilightFindPhrase( c.frame.left+1, c.frame.top + offset );
end if;
end if;
Offset := Offset + 1;
end loop;
end if;
end if;
end if;
c.DirtyLine := false;
Draw( AWindowControl( c ) );
end Draw; -- ASourceEditList
---> Window Control Input
procedure Hear( c : in out RootControl; i : AnInputRecord; d : in out ADialogAction ) is
pragma Unreferenced (C, I);
begin
NoError;
d := None;
end Hear;
procedure Hear( c : in out AThermometer; i : AnInputRecord; d : in out ADialogAction ) is
diff : integer;
begin
NoError;
if c.Status = On and i.InputType = KeyInput then
d := None;
c.NeedsRedrawing := true;
case i.key is
when RightKey|' ' =>
if c.value < c.max then
c.value := c.value + 1;
end if;
when LeftKey|DeleteKey =>
if c.value > 0 then
c.value := c.value - 1;
end if;
when HomeKey =>
c.value := 0;
when EndKey =>
c.value := c.max;
when PageUpKey|UpKey =>
diff := c.max / 10;
if c.value < diff then
c.value := 0;
else
c.value := c.value - diff;
end if;
when PageDownKey|DownKey =>
diff := c.max / 10;
if c.value + diff > c.max then
c.value := c.max;
else
c.value := c.value + diff;
end if;
when ReturnKey =>
d := Next;
when others =>
c.NeedsRedrawing := false;
d := ScanNext;
end case;
else
d := None;
end if;
end Hear;
procedure Hear( c : in out AScrollBar; i : AnInputRecord; d : in out ADialogAction ) is
diff : integer;
begin
NoError;
if c.Status = On then
if i.InputType = ButtonUpInput then
if c.Owner = 0 then
d := complete;
else
d := None;
end if;
c.DirtyThumb := true;
if (c.frame.bottom-c.frame.top) < (c.frame.right-c.frame.left) then
-- Horizontal only
if i.UpLocationX < c.frame.left + c.OldThumb - 1 then
diff := c.max / 10;
if c.thumb < diff then
c.thumb := 0;
else
c.thumb := c.thumb - diff;
end if;
elsif i.UpLocationX > c.frame.left + c.OldThumb - 1 then
diff := c.max / 10;
if c.thumb + diff > c.max then
c.thumb := c.max;
else
c.thumb := c.thumb + diff;
end if;
end if;
else
-- Vorizontal only
if i.UpLocationY < c.frame.top + c.OldThumb - 1 then
diff := c.max / 10;
if c.thumb < diff then
c.thumb := 0;
else
c.thumb := c.thumb - diff;
end if;
elsif i.UpLocationY > c.frame.top + c.OldThumb - 1 then
diff := c.max / 10;
if c.thumb + diff > c.max then
c.thumb := c.max;
else
c.thumb := c.thumb + diff;
end if;
end if;
end if;
elsif i.InputType = KeyInput then
if c.Owner = 0 then
d := complete;
else
d := None;
end if;
c.DirtyThumb := true;
case i.key is
when RightKey|' ' =>
if c.thumb < c.max then
c.thumb := c.thumb + 1;
end if;
when LeftKey|DeleteKey =>
if c.thumb > 0 then
c.thumb := c.thumb - 1;
end if;
when PageUpKey|UpKey =>
diff := c.max / 10;
if c.thumb < diff then
c.thumb := 0;
else
c.thumb := c.thumb - diff;
end if;
when PageDownKey|DownKey =>
diff := c.max / 10;
if c.thumb + diff > c.max then
c.thumb := c.max;
else
c.thumb := c.thumb + diff;
end if;
when HomeKey =>
c.thumb := 0;
when EndKey =>
c.thumb := c.max;
when ReturnKey =>
d := Next;
when others =>
c.DirtyThumb := false;
--c.NeedsRedrawing := false;
d := ScanNext;
end case;
end if;
else
d := None;
end if;
end Hear;
procedure Hear( c : in out AStaticLine; i : AnInputRecord; d : in out ADialogAction ) is
pragma Unreferenced (I);
begin
NoError;
if c.Status = On then
d := ScanNext;
else
d := None;
end if;
end Hear;
procedure Hear( c : in out AnEditLine; i : AnInputRecord; d : in out ADialogAction ) is
k : character; -- the key typed
procedure Add is
begin
if length( c.text ) < c.MaxLength then
Insert( c.text, c.CursorX+1, (1 => K));
c.CursorX := c.CursorX + 1;
c.DirtyText := true;
end if;
end Add;
procedure Del is
begin
if c.CursorX > 0 then
c.CursorX := C.CursorX - 1;
Delete( c.text, c.CursorX + 1, c.CursorX + 1 );
c.DirtyText := true;
end if;
end Del;
procedure Clear is
begin
c.text := Null_Unbounded_String;
c.CursorX := 0;
c.NeedsRedrawing := true;
end Clear;
procedure Left is
begin
if c.CursorX > 0 then
c.CursorX := c.CursorX - 1;
end if;
end Left;
procedure Right is
begin
if c.CursorX < Length( c.text ) then
c.CursorX := c.CursorX + 1;
end if;
end Right;
procedure Home is
begin
c.CursorX := 0;
end Home;
procedure Append is
begin
if Length( c.text ) = 0 then
Home;
else
c.CursorX := length( c.text );
end if;
end Append;
begin
NoError;
if c.Status = On then
if i.InputType = ButtonUpInput then
c.CursorX := (i.UpLocationX - c.frame.left );
if c.CursorX > length( c.Text ) then
c.CursorX := length( c.Text );
elsif c.CursorX < 0 then
c.CursorX := 0;
end if;
d := None;
elsif i.InputType = KeyInput then
k := i.key;
d := None;
case k is
when LeftKey => Left;
when RightKey => Right;
when DownKey|HomeKey => Home;
when UpKey|EndKey => Append;
when DeleteKey => Del;
when ClearKey => Clear;
when ReturnKey => d := Next;
when others =>
if k >= ' ' and k <= '~' then
Add;
if c.AdvanceMode then
if length(c.text) = c.frame.right -
c.frame.left + 1 then -- field full? advance
d :=next;
end if;
end if;
end if;
end case;
else
d := none;
end if;
else
d := none;
end if;
end Hear;
procedure Hear( c : in out AnIntegerEditLine; i : AnInputRecord;
d : in out ADialogAction ) is
begin
NoError;
if c.Status = On and i.InputType = KeyInput then
if i.Key >= '0' and i.Key <= '9' then
Hear( AnEditLine( c ), i, d );
elsif i.Key = '+' or i.Key = '-' then
if Length( c.text ) = 0 then
Hear( AnEditLine( c ), i, d );
else
Beep( BadInput );
end if;
elsif i.Key <= ' ' or i.key = DeleteKey then
Hear( AnEditLine( c ), i, d );
else
Beep( BadInput );
end if;
end if;
end Hear;
procedure Hear( c : in out ALongIntEditLine; i : AnInputRecord;
d : in out ADialogAction ) is
begin
NoError;
if c.Status = On and i.InputType = KeyInput then
if i.Key >= '0' and i.Key <= '9' then
Hear( AnEditLine( c ), i, d );
elsif i.Key = '+' or i.Key = '-' then
if Length( c.text ) = 0 then
Hear( AnEditLine( c ), i, d );
else
Beep( BadInput );
end if;
elsif i.Key <= ' ' or i.Key = DeleteKey then
Hear( AnEditLine( c ), i, d );
else
Beep( BadInput );
end if;
end if;
end Hear;
procedure Hear( c : in out AFloatEditLine; i : AnInputRecord;
d : in out ADialogAction ) is
begin
NoError;
if c.Status = On and i.InputType = KeyInput then
if i.Key >= '0' and i.Key <='9' then
Hear( AnEditLine( c ), i, d );
elsif i.Key = '+' or i.Key = '-' then
if length( c.text ) = 0 then
Hear( AnEditLine( c ), i, d );
else
Beep( BadInput );
end if;
elsif i.Key <= ' ' or i.Key = '.' or i.Key = DeleteKey then
Hear( AnEditLine( c ), i, d );
else
Beep( BadInput );
end if;
end if;
end Hear;
procedure Hear( c : in out ACheckBox; i : AnInputRecord; d : in out ADialogAction ) is
begin
NoError;
if c.Status = On then
if i.InputType = ButtonUpInput then
c.checked := not c.checked;
c.NeedsRedrawing := true;
d := None;
elsif i.InputType = KeyInput then
d := ScanNext;
case i.key is
when ' ' =>
c.checked := not c.checked;
c.NeedsRedrawing := true;
d := None;
when RightKey =>
d := right;
when LeftKey =>
d := left;
when UpKey =>
d := up;
when DownKey =>
d := down;
when ReturnKey =>
d := Next;
when others =>
null;
end case;
end if;
else
d := None;
end if;
end Hear;
procedure Hear( c : in out ARadioButton; i : AnInputRecord; d : in out ADialogAction ) is
begin
NoError;
if c.Status = On then
if i.InputType = ButtonUpInput then
c.checked := true;
c.NeedsRedrawing := true;
d := FixFamily;
elsif i.InputType = KeyInput then
d := ScanNext;
case i.key is
when ' ' =>
c.checked := true;
c.NeedsRedrawing := true;
d := FixFamily;
when RightKey =>
d := right;
when LeftKey =>
d := left;
when UpKey =>
d := up;
when DownKey =>
d := down;
when ReturnKey =>
d := Next;
when others =>
null;
end case;
end if;
else
d := None;
end if;
end Hear;
procedure Hear( c : in out ASimpleButton; i : AnInputRecord; d : in out ADialogAction ) is
k : character; -- for delay
procedure Blink is
begin
for i in 1..2 loop
SetTextStyle( bold );
SetPenColour( c.colour );
MoveToGlobal( c.frame.left+4, c.frame.top );
Draw( To_String (C.Text));
RevealNow;
WaitFor( 6 );
Invalid( c );
Draw( c );
--MoveToGlobal( c.frame.left+4, c.frame.top );
--SetTextStyle( Normal );
--Draw( c.text );
RevealNow;
WaitFor( 6 );
end loop;
end Blink;
begin
NoError;
if c.Status = On then
if i.InputType = ButtonUpInput then
d := Complete;
Blink;
elsif i.InputType = KeyInput then
k := i.key;
if k = ReturnKey or else k = ' ' then
d := Complete;
Blink;
elsif k = RightKey then
d := Right;
elsif k = DownKey then
d := Down;
elsif k = LeftKey then
d := Left;
elsif k = UpKey then
d := Up;
else
d := ScanNext;
end if;
end if; -- key imput
else
d := None;
end if;
end Hear;
procedure Hear( c : in out AWindowButton; i : AnInputRecord; d : in out ADialogAction ) is
k : character; -- for delay
begin
NoError;
if c.Status = On and i.InputType = KeyInput then
k := i.key;
if k = ReturnKey or else k = ' ' then
if length( c.link ) > 0 then
d := FollowLink;
else
d := Complete;
end if;
for i in 1..2 loop
SetTextStyle( bold );
SetPenColour( white );
MoveToGlobal( c.frame.left+4, c.frame.top );
Draw( To_String (C.Text) );
RevealNow;
WaitFor( 6 );
MoveToGlobal( c.frame.left+4, c.frame.top );
SetTextStyle( Normal );
Draw( To_String (C.Text) );
RevealNow;
WaitFor( 6 );
end loop;
elsif k = RightKey then
d := Right;
elsif k = DownKey then
d := Down;
elsif k = LeftKey then
d := Left;
elsif k = UpKey then
d := Up;
else
d := ScanNext;
end if;
else
d := None;
end if;
end Hear;
procedure Hear( c : in out ARectangle; i : AnInputRecord; d : in out ADialogAction ) is
pragma Unreferenced (I);
begin
NoError;
if c.Status = On then
d := ScanNext;
else
d := None;
end if;
end Hear; -- ARectangle
procedure Hear( c : in out ALine'class; i : AnInputRecord; d : in out ADialogAction ) is
pragma Unreferenced (I);
begin
NoError;
if c.Status = On then
d := ScanNext;
else
d := None;
end if;
end Hear; -- ALine
procedure Hear( c : in out AStaticList; i : AnInputRecord; d : in out
ADialogAction ) is
Distance : integer;
LastLine : integer; -- last legal origin
Height : integer; -- height of control
NewOrigin: Natural;
begin
NoError;
if c.Status = On and not c.List.Is_Empty then
if i.InputType = ButtonUpInput then
Distance := i.UpLocationY - c.frame.top - c.CursorY;
MoveCursor( c, 0, Distance );
if Distance = 0 then
if GetMark( c ) = GetCurrent( c ) then
SetMark( c, -1 );
else
SetMark( c, GetCurrent( c ) );
end if;
end if;
elsif i.InputType = KeyInput then
d := None;
Height := c.frame.bottom - c.frame.top;
LastLine := Natural ( C.List.Length) - (Height - 2);
if LastLine < 1 then
LastLine := 1;
end if;
case i.key is
when UpKey|LeftKey =>
MoveCursor( c, 0, -1 );
when DownKey|RightKey =>
MoveCursor( c, 0, +1 );
when PageDownKey =>
if c.Origin + Height - 2 > LastLine then
NewOrigin := LastLine;
else
NewOrigin := c.Origin + Natural( Height - 2 );
end if;
if NewOrigin /= c.Origin then
c.Origin := NewOrigin;
c.NeedsRedrawing := true;
end if;
when PageUpKey =>
if c.Origin - (Height - 2) < 1 then
NewOrigin := 1;
else
NewOrigin := c.Origin - ( Height - 2 );
end if;
if NewOrigin /= c.Origin then
c.Origin := NewOrigin;
c.NeedsRedrawing := true;
end if;
when HomeKey =>
c.Origin := 1;
c.NeedsRedrawing := true;
when EndKey =>
if c.Origin /= LastLine then
c.Origin := LastLine;
c.NeedsRedrawing := true;
end if;
when others =>
d := ScanNext;
end case;
end if; -- input type
else
d := ScanNext;
end if;
exception when others => DrawErrLn; DrawErr( "Hear(sl) exceptions" ); raise;
end Hear; -- AStaticList
procedure Hear( c : in out ACheckList; i : AnInputRecord; d : in out
ADialogAction ) is
Distance : integer;
line : Integer;
begin
NoError;
if c.Status = On and not c.List.Is_Empty then
if i.InputType = ButtonUpInput then
Distance := i.UpLocationY - c.frame.top - c.CursorY;
MoveCursor( c, 0, Distance );
if Distance = 0 then
if GetMark( c ) = GetCurrent( c ) then
SetMark( c, -1 );
else
SetMark( c, GetCurrent( c ) );
end if;
end if;
if not C.Checks.Is_Empty then
Line := GetCurrent (c);
if Natural (c.Checks.Length) >= Line then
C.Checks.Replace_Element (Line, not c.Checks.Element (Line));
c.NeedsRedrawing := true;
end if;
end if;
elsif i.InputType = KeyInput then
if i.Key = ReturnKey or else i.Key = ' ' then
if not C.Checks.Is_Empty then
Line := GetCurrent (C);
if Natural (C.Checks.Length) >= Line then
C.Checks.Replace_Element (Line, not c.Checks.Element (Line));
c.NeedsRedrawing := true;
end if;
end if;
else
Hear( AStaticList( c ), i, d );
end if;
end if;
else
d := ScanNext;
end if;
end Hear; -- ACheckList
procedure Hear( c : in out ARadioList; i : AnInputRecord; d : in out
ADialogAction ) is
Distance : integer;
line : integer;
begin
NoError;
if c.Status = On and not c.List.Is_Empty then
if i.InputType = ButtonUpInput then
Distance := i.UpLocationY - c.frame.top - c.CursorY;
MoveCursor( c, 0, Distance );
if Distance = 0 then
if GetMark( c ) = GetCurrent( c ) then
SetMark( c, -1 );
else
SetMark( c, GetCurrent( c ) );
end if;
end if;
if not C.Checks.Is_Empty then
Line := GetCurrent( c );
if Natural (C.Checks.Length) >= Line then
if c.LastCheck /= 0 then
C.Checks.Replace_Element (C.LastCheck, false );
end if;
C.Checks.Replace_Element (Line, true );
c.NeedsRedrawing := true;
c.LastCheck := Line;
end if;
end if;
elsif i.InputType = KeyInput then
if i.Key = ReturnKey or else i.Key = ' ' then
if not C.Checks.Is_Empty then
Line := GetCurrent( c );
if Natural (C.Checks.Length) >= Line then
if c.LastCheck /= 0 then
C.Checks.Replace_Element (C.LastCheck, false );
end if;
C.Checks.Replace_Element (Line, True);
c.NeedsRedrawing := true;
c.LastCheck := Line;
end if;
end if;
else
Hear( AStaticList( c ), i, d );
end if;
end if;
else
d := ScanNext;
end if;
exception when others=> DrawErrLn; DrawErr( "Hear(rl) exception" ); raise;
end Hear; -- ARadioList
procedure Hear( c : in out AnEditList; i : AnInputRecord; d : in out
ADialogAction ) is
DistanceX : integer;
DistanceY : integer;
line : integer; -- line # of text in list
k : character; -- the key typed
text : Unbounded_String; -- the text
procedure AdjustCursorForEOL is
-- note! uses line and text
begin
Line := c.origin + c.CursorY - 1;
Text := To_Unbounded_String (C.List.Element (line));
if c.CursorX > length( text ) + 1 then
c.CursorX := length( text ) + 1;
end if;
end AdjustCursorForEOL;
procedure Add is
begin
Insert( text, c.CursorX, (1 => K));
C.List.Replace_Element (line, To_String (Text) );
if length( text ) >= c.frame.right - c.frame.left then
JustifyText( c, c.frame.right - c.frame.left - 1, line );
c.NeedsRedrawing := true;
else
c.DirtyLine := true;
end if;
c.CursorX := c.CursorX + 1;
end Add;
procedure Del is
function isParagraphStart( A_Line_Of_Text : string ) return boolean is
-- does the line of text look like the start of a paragraph (blank line or
-- indented)
begin
if A_Line_Of_Text'Length = 0 then
return true;
elsif A_Line_Of_Text (A_Line_Of_Text'First) = ' ' then
return true;
end if;
return false;
end isParagraphStart;
begin
if c.CursorX > 1 then
c.CursorX := C.CursorX - 1;
Delete( text, c.CursorX , c.CursorX );
C.List.Replace_Element (Line, To_String (Text));
if not C.list.Is_Empty then
declare
NextText : constant String := c.List.Element (line+1);
begin
if not isParagraphStart( NextText ) then
Append( Text, NextText);
C.List.Replace_Element (Line, To_String (Text)); -- combine lines
c.List.Delete (line + 1 ); -- discard previous
JustifyText( c, c.frame.right - c.frame.left - 1, line );
c.NeedsRedrawing := true;
else
c.DirtyLine := true;
end if;
end;
end if;
elsif line > 1 then -- move the cursor up
line := line - 1;
if c.CursorY > 1 then
if c.Origin > 1 and then line > Natural (c.list.Length) -
(c.frame.bottom - c.frame.top) then
-- keep list in window
c.Origin := c.Origin - 1; -- when del near bottom
else
c.CursorY := c.CursorY - 1;
end if;
else
c.Origin := c.Origin - 1;
end if;
declare
Prevtext : constant String := c.List.Element (line);
begin
if length( Text ) > 0 then
c.CursorX := PrevText'Length;
else
c.CursorX := PrevText'Length + 1;
end if;
C.List.Replace_Element (line, PrevText & To_String (Text)); -- combine lines
end;
C.List.Delete (line + 1 ); -- discard previous
JustifyText( c, c.frame.right - c.frame.left - 1, line );
c.NeedsRedrawing := true;
end if;
end Del;
procedure Clear is
procedure ClearALine( line : Natural ) is
begin
C.List.Delete (line );
if C.List.Is_Empty then
c.CursorX := 1;
c.CursorY := 1;
elsif line > Natural (C.List.Length) then
MoveCursor( c, 0, -1 );
else
MoveCursor( c, 0, 0 );
end if;
end ClearALine;
begin
if c.mark < 0 then
ClearALine( line );
else
-- clear n lines from mark
for i in c.mark..line loop
ClearALine( c.mark );
end loop;
-- reposition to mark
MoveCursor( c, 0, -GetCurrent( c ) );
MoveCursor( c, 0, c.mark-1 );
end if;
c.needsRedrawing := true;
end Clear;
procedure Left is
begin
if c.CursorX > 1 then
c.CursorX := c.CursorX - 1; --MoveCursor(c, -1, 0 );
else
MoveCursor(c, 256, -1);
end if;
end Left;
procedure Right is
begin
if c.CursorX <= Length( text ) then
c.CursorX := c.CursorX + 1;
else
if line < Natural (c.list.Length) then
c.CursorX := 1;
MoveCursor( c, 0, +1 );
end if;
end if;
end Right;
procedure DoReturn is
NewText : unbounded_string;
begin
-- should really cut off line, but that requires inserting a new
-- string into the middle of the list -- not yet written
if c.CursorX <= length( text ) then
NewText := Tail( text, length( text ) - c.CursorX + 1 );
Delete( Text, c.CursorX, length( text ) );
C.List.Replace_Element (line, To_String (Text));
else
NewText := Null_Unbounded_String;
end if;
if line < Natural (c.list.Length) then
C.List.Insert (line+1, To_String (NewText) );
else
C.List.Prepend (To_String (NewText) );
end if;
c.needsRedrawing := true;
c.CursorX := 1;
MoveCursor( c, 0, 1 );
end DoReturn;
procedure DoForwardSearch is
newpos : integer;
begin
c.ForwardCharSearchMode := false;
newpos := c.CursorX;
for z in c.CursorX+1..length( text ) loop
if Element( text, z ) = i.Key then
newpos := z;
exit;
end if;
end loop;
if newpos = c.CursorX then
Beep( Failure );
else
c.CursorX := newpos;
c.needsRedrawing := true;
end if;
end DoForwardSearch;
procedure StartNewList is
begin
C.List.Prepend ((1 => I.Key));
c.CursorX := 2;
c.Origin := 1;
c.CursorY := 1;
c.needsRedrawing := true;
end StartNewList;
procedure StartBlankList is
begin
C.List.Prepend ("");
C.List.Prepend ("");
c.CursorX := 1;
c.Origin := 1;
c.CursorY := 2;
c.needsRedrawing := true;
end StartBlankList;
begin
NoError;
d := None;
if c.Status = On then
if i.InputType = ButtonUpInput and not c.List.Is_Empty then
DistanceY := i.UpLocationY - c.frame.top - c.CursorY;
DistanceX := i.UpLocationX - c.frame.left - c.CursorX;
MoveCursor( c, DistanceX, DistanceY );
if DistanceY = 0 then
if GetMark( c ) = GetCurrent( c ) then
SetMark( c, -1 );
else
SetMark( c, GetCurrent( c ) );
end if;
end if;
elsif i.InputType = KeyInput then
if not C.List.Is_Empty then
k := i.key;
line := GetCurrent( c );
--line := c.origin + c.CursorY - 1;
Text := To_Unbounded_String (C.List.Element (line));
-- should be buffered in a field
if c.ForwardCharSearchMode then
DoForwardSearch;
return;
end if;
case k is
when LeftKey => Left;
when RightKey => Right;
when DeleteKey => Del;
when ClearKey => Clear;
c.Touched := true;
when ReturnKey => DoReturn;
c.Touched := true;
when CSearchKey =>
c.ForwardCharSearchMode := true;
when others =>
if k >= ' ' and k <= '~' then
Add;
c.Touched := true;
else
Hear( AStaticList( c ), i, d );
AdjustCursorForEOL;
end if;
end case;
elsif i.key >= ' ' and i.key <= '~' then
StartNewList;
c.Touched := true;
elsif i.key = ReturnKey then
StartBlankList;
c.Touched := true;
end if;
end if;
else
d := None;
end if;
end Hear; -- AnEditList
procedure Hear( c : in out ASourceEditList; i : AnInputRecord; d : in out
ADialogAction ) is
DistanceX : integer;
DistanceY : integer;
line : integer; -- line # of text in list
k : character; -- the key typed
text : Unbounded_String; -- the text
procedure AdjustCursorForEOL is
-- note! uses line and text
begin
Line := c.origin + c.CursorY - 1;
Text := To_Unbounded_String (c.List.Element (line));
if c.CursorX > length( text ) + 1 then
c.CursorX := length( text ) + 1;
end if;
end AdjustCursorForEOL;
procedure Add is
begin
-- Starting to insert new typing? Start a new insert area.
if c.InsertedLines = 0 then -- starting?
c.InsertedFirst := c.origin + c.CursorY - 1;
c.InsertedLines := 1; -- this line
end if;
Insert( text, c.CursorX, (1 => K)); -- add char
if length( text ) >= c.frame.right - c.frame.left then -- too big?
C.List.Replace_Element (line, To_String (Text) ); -- update ln
JustifyText( c, c.frame.right - c.frame.left - 1, line ); -- justify
c.NeedsRedrawing := true; -- redraw it
else -- fits?
C.List.Replace_Element (line, To_String (Text)); -- update ln
c.DirtyLine := true; -- redraw ln
end if;
c.CursorX := c.CursorX + 1; -- advance
end Add;
procedure Del is
begin
if c.CursorX > 1 then
c.CursorX := C.CursorX - 1;
Delete( text, c.CursorX , c.CursorX );
C.List.Replace_Element (line, To_String (Text) );
c.dirtyLine := true;
elsif line > 1 then -- move the cursor up
line := line - 1;
if c.CursorY > 1 then
if c.Origin > 1 and then line > Natural (c.list.Length) -
(c.frame.bottom - c.frame.top) then
-- keep list in window
c.Origin := c.Origin - 1; -- when del near bottom
else
c.CursorY := c.CursorY - 1;
end if;
else
c.Origin := c.Origin - 1;
end if;
declare
Prevtext : constant String := C.List.Element (Line);
begin
if length( Text ) > 0 then
c.CursorX := PrevText'Length;
else
c.CursorX := PrevText'Length + 1;
end if;
C.List.Replace_Element (line, PrevText & To_String (Text)); -- combine lines
end;
C.List.Delete (line + 1 ); -- discard previous
-- insert area? justify it. If no insert area, don't.
if c.InsertedLines > 0 then
if c.InsertedFirst = line+1 then
c.InsertedFirst := c.InsertedFirst - 1; -- lift ins area up
c.InsertedLines := c.InsertedLines - 1; -- move up bottom
end if;
c.InsertedLines := c.InsertedLines - 1; -- move up bottom
--JustifyText( c, c.frame.right - c.frame.left - 1, line );
end if;
c.NeedsRedrawing := true;
end if;
end Del;
procedure Clear is
procedure ClearALine( line : Natural ) is
begin
C.List.Delete (line );
if c.List.Is_Empty then
c.CursorX := 1;
c.CursorY := 1;
elsif line > Natural (C.List.Length) then
MoveCursor( c, 0, -1 );
else
MoveCursor( c, 0, 0 );
end if;
end ClearALine;
begin
if c.mark < 0 then
ClearALine( line );
else
-- clear n lines from mark
for i in c.mark..line loop
ClearALine( c.mark );
end loop;
-- reposition to mark
MoveCursor( c, 0, -GetCurrent( c ) );
MoveCursor( c, 0, c.mark-1 );
end if;
c.needsRedrawing := true;
end Clear;
procedure Left is
begin
if c.CursorX > 1 then
c.CursorX := c.CursorX - 1; --MoveCursor(c, -1, 0 );
else
if c.InsertedLines > 0 then
if line = c.InsertedFirst then
c.InsertedLines := 0;
end if;
end if;
MoveCursor(c, 256, -1);
end if;
end Left;
procedure Right is
begin
if c.CursorX <= Length( text ) then
c.CursorX := c.CursorX + 1;
else
if c.InsertedLines > 0 then
if line = c.InsertedFirst + c.InsertedLines - 1 then
c.InsertedLines := 0;
end if;
end if;
if line < Natural (c.list.Length) then
c.CursorX := 1;
MoveCursor( c, 0, +1 );
end if;
end if;
end Right;
procedure DoIndent is
-- indent line same number of spaces as line above it
begin
-- DoReturn makes a new line, so we need to reload "text"
line := GetCurrent( c );
Text := To_Unbounded_String (C.List.Element (Line));
if line > 1 then -- if current line is not the first (never =1?)
declare
LineAbove : constant String := C.List.Element (line-1);
Spacepos : Positive := Lineabove'First;
begin
while Spacepos <= Lineabove'Last
and then Lineabove (Spacepos) /= ' ' loop
Insert( Text, c.CursorX, (1=>' '));
SpacePos := SpacePos + 1;
end loop;
C.List.Replace_Element (line, To_String (Text));
MoveCursor( c, SpacePos-1, 0 ); -- move to end of spaces
end;
end if;
c.NeedsRedrawing := true;
end DoIndent;
procedure DoReturn is
procedure AutoSpell is
-- extract the first word (or if "end", first two words)
-- and if a mispelling of a long Ada keyword, replace
-- it with the proper spelling. Do only long keywords
-- to avoid fixing legitimate identifiers.
--
-- assumes Text is the text to correct
--
FirstPos, SpacePos, LastPos : natural := 0;
OldTextLength : integer;
Word : unbounded_string;
Changed : boolean := false; -- true if word was corrected
begin
OldTextLength := Length( Text );
-- extract the word(s) to test
for i in 1..Length( Text ) loop
if Element( Text, i ) /= ' ' then
FirstPos := i;
exit;
end if;
end loop;
if FirstPos = 0 then -- null string
return;
end if;
for i in FirstPos + 1..length( Text ) loop
if Element( text, i ) = ' ' then
LastPos := i - 1;
exit;
end if;
end loop;
if LastPos = 0 then -- no trailing space?
LastPos := length( Text );
end if;
Word := Unbounded_Slice( Text, FirstPos, LastPos );
if Word = "end" and LastPos < length( Text ) then
SpacePos := LastPos+1;
LastPos := 0;
for i in SpacePos+1..length( Text ) loop
if Element( text, i ) = ' ' then
LastPos := i - 1;
exit;
end if;
end loop;
if LastPos = 0 then -- no trailing space?
LastPos := length( Text );
end if;
Word := Unbounded_Slice( Text, FirstPos, LastPos );
end if;
-- take first word (or if "end", first two words) and test
-- for typos
Changed := false;
for I in Strings_Used_By_Autospell'Range loop
if TypoOf( To_String (Word), To_String (Strings_Used_By_Autospell (I))) then
Delete( Text, FirstPos, LastPos );
Insert( Text, FirstPos, To_String (Strings_Used_By_Autospell (I)));
Changed := true;
exit;
end if;
end loop;
if Changed then
C.List.Replace_Element (line, To_String (Text) );
SessionLog( "AutoSpell: " & To_String (Word) & " corrected" );
-- spell checking will add no more than 1 letter
if length( text ) > OldTextLength then
c.CursorX := c.CursorX + 1;
end if;
elsif LastPos /= OldTextLength then
-- no first word changes and not entire line?
-- try fixing ending words
OldTextLength := length( Text );
FirstPos := 0;
LastPos := length( Text );
for i in reverse 1..LastPos-1 loop
if Element( Text, i ) = ' ' then
FirstPos := i+1;
exit;
end if;
end loop;
if FirstPos /= 0 then
Changed := false;
Word := Unbounded_Slice ( Text, FirstPos, LastPos);
if TypoOf( To_String (Word), "then" ) then
Delete( Text, FirstPos, LastPos );
Insert( Text, FirstPos, "then");
Changed := true;
elsif TypoOf( To_String (Word), "loop") then
Delete( Text, FirstPos, LastPos );
Insert( Text, FirstPos, "loop");
Changed := true;
end if;
if Changed then
C.List.Replace_Element (line, To_String (Text));
SessionLog( "AutoSpell: " & To_String (Word) & " corrected" );
-- spell checking will add no more than 1 letter
if length( text ) > OldTextLength then
c.CursorX := c.CursorX + 1;
end if;
end if;
end if;
end if;
end AutoSpell;
NewText : unbounded_string;
begin
-- should really cut off line, but that requires inserting a new
-- string into the middle of the list -- not yet written
if c.insertedLines = 0 then
c.insertedFirst := c.origin + c.CursorY;
end if;
c.insertedLines := c.insertedLines + 1;
AutoSpell;
if c.CursorX <= length( text ) then
NewText := Tail( text, length( text ) - c.CursorX + 1 );
Delete( Text, c.CursorX, length( text ) );
C.List.Replace_Element (line, To_String (Text) );
else
NewText := Null_Unbounded_String;
end if;
if line < Natural (c.list.Length) then
C.List.Insert (line+1, To_String (NewText) );
else
C.List.Prepend (To_String (NewText) );
end if;
c.needsRedrawing := true;
c.CursorX := 1;
MoveCursor( c, 0, 1 );
DoIndent;
end DoReturn;
procedure DoForwardSearch is
newpos : integer;
begin
c.ForwardCharSearchMode := false;
newpos := c.CursorX;
for z in c.CursorX+1..length( text ) loop
if Element( text, z ) = i.Key then
newpos := z;
exit;
end if;
end loop;
if newpos = c.CursorX then
Beep( Failure );
else
c.CursorX := newpos;
c.needsRedrawing := true;
end if;
end DoForwardSearch;
procedure StartNewList is
begin
C.List.Prepend ((1 => I.Key));
c.CursorX := 2;
c.Origin := 1;
c.CursorY := 1;
c.insertedLines := 0;
c.needsRedrawing := true;
end StartNewList;
procedure StartBlankList is
begin
C.List.Prepend ("");
C.List.Prepend ("");
c.CursorX := 1;
c.Origin := 1;
c.CursorY := 2;
c.insertedLines := 0;
c.needsRedrawing := true;
end StartBlankList;
begin
NoError;
if i.InputType = ButtonUpInput and not C.List.Is_Empty then
DistanceY := i.UpLocationY - c.frame.top - c.CursorY;
DistanceX := i.UpLocationX - c.frame.left - c.CursorX;
MoveCursor( c, DistanceX, DistanceY );
if DistanceY = 0 then
if GetMark( c ) = GetCurrent( c ) then
SetMark( c, -1 );
else
SetMark( c, GetCurrent( c ) );
end if;
end if;
c.InsertedLines := 0;
elsif i.InputType = KeyInput then
d := None;
if not C.List.Is_Empty then
k := i.key;
line := GetCurrent( c );
--line := c.origin + c.CursorY - 1;
Text := To_Unbounded_String (C.List.Element (Line));
-- should be buffered in a field
if c.ForwardCharSearchMode then
DoForwardSearch;
return;
end if;
case k is
when LeftKey =>
Left;
when RightKey =>
Right;
when UpKey =>
if c.InsertedLines > 0 then
if GetCurrent( c ) = c.InsertedFirst then
c.InsertedLines := 0;
end if;
end if;
MoveCursor( c, 0, -1 );
when DownKey =>
if c.InsertedLines > 0 then
if GetCurrent( c ) = c.InsertedFirst + c.InsertedLines - 1 then
c.InsertedLines := 0;
end if;
end if;
MoveCursor( c, 0, +1 );
when DeleteKey =>
Del;
c.Touched := true;
when ClearKey =>
Clear;
c.Touched := true;
when ReturnKey =>
DoReturn;
c.Touched := true;
when CSearchKey =>
c.ForwardCharSearchMode := true;
when others =>
if k >= ' ' and k <= '~' then
Add;
c.Touched := true;
else
Hear( AStaticList( c ), i, d );
AdjustCursorForEOL;
end if;
end case;
elsif i.key >= ' ' and i.key <= '~' then
StartNewList;
c.Touched := true;
elsif i.key = ReturnKey then
StartBlankList;
c.Touched := true;
end if;
else
d := None;
end if;
end Hear; -- ASourceEditList
---> Status Selection
function GetStatus( c : in RootControl'class ) return AControlStatus is
begin
NoError;
return c.status;
end GetStatus;
procedure SetStatus( c : in out RootControl; status : AControlStatus ) is
begin
NoError;
c.Status := status;
end SetStatus;
procedure SetStatus( c : in out AnIconicControl; status : AControlStatus ) is
begin
SetStatus( RootControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AWindowControl; status : AControlStatus ) is
begin
SetStatus( RootControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AThermometer; status : AControlStatus ) is
begin
SetStatus( AWindowControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AScrollBar; status : AControlStatus ) is
begin
SetStatus( AWindowControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AStaticLine; status : AControlStatus ) is
begin
SetStatus( AnIconicControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out ACheckBox; status : AControlStatus ) is
begin
if c.status = Off xor status = Off then
c.NeedsRedrawing := true;
end if;
SetStatus( AWindowControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out ARadioButton; status : AControlStatus ) is
begin
if c.status = Off xor status = Off then
c.NeedsRedrawing := true;
end if;
SetStatus( AWindowControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AnEditLine; status : AControlStatus ) is
begin
c.NeedsRedrawing := status /= c.status;
SetStatus( AWindowControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AnIntegerEditLine; status : AControlStatus ) is
begin
SetStatus( AnEditLine( c ), status );
end SetStatus;
procedure SetStatus( c : in out ALongIntEditLine; status : AControlStatus ) is
begin
SetStatus( AnEditLine( c ), status );
end SetStatus;
procedure SetStatus( c : in out AFloatEditLine; status : AControlStatus ) is
begin
SetStatus( AnEditLine( c ), status );
end SetStatus;
procedure SetStatus( c : in out ASimpleButton; status : AControlStatus ) is
begin
if c.status = Off xor status = Off then
c.NeedsRedrawing := true;
end if;
SetStatus( AWindowControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AWindowButton; status : AControlStatus ) is
begin
if c.status = Off xor status = Off then
c.NeedsRedrawing := true;
end if;
SetStatus( AnIconicControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out ARectangle; status : AControlStatus ) is
begin
SetStatus( AnIconicControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out ALine'class; status : AControlStatus ) is
begin
SetStatus( AnIconicControl( c ), status );
end SetStatus;
procedure SetStatus( c : in out AStaticList'class; status : AControlStatus ) is
begin
SetStatus( AWindowControl( c ), status );
end SetStatus;
---> Encoding Controls as Strings
function Encode( c : in RootControl ) return EncodedString is
estr : Encodedstring := Null_Unbounded_String;
begin
NoError;
Encode( estr, c.frame );
Encode( estr, integer( AControlStatus'pos( c.Status ) ) );
-- We'll init CursorX on Decode
-- We'll init CursorY on Decode
-- We'll init NeedsRedrawing on Decode
Encode( estr, c.HotKey );
Encode( estr, c.HasInfo );
if c.HasInfo then
Encode( estr, To_String (C.InfoText));
end if;
Encode( estr, c.StickLeft );
Encode( estr, c.StickTop );
Encode( estr, c.StickRight );
Encode( estr, c.StickBottom );
return estr;
end Encode;
function Encode( c : in AnIconicControl ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( RootControl( c ) );
Encode( estr, To_String (C.Link) );
Encode( estr, c.CloseBeforeFollow );
return estr;
end Encode;
function Encode( c : in AWindowControl ) return EncodedString is
begin
return Encode( RootControl( c ) );
end Encode;
function Encode( c : in AThermometer ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AWindowControl( c ) );
Encode( estr, c.max );
Encode( estr, c.value );
return estr;
end Encode;
function Encode( c : in AScrollBar ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AWindowControl( c ) );
Encode( estr, c.max );
Encode( estr, c.thumb );
return estr;
end Encode;
function Encode( c : in AStaticLine ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AnIconicControl( c ) );
Encode( estr, To_String (C.Text) );
Encode( estr, integer( ATextStyle'pos( c.style ) ) );
Encode( estr, integer( APenColourName'pos( c.colour ) ) ); -- should be RGB
return estr;
end Encode;
function Encode( c : in AnEditLine ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AWindowControl( c ) );
Encode( estr, To_String (c.Text) );
Encode( estr, c.AdvanceMode );
return estr;
end Encode;
function Encode( c : in AnIntegerEditLine ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AnEditLine( c ) );
Encode( estr, c.value );
return estr;
end Encode;
function Encode( c : in ALongIntEditLine ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AnEditLine( c ) );
Encode( estr, c.value );
return estr;
end Encode;
-- function Encode( c : in AFloatEditLine ) return EncodedString is
-- estr : EncodedString;
-- begin
-- estr := Encode( AnEditLine( c ) );
-- Error( TT_NotYetWritten ); -- encoding floats not yet written
-- return estr;
-- end Encode;
function Encode( c : in ACheckBox ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AWindowControl( c ) );
Encode( estr, To_String (C.Text) );
Encode( estr, c.checked );
return estr;
end Encode;
function Encode( c : in ARadioButton ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AWindowControl( c ) );
Encode( estr, To_String (C.Text) );
Encode( estr, c.checked );
Encode( estr, c.family );
return estr;
end Encode;
function Encode( c : in ASimpleButton ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AWindowControl( c ) );
Encode( estr, To_String (C.Text) );
Encode( estr, c.instant );
Encode( estr, integer( APenColourName'pos( c.colour ) ) ); -- should be RGB
return estr;
end Encode;
function Encode( c : in AWindowButton ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AnIconicControl( c ) );
Encode( estr, To_String (C.Text) );
Encode( estr, To_String (c.Link) );
return estr;
end Encode;
function Encode( c : in ARectangle ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AnIconicControl( c ) );
Encode( estr, integer( APenColourName'pos( c.FrameColour ) ) );
Encode( estr, integer( APenColourName'pos( c.BackColour ) ) );
Encode( estr, To_String (C.Text) );
return estr;
end Encode;
function Encode( c : in ALine'class ) return EncodedString is
estr : EncodedString;
begin
estr := Encode( AnIconicControl( c ) );
Encode( estr, integer( APenColourName'pos( c.Colour ) ) );
Encode( estr, c.DownRight );
return estr;
end Encode;
function Encode( c : in AStaticList'class ) return EncodedString is
--estr : EncodedString;
begin
return Encode( AWindowControl( c ) );
end Encode;
-- Decoding Controls From Strings
procedure Decode( estr : in out EncodedString; c : in out RootControl ) is
TempInt : integer := integer'last;
begin
NoError;
Decode( estr, c.frame );
Decode( estr, TempInt );
c.Status := AControlStatus'val( TempInt );
c.CursorX := 0;
c.CursorY := 0;
c.NeedsRedrawing := true;
Decode( estr, c.HotKey );
Decode( estr, c.HasInfo );
if c.HasInfo then
Decode( estr, c.InfoText );
end if;
Decode( estr, c.StickLeft );
Decode( estr, c.StickTop );
Decode( estr, c.StickRight );
Decode( estr, c.StickBottom );
end Decode;
procedure Decode( estr : in out EncodedString; c : in out AnIconicControl ) is
begin
Decode( estr, RootControl( c ) );
Decode( estr, c.link );
Decode( estr, c.CloseBeforeFollow );
end Decode;
procedure Decode( estr : in out EncodedString; c : in out AWindowControl ) is
begin
Decode( estr, RootControl( c ) );
end Decode;
procedure Decode( estr : in out EncodedString; c : in out AThermometer ) is
begin
Decode( estr, AWindowControl( c ) );
Decode( estr, c.max );
Decode( estr, c.value );
end Decode; -- AThermometer
procedure Decode( estr : in out EncodedString; c : in out AScrollBar ) is
begin
Decode( estr, AWindowControl( c ) );
Decode( estr, c.max );
Decode( estr, c.thumb );
end Decode; -- AScrollBar
procedure Decode( estr : in out EncodedString; c : in out AStaticLine ) is
tempInt : integer := integer'last;
begin
Decode( estr, AnIconicControl( c ) );
Decode( estr, c.text );
Decode( estr, tempInt );
c.Style := ATextStyle'val( tempInt );
Decode( estr, tempInt );
c.Colour := APenColourName'val( tempInt ); -- really should be RGB
end Decode; -- AStaticLine
procedure Decode( estr : in out EncodedString; c : in out AnEditLine ) is
begin
Decode( estr, AWindowControl( c ) );
Decode( estr, c.text );
Decode( estr, c.AdvanceMode );
end Decode; -- AnEditLine
procedure Decode( estr : in out EncodedString; c : in out AnIntegerEditLine ) is
begin
Decode( estr, AnEditLine( c ) );
Decode( estr, c.value );
end Decode; -- AnIntegerEditLine
procedure Decode( estr : in out EncodedString; c : in out ALongIntEditLine ) is
begin
Decode( estr, AnEditLine( c ) );
Decode( estr, c.value );
end Decode; -- ALongIntEditLine
-- procedure Decode( estr : in out EncodedString; c : in out AFloatEditLine ) is
-- begin
-- Decode( estr, AnEditLine( c ) );
-- Error( TT_NotYetWritten );
-- end Decode; -- AFloatEditLine
procedure Decode( estr : in out EncodedString; c : in out ACheckBox ) is
begin
Decode( estr, AWindowControl( c ) );
c.CursorX := 1;
Decode( estr, c.text );
Decode( estr, c.checked );
end Decode; -- ACheckBox
procedure Decode( estr : in out EncodedString; c : in out ARadioButton ) is
begin
Decode( estr, AWindowControl( c ) );
c.CursorX := 1;
Decode( estr, c.text );
Decode( estr, c.checked );
Decode( estr, c.family );
end Decode; -- ARadioButton
procedure Decode( estr : in out EncodedString; c : in out ASimpleButton ) is
tempInt : integer := integer'last;
begin
Decode( estr, AWindowControl( c ) );
c.CursorX := 1;
Decode( estr, c.text );
Decode( estr, c.instant );
c.HotPos := GetHotPos( c.HotKey, To_String (C.Text) );
Decode( estr, tempInt );
c.Colour := APenColourName'val( tempInt );
end Decode; -- ASimpleButton
procedure Decode( estr : in out EncodedString; c : in out AWindowButton ) is
begin
Decode( estr, AnIconicControl( c ) );
c.CursorX := 1;
Decode( estr, c.text );
Decode( estr, c.link );
end Decode; -- AWindowButton
procedure Decode( estr : in out EncodedString; c : in out ARectangle ) is
tempint : integer := integer'last;
begin
Decode( estr, AnIconicControl( c ) );
Decode( estr, tempint );
c.FrameColour := APenColourName'val( tempInt );
Decode( estr, tempint );
c.BackColour := APenColourName'val( tempInt );
Decode( estr, c.text );
end Decode; -- ARectangle
procedure Decode( estr : in out EncodedString; c : in out ALine'class ) is
tempint : integer := integer'last;
begin
Decode( estr, AnIconicControl( c ) );
Decode( estr, tempint );
c.Colour := APenColourName'val( tempInt );
Decode( estr, c.DownRight );
end Decode; -- ALine
procedure Decode( estr : in out EncodedString; c : in out AStaticList'class
) is begin
Decode( estr, AWindowControl( c ) );
end Decode; -- AStaticList, etc.
---> Resizing
procedure Resize( c : in out RootControl; dleft, dtop, dright, dbottom : integer ) is
begin
NoError;
c.frame.left := c.frame.left + dleft;
c.frame.top := c.frame.top + dtop;
c.frame.right := c.frame.right + dright;
c.frame.bottom := c.frame.bottom + dbottom;
Invalid( c );
end Resize;
procedure Resize( c : in out AnIconicControl; dleft, dtop, dright, dbottom : integer ) is
begin
Resize( RootControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AWindowControl; dleft, dtop, dright, dbottom : integer ) is
begin
Resize( RootControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AThermometer; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AScrollBar; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AStaticLine; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AnIconicControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out ACheckBox; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out ARadioButton; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AnEditLine'class; dleft, dtop, dright,
dbottom : integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out ASimpleButton; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AWindowButton; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AnIconicControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out ARectangle; dleft, dtop, dright, dbottom :
integer ) is begin
Resize( AnIconicControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out ALine'class; dleft, dtop, dright, dbottom : integer
) is begin
Resize( AnIconicControl( c ), dleft, dtop, dright, dbottom );
end Resize;
procedure Resize( c : in out AStaticList'class; dleft, dtop, dright,
dbottom : integer ) is begin
Resize( AWindowControl( c ), dleft, dtop, dright, dbottom );
end Resize;
end controls;
texttools/src/userio.adb 0000664 0000764 0000764 00000160732 11774715706 014046 0 ustar ken ken ------------------------------------------------------------------------------
-- USER IO (package body) --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with Ada.Strings;
with Ada.Numerics.Elementary_Functions;
with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Ordered_Sets;
with Ada.Calendar; use Ada.Calendar;
with Ada.Calendar.Formatting;
with Strings; use Strings;
with Ada.Directories;
with Ada.Strings.Fixed;
package body userio is
PackageRunning : boolean := false;
---> Global variables
--
-- Background Colour
BackgroundIsBlue : boolean;
-- Font Characteristics
SystemFontName : constant String := "System Font"; -- fake for text screen
SystemFontSize : constant natural := 12;
-- Pen Characteristics
CurrentStyle : ATextStyle; -- last text style selected
CurrentColour : APenColourName; -- last text colour (unused)
CurrentPenColour : APenColourName; -- last pen colour selected
CurrentAngle : float; -- last pen angle (turtle graphics)
CurrentSize : Points; -- last pen size
ErrorLine : integer; -- y coordinate for next error message
SpoolCounter : natural; -- number of times WaitToReval called
--> Macro variables
MacroFile : constant APathName := "$SYS/macro_file";
-- macro file path
Macros : StrList.Vector; -- contents of macro file:
-- the key + string to equate
AreMacros : boolean; -- true if macro file was loaded
MacroInProgress : boolean; -- true if "do macro" key pressed
IdleJobsDone : boolean; -- true if IdleUserIO jobs incomplete
---> Sound Support
SoundFlag : constant APathName := "$SYS/play_sound" ;
HasSounds : boolean;
---> C routines to support Curses library
Colour_Flag : integer;
pragma Import( C, Colour_Flag, "colour_flag" );
-- colour : integer; -- 0 if monochrome
-- pragma Import( C, colour, "colour" );
lines : integer; -- # lines
pragma Import( C, lines, "lines" );
cols : integer; -- # columns
pragma Import( C, cols, "cols" );
C_hasmouse : integer; -- GPM mouse if 1
pragma Import( C, C_hasmouse, "C_hasmouse" );
C_mousebutton : integer;
pragma Import( C, C_mousebutton, "C_mousebutton" );
C_mousex : integer;
pragma Import( C, C_mousex, "C_mousex" );
C_mousey : integer;
pragma Import( C, C_mousey, "C_mousey" );
procedure StartupCurses;
pragma Import( C, StartupCurses, "StartupCurses" );
procedure ShutdownCurses;
pragma Import( C, ShutdownCurses, "ShutdownCurses" );
procedure ResetCurses;
pragma Import( C, ResetCurses, "ResetCurses" );
--procedure Cls;
--pragma Import( C, Cls, "Cls" ); -- Curses move/clrtobot
--procedure FlushKeys; -- Curses' flushinp
--pragma Import( C, FlushKeys, "FlushKeys" );
function CGetXY return long_integer; -- Curses' getyx
pragma Import( C, CGetXY, "CGetXY" );
function CGetKey return integer; -- Curses' getch (cbreak)
pragma Import( C, CGetKey, "CGetKey");
function CKeypress return integer; -- Curses' getch (nodelay)
pragma Import( C, CKeypress, "CKeypress");
function CKeyDelay return integer; -- halfdelay
pragma Import( C, CKeyDelay, "CKeyDelay" );
-- procedure DrawChar( ch : character ); -- Curses' echoch
-- pragma Import( C, DrawChar, "DrawChar");
procedure SpoolChar( ch : character ); -- Curses' addch
pragma Import( C, SpoolChar, "SpoolChar" );
procedure CSpoolRect( left, top, right, bottom : integer;
ch : character );
pragma Import( C, CSpoolRect, "CSpoolRect" );
type SpecialChar is ( upperleft, lowerleft, upperright, lowerright,
hline, vline );
procedure SpoolSpecial( s : specialChar ); -- line graphics
pragma Import( C, SpoolSpecial, "SpoolSpecial" );
procedure CANSIColour( i : integer );
pragma Import( C, CANSIColour, "CANSIColour" );
procedure Refresh; -- Curses' refresh
pragma Import( C, Refresh, "Refresh" );
procedure CMoveTo( x, y : integer ); -- Curses' move
pragma Import( C, CMoveTo, "CMoveTo" );
function CGetChar( x, y : integer ) return character; -- Curses' mvinch
pragma Import( C, CGetChar, "CGetChar" );
procedure CTextStyle( bold, so, under : character );
pragma Import( C, CTextStyle, "CTextStyle" ); -- Curses' attron/off
procedure CBeep;
pragma Import( C, CBeep, "CBeep" ); -- beep terminal
procedure SetColour( cmode : integer );
pragma Import( C, SetColour, "SetColour" );
---> Basic Terminal Control
procedure GetDisplayInfo( info : in out ADisplayInfoRec ) is
-- Return general info about the display device
MaxX, MaxY : integer;
begin
-- C routines expect no wider than 180
-- enforce a reasonable value for lines
MaxX := cols;
MaxY := lines;
if cols > 180 then
MaxX := 180;
end if;
if lines > 180 then
MaxY := 180;
end if;
-- assume standard monochrome text terminal
info.Fields := 8; -- number of valid fields (excluding itself)
info.TextBased := true; -- is text terminal
info.H_Res := MaxX; -- 80 columns
info.V_Res := MaxY; -- 23 rows (24th for status bar on Wyse)
if Colour_Flag > 0 then
info.C_Res := 1; -- has (ANSI) colour
else
info.C_Res := 0; -- no colour
end if;
info.P_Len := 0; -- no palette
info.D_Buf := 1; -- 1 buffer
info.S_Res := 0; -- no sound (besides beep)
if IsLocal and NotEmpty ("$SYS/beeps_file.zoo") then
info.Y_Res := 1; -- no sound [channels]
else
info.Y_Res := 0; -- no sound [channels]
end if;
end GetDisplayInfo;
procedure GetInputInfo( info : in out AnInputInfoRec ) is
-- Return general info about the input devices
begin
info.Fields := 4; -- number of valid fields (excl. itself)
info.HasKeyboard := true; -- has a keyboard
info.HasDirection := false; -- no directional device (eg. joystick)
info.HasVelocity := false; -- no direction device => no velocity
info.HasLocator := C_hasmouse=1; -- locator device (eg. mouse)
end GetInputInfo;
---> Pen Attributes
--
-- Name2RGB - convert a colour name to it's RGB components
-- RGB2Name - convert RGB components to their colour name
procedure Name2RGB( colour : APenColourName; redC, greenC, blueC :
in out ARGBComponent ) is
-- utility procedure to change from name to RGB
begin
-- for a terminal, fake reasonable values
redC := 100.0; -- default white
blueC := 100.0;
greenC := 100.0;
case Colour is
when ScrollBack => redC := 50.0; blueC := 50.0; greenC := 50.0;
when ScrollThumb => null;
when ThermBack => redC := 50.0; blueC := 50.0; greenC := 50.0;
when ThermFore => null;
when Red => greenC := 0.0; blueC := 0.0;
when Purple => greenC := 0.0;
when Green => redC := 0.0; blueC := 0.0;
when Blue => redC := 0.0; greenC := 0.0;
when Yellow => blueC := 0.0;
when Black => redC := 0.0; blueC := 0.0; greenC := 0.0;
when others => null;
end case;
end Name2RGB;
procedure RGB2Name( redC, greenC, blueC : ARGBComponent; colour :
in out APenColourName ) is
-- utility procedure to change from RGB to name
begin
if redC > 50.0 then
Colour := red;
if greenC > 50.0 and then blueC > 50.0 then
Colour := white;
elsif GreenC > 50.0 then
Colour := yellow;
elsif BlueC > 50.0 then
Colour := purple;
end if;
else
Colour := black;
if greenC > 50.0 and then blueC > 50.0 then
Colour := green;
elsif greenC > 50.0 then
Colour := green;
elsif blueC > 50.0 then
Colour := blue;
end if;
end if;
end RGB2Name;
procedure SetPenColour( name : APenColourName ) is
-- Set the current pen colour by colour name
begin
-- CTextStyle can override colour, so we always send the ASCII seq
CurrentPenColour := Name;
if Colour_Flag > 0 then
case name is
when none => CANSIColour( 0 );
when outline => CANSIColour( 7 );
when scrollBack => CANSIColour( 10 );
when scrollThumb => CANSIColour( 12 );
when thermBack => CANSIColour( 11 );
when thermFore => CANSIColour( 9 );
when White => CANSIColour( 7 );
when Red => CANSIColour( 1 );
when Purple => CANSIColour( 5 );
when Green => CANSIColour( 2 );
when Blue => CANSIColour( 4 );
when Yellow => CANSIColour( 3 );
when Black => CANSIColour( 0 );
end case;
end if;
end SetPenColour;
procedure SetPenColour( redC, greenC, blueC : ARGBComponent ) is
-- Select the current pen colour by RGB values
PenColour : APenColourName := none;
begin
-- for a terminal, equate to reasonable colour name
RGB2Name( redC, greenC, blueC, PenColour );
if PenColour /= CurrentPenColour then
SetPenColour( PenColour );
end if;
end SetPenColour;
procedure SetPenColour( colour : APaletteColour ) is
-- Select the current pen colour from the palette (no effect here)
begin
null;
end SetPenColour;
procedure SetPaletteColour( colour : APaletteColour; name : APenColourName ) is
-- Set a palette colour by colour name (no palette = no effect)
begin
null;
end SetPaletteColour;
procedure SetPaletteColour( colour : APaletteColour; redC, greenC, blueC
: ARGBComponent ) is
-- Set a palette colour by RGB (no palette = no effect)
begin
null;
end SetPaletteColour;
procedure GetPaletteColour( colour : APaletteColour; redC, greenC, blueC
: in out ARGBComponent ) is
-- Get a palette colour's RGB (no palette = no effect)
begin
null;
end GetPaletteColour;
function GetPaletteColour( colour : APaletteColour ) return APenColourName is
pragma Unreferenced (Colour);
-- Get a palette colour's RGB (no palette - just returns white)
begin
return White;
end GetPaletteColour;
function FindPaletteColour( redC, greenC, blueC : ARGBComponent )
return APaletteColour is
pragma Unreferenced (RedC, GreenC, BlueC);
-- search for the closest palette colour (meaningless)
begin
return 0;
end FindPaletteColour;
procedure GetPenColour( redC, greenC, blueC : in out ARGBComponent ) is
-- Return the current pen colour (as RGB components)
begin
NoError;
Name2RGB( CurrentPenColour, redC, greenC, blueC );
end GetPenColour;
function GetPenColour return APenColourName is
-- Return the current pen colour (as a name)
begin
NoError;
return CurrentPenColour;
end GetPenColour;
function GetPenColour return APaletteColour is
-- Return the current pen colour as a palette entry (no effect)
begin
NoError;
return 0;
end GetPenColour;
function GetPenColour( colour : APaletteColour ) return APenColourName is
pragma Unreferenced (Colour);
-- Return a palette colour as a name (no palette - just return white)
begin
NoError;
return White;
end GetPenColour;
-- procedure GetPenColour( colour : APaletteColour; redC, greenC, blueC
-- : in out ARGBComponent ) is
-- pragma Unreferenced (Colour, Redc, Greenc, Bluec);
-- -- Return a palette colour as RGB (no palette = no effect)
-- begin
-- Error( TT_NotYetWritten );
-- end GetPenColour;
procedure GetPenPos( x, y : out integer ) is
temp : long_integer;
begin
NoError;
temp := CGetXY;
x := integer( temp mod 256 );
y := integer( temp / 256 );
end GetPenPos;
procedure SetPenSize( p : points ) is
begin
NoError;
CurrentSize := p;
end SetPenSize;
function GetPenSize return points is
begin
NoError;
return CurrentSize;
end GetPenSize;
procedure GetPixel( x, y : integer; redC, greenC, blueC:out ARGBComponent ) is
ch : character;
begin
ch := CGetChar( x, y );
-- No inverse function to get draw char yet
if ch = ' ' then
redC := 0.0;
greenC := 0.0;
blueC := 0.0;
else
redC := 100.0;
greenC := 100.0;
blueC := 100.0;
end if;
end GetPixel;
-- Turtle Graphics
procedure SetPenAngle( angle : float ) is
begin
CurrentAngle := float( integer(angle) mod 360 ); --rounding error
end SetPenAngle;
procedure ChangePenAngle( degrees : float ) is
begin
CurrentAngle := float(integer(CurrentAngle + degrees) mod 360); --rounding error
end ChangePenAngle;
function GetPenAngle return float is
begin
return CurrentAngle;
end GetPenAngle;
procedure DrawForward( dist : float ) is
use Ada.Numerics.Elementary_Functions;
OldX, OldY, NewX, NewY : integer;
begin
GetPenPos( OldX, OldY );
NewX := OldX + Integer( Cos( CurrentAngle * (Ada.Numerics.Pi / 180.0)) * dist );
NewY := OldY + Integer( Sin( CurrentAngle * (Ada.Numerics.Pi / 180.0)) * dist );
DrawLine( OldX, OldY, NewX, NewY );
end DrawForward;
procedure MoveForward( dist : float ) is
use Ada.Numerics.Elementary_Functions;
OldX, OldY, NewX, NewY : integer;
begin
GetPenPos( OldX, OldY );
NewX := OldX + Integer( Cos( CurrentAngle * (Ada.Numerics.Pi / 180.0)) * dist );
NewY := OldY + Integer( Sin( CurrentAngle * (Ada.Numerics.Pi / 180.0)) * dist );
MoveToGlobal( NewX, NewY );
end MoveForward;
---> Text Attributes
procedure SetTextStyle( style : ATextStyle ) is
-- Change the current text style
begin
if CurrentStyle = Input and Colour_Flag > 0 then
SetPenColour( CurrentColour ); -- kludge: input changes colour
end if;
case style is
when Normal =>
CTextStyle( 'n', 'n', 'n');
when Bold =>
CTextStyle( 'y', 'n', 'n');
when Italic =>
CTextStyle( 'n', 'n', 'y');
when Underline =>
CTextStyle( 'n', 'n', 'y');
when BoldItalic =>
CTextStyle( 'y', 'n', 'n');
when BoldUnderline =>
CTextStyle( 'y', 'n', 'y');
when ItalicUnderline =>
CTextStyle( 'n', 'n', 'y');
when BoldItalicUnderline =>
CTextStyle( 'y', 'y', 'y');
when Success =>
CTextStyle( 'y', 'n', 'n');
when Failure =>
CTextStyle( 'n', 'y', 'n');
when Warning =>
if Colour_Flag > 0 then
CTextStyle( 'y', 'n', 'n');
SetPenColour( yellow );
else
CTextStyle( 'y', 'n', 'n');
end if;
when Status =>
CTextStyle( 'n', 'n', 'n');
when Citation =>
CTextStyle( 'n', 'n', 'n');
when SectionHeading =>
CTextStyle( 'n', 'y', 'n');
when Heading =>
if Colour_Flag > 0 then
CTextStyle( 'n', 'n', 'y');
SetPenColour( yellow );
else
CTextStyle( 'n', 'n', 'y');
end if;
when SubHeading =>
CTextStyle( 'y', 'n', 'n');
when Title =>
CTextStyle( 'y', 'n', 'n');
when Emphasis =>
CTextStyle( 'y', 'n', 'n');
when Marquee =>
if Colour_Flag > 0 then
CTextStyle( 'y', 'n', 'y');
SetPenColour( red );
else
CTextStyle( 'y', 'y', 'y');
end if;
when HeadLine =>
CTextStyle( 'y', 'y', 'y');
when FinePrint =>
CTextStyle( 'n', 'n', 'n');
when DefinedTerm =>
CTextStyle( 'n', 'n', 'y');
when Input =>
if Colour_Flag > 0 then
CTextStyle( 'n', 'n', 'n' );
SetPenColour( white );
CANSIColour( 8 ); -- background colour
else
CTextStyle( 'n', 'y', 'n');
end if;
when Footnote =>
CTextStyle( 'n', 'n', 'n');
when ToAddress =>
CTextStyle( 'n', 'n', 'n');
when FromAddress =>
CTextStyle( 'n', 'n', 'n');
when SubScript =>
CTextStyle( 'n', 'n', 'n');
when SuperScript =>
CTextStyle( 'n', 'n', 'n');
CTextStyle( 'n', 'n', 'n');
end case;
CurrentStyle := style;
end SetTextStyle;
function GetTextStyle return ATextStyle is
-- Get the current text style
begin
return CurrentStyle;
end GetTextStyle;
procedure SetTextColour( name : APenColourName ) is
-- Set the text colour (recorded, but no effect)
begin
CurrentColour := name;
-- change colour here
end SetTextColour;
procedure SetTextFont( font : string; size : natural := 0 ) is
-- Set the text font and size (no fonts = no effect)
begin
null;
end SetTextFont;
procedure SetTextFont( fonts : StrList.Vector; size : natural := 0 ) is
begin
null;
end SetTextFont;
function GetTextColour return APenColourName is
-- Get the text colour
begin
return White; -- CurrentColour
end GetTextColour;
procedure GetTextFont( font : out Unbounded_String; size : out natural ) is
-- Get the text font and size (no fonts = reasonable estimate)
begin
font := To_Unbounded_String (SystemFontName); -- return a reasonable pseudo font & size
size := SystemFontSize;
end GetTextFont;
procedure GetFontNameList( TheList : out StrList.Vector) is
-- get a list of available fonts
begin
TheList.Clear;
TheList.Prepend (SystemFontName);
end GetFontNameList;
procedure GetFontSizeList( font : string; TheList : out StrList.Vector) is
pragma Unreferenced (Font);
-- get a list of sizes for a font
begin
TheList.Clear;
TheList.Prepend (natural'image(SystemFontSize));
end GetFontSizeList;
function GetTextHeight( ch : character ) return integer is
pragma Unreferenced (Ch);
begin
return 1;
end GetTextHeight;
function GetTextHeight( s : string ) return integer is
pragma Unreferenced (S);
begin
return 1;
end GetTextHeight;
function GetTextWidth( ch : character ) return integer is
pragma Unreferenced (Ch);
begin
return 1;
end GetTextWidth;
function GetTextWidth( s : string ) return integer is
begin
return S'Length;
end GetTextWidth;
---> Misc procedures
procedure MoveToGlobal( x, y : in integer ) is
-- Move to cursor (global coordinates)
begin
CMoveTo( x, y );
end MoveToGlobal;
procedure Beep( style : BeepStyles ) is
-- Make the terminal beep (or play a sound effect)
-- beeps should really be extracted and moved to a temp file name!!!!
begin
NoError;
if HasSounds then
declare
OldPath : constant String := Ada.Directories.Current_Directory;
BeepFile : constant String := BeepStyles'Image (Style);
begin
SetPath ("$SYS");
if NotEmpty (BeepFile) then
SessionLog ("Beep: playing " & BeepFile);
PlaySound (BeepFile);
if LastError /= TT_OK then
SessionLog ("Beep: Error playing " & BeepFile, LastError );
else
Ada.Directories.Set_Directory (OldPath);
return; -- don't CBeep
end if;
end if;
Ada.Directories.Set_Directory (OldPath);
end;
end if;
-- either no sound capability, or no sound to play for this beep style
case style is
when StartUp => null; -- no need to beep on startup
when ShutDown => null; -- no need to beep on shutdown
when Status => null; -- no need to beep on a status message
when HourChime => null;
when QuarterChime1 => null;
when QuarterChime2 => null;
when QuarterChime3 => null;
when others => CBeep; -- assume worst: notify with beep by default
end case;
end Beep;
---> Basic Input
procedure GetKey( c : out character ) is
-- Wait for a keypress and return it
begin
c := character'val( CGetKey );
end GetKey;
function Keypress( shortblock : boolean ) return character is
-- Check for a keypress and return it (or else return NullKey)
begin
if ShortBlock then
return character'val( CKeypress );
else
return character'val( CKeyDelay );
end if;
end Keypress;
procedure GetDirection( direction : out ADirection;
velocity : out AVelocity ) is
-- Get the direction device's values (no device = return 0)
begin
direction := 0.0;
velocity := 0.0;
end GetDirection;
procedure GetLocation( x, y : out integer ) is
-- Get the location device's values (no device = 0,0)
begin
x := 0;
y := 0;
end GetLocation;
---> Basic Output
procedure Draw( s : string ) is
-- Draw a string
begin
for i in s'first..s'last loop
SpoolChar( s(i) );
end loop;
if SpoolCounter = 0 then
Refresh;
end if;
end Draw;
procedure Draw (s : in string;
Fieldwidth : in integer;
elipsis : in boolean :=false)is
-- Draw a string with a fieldwidth an optional elipsis (if too long)
OverflowLength : integer;
OldStyle : ATextStyle; -- pad spaces must be in "normal" style
OldColour: APenColourName;
begin
OldStyle := GetTextStyle;
OldColour := GetPenColour;
OverflowLength := S'Length - fieldwidth;
if OverflowLength = 0 then
Draw( s );
elsif OverflowLength > 0 then
if elipsis and fieldwidth > 3 then
Draw( Ada.Strings.Fixed.Head (S, Fieldwidth - 3));
Draw( "..." );
else
Draw( Ada.Strings.Fixed.Head( s, fieldwidth ) );
end if;
else
Draw( s );
SetTextStyle( Normal );
SetPenColour( White );
for i in 1..-OverflowLength loop
SpoolChar( ' ' );
end loop;
SetTextStyle( OldStyle );
SetPenColour( OldColour );
end if;
if SpoolCounter = 0 then
Refresh;
end if;
exception when others => DrawErrLn;
DrawErr("Draw(e) exception");
raise;
end Draw;
procedure DrawEdit( s : string; fieldwidth : integer; am : boolean )is
-- Draw a string for an edit line with a fieldwidth
OverflowLength : integer;
OldStyle : ATextStyle; -- pad spaces must be in "normal" style
OldColour : APenColourName;
begin
OldStyle := GetTextStyle;
OldColour := GetPenColour;
if am then -- advance mode: add a ">" at the far right
OverflowLength := S'Length - FieldWidth + 1;
if OverflowLength = 0 then
Draw( s );
elsif OverflowLength > 0 then
Draw( Ada.Strings.Fixed.head( s, FieldWidth-1) );
else
Draw( s );
for i in 1..-OverflowLength loop
SpoolChar( ' ' );
end loop;
end if;
SpoolChar( '>' );
else -- normal (no advance mode)
OverflowLength := S'Length - fieldwidth;
if OverflowLength = 0 then
Draw( s );
elsif OverflowLength > 0 then
Draw( Ada.Strings.Fixed.Head( s, Fieldwidth));
else
Draw( s );
for i in 1..-OverflowLength loop
SpoolChar( ' ' );
end loop;
end if;
end if;
SetTextStyle( OldStyle );
SetPenColour( OldColour );
if SpoolCounter = 0 then
Refresh;
end if;
exception when others => DrawErrLn;
DrawErr( "DrawEdit exception" );
raise;
end DrawEdit;
procedure Draw( c : character ) is
-- Draw a single character
begin
SpoolChar( c );
if SpoolCounter = 0 then
Refresh;
end if;
end Draw;
procedure Draw( i : integer ) is
-- Draw an integer
begin
Draw( integer'image( i ) );
if SpoolCounter = 0 then
Refresh;
end if;
end Draw;
procedure Draw( l : long_integer ) is
-- Draw a long integer
begin
Draw( long_integer'image( l ) );
if SpoolCounter = 0 then
Refresh;
end if;
end Draw;
procedure Draw( f : float ) is
-- Draw a float
begin
Draw( float'image( f ) );
if SpoolCounter = 0 then
Refresh;
end if;
end Draw;
procedure DrawCoord( r : ARect ) is
-- Draw a rectangle's coordinates
begin
Draw( r.left );
Draw( ',' );
Draw( r.top );
Draw( '-' );
Draw( r.right );
Draw( ',' );
Draw( r.bottom );
end DrawCoord;
procedure DrawLn is
-- Advance to the next line
temp : long_integer;
y : integer;
begin
-- This used to work in early version of ncurses!
-- SpoolChar( character'val(10) );
-- SpoolChar( character'val(13) );
temp := CGetXY;
-- x := integer( temp mod 256 );
y := integer( temp / 256 )+1;
if y >= lines then
y := 0;
end if;
CMoveTo( 0, y );
if SpoolCounter = 0 then
Refresh;
end if;
end DrawLn;
--- Error Output
procedure DrawErr( s : string ) is
-- Draw a string error message
begin
SetTextStyle( Normal );
Draw( s );
Refresh;
end DrawErr;
procedure DrawErr( i : integer ) is
-- Draw an error integer
begin
SetTextStyle( Normal );
Draw( i );
Refresh;
end DrawErr;
procedure DrawErr( l : long_integer ) is
-- Draw an error long integer
begin
SetTextStyle( Normal );
Draw( l );
Refresh;
end DrawErr;
procedure DrawErr( i : AnInputRecord ) is
-- Draw an error input record
begin
SetTextStyle( Normal );
MoveToGlobal( 1, ErrorLine );
Draw( AnInput'image( i.InputType ) );
Draw( '[' );
case i.InputType is
when NullInput => null;
when KeyInput => Draw( i.Key );
when HeldKeyInput => Draw( i.HeldKey );
when DirectionInput => Draw( long_integer( i.Direction ) );
Draw( ',' );
Draw( long_integer( i.Velocity ) );
when LocationInput => Draw( i.x ); Draw( ',' ); Draw( i.y );
when ButtonDownInput => Draw( i.DownButton );
when ButtonUpInput => Draw( i.UpButton );
when HeartBeatInput => null;
when UserInput => Draw( i.id );
when others => Draw( '?' );
end case;
Draw( ']' );
Refresh;
end DrawErr;
procedure DrawErrLn is
-- Advance to the next line for errors
begin
SetTextStyle( Normal );
ErrorLine := ( ErrorLine + 1 ) mod 24;
MoveToGlobal( 1, ErrorLine );
Refresh;
end DrawErrLn;
---> Drawing functions
procedure GetDrawChar( PenColour : APenColourName;
ch : out character ) is
-- char to use to simulate a colour on monochrome terminals
-- may affect scrren attributes
begin
ch := ' ';
case PenColour is
when Outline => ch := '+';
when ScrollBack => CTextStyle( 'n', 'y', 'n' );
when ScrollThumb => CTextStyle( 'y', 'y', 'n' );
when ThermBack => CTextStyle( 'n', 'y', 'n' );
when ThermFore => CTextStyle( 'y', 'y', 'n' );
when Red => ch := '+';
when Purple => ch := '%';
when Green => ch := '*';
when Blue => ch := '=';
when Yellow => ch := '@';
when Black => null; -- a space
when others => ch := '#';
end case;
end GetDrawChar;
procedure DoneDrawing is
-- counterpart of GetDrawChar: restore screen status, if necessary
begin
SetTextStyle( CurrentStyle );
end DoneDrawing;
pragma Inline( DoneDrawing );
procedure DrawLine( x1, y1, x2, y2 : in integer ) is
-- Draw a line between the coordinates in the current colour
XLo, XHi : integer;
YLo, YHi : integer;
dx, dy : integer;
x, y : integer;
ch : character;
begin
GetDrawChar( CurrentPenColour, ch );
dx := x2 - x1;
dy := y2 - y1;
if dx = 0 and dy = 0 then
MoveToGlobal( x1, y1 );
SpoolChar( ch );
elsif abs(dx) > abs(dy) then
if x1 > x2 then
XLo := x2;
XHi := x1;
YLo := y2;
YHi := y1;
dx := -dx;
dy := -dy;
else
XLo := x1;
XHi := x2;
YLo := y1;
YHi := y2;
end if;
for x in XLo..XHi loop
y := YLo + ( dy * ( x - XLo ) ) / dx ;
MoveToGlobal( x, y );
SpoolChar( ch );
end loop;
else
if y1 > y2 then
XLo := x2;
XHi := x1;
YLo := y2;
YHi := y1;
dx := -dx;
dy := -dy;
else
XLo := x1;
XHi := x2;
YLo := y1;
YHi := y2;
end if;
for y in YLo..YHi loop
x := XLo + ( dx * ( y - YLo ) ) / dy ;
MoveToGlobal( x, y );
SpoolChar( ch );
end loop;
end if;
MoveToGlobal( x2, y2 );
if SpoolCounter = 0 then
Refresh;
end if;
end DrawLine;
procedure DrawHorizontalLine( x1, x2, y1 : in integer ) is
-- Draw a line between the coordinates in the current colour
begin
MoveToGlobal( x1, y1 );
for x in x1..x2 loop
MoveToGlobal( x, y1 );
SpoolSpecial( hline );
end loop;
MoveToGlobal( x2, y1 );
if SpoolCounter = 0 then
Refresh;
end if;
end DrawHorizontalLine;
procedure DrawVerticalLine( y1, y2, x1 : in integer ) is
-- Draw a line between the coordinates in the current colour
begin
MoveToGlobal( x1, y1 );
for y in y1..y2 loop
MoveToGlobal( x1, y );
SpoolSpecial( vline );
end loop;
MoveToGlobal( x1, y2 );
if SpoolCounter = 0 then
Refresh;
end if;
end DrawVerticalLine;
procedure FrameRect( r : in ARect ) is
-- Outline a rectangle
lenx, leny: integer;
ch : character;
OldStyle : ATextStyle;
OldPenColour : APenColourName;
begin
OldStyle := GetTextStyle;
OldPenColour := CurrentPenColour;
SetTextStyle( normal );
if Colour_Flag > 0 then
CurrentPenColour := outline; -- ok to draw with special chars in
end if; -- colour, no need to fake colour
if CurrentPenColour = Outline then
MoveToGlobal(r.left, r.top);
SpoolSpecial( upperleft );
MoveToGlobal(r.left, r.bottom);
SpoolSpecial( lowerleft );
MoveToGlobal(r.right, r.top);
SpoolSpecial( upperright );
MoveToGlobal(r.right, r.bottom);
SpoolSpecial( lowerright );
lenx := r.right - r.left;
leny := r.bottom - r.top;
MoveToGlobal(r.left+1, r.top);
for line in 2..LenX loop
SpoolSpecial( hline );
end loop;
MoveToGlobal(r.left+1, r.bottom);
for line in 2..LenX loop
SpoolSpecial( hline );
end loop;
for line in 1..LenY-1 loop
MoveToGlobal( r.left, r.top+line );
SpoolSpecial( vline );
MoveToGlobal( r.right, r.top+line );
SpoolSpecial( vline );
end loop;
else
-- fake colour drawing in different characters for different
-- colours
GetDrawChar( CurrentPenColour, ch );
MoveToGlobal(r.left, r.top);
SpoolChar( ch );
MoveToGlobal(r.left, r.bottom);
SpoolChar( ch );
MoveToGlobal(r.right, r.top);
SpoolChar( ch );
MoveToGlobal(r.right, r.bottom);
SpoolChar( ch );
lenx := r.right - r.left;
leny := r.bottom - r.top;
MoveToGlobal(r.left+1, r.top);
for line in 2..LenX loop
SpoolChar( ch );
end loop;
MoveToGlobal(r.left+1, r.bottom);
for line in 2..LenX loop
SpoolChar( ch );
end loop;
for line in 1..LenY-1 loop
MoveToGlobal( r.left, r.top+line );
SpoolChar( ch );
MoveToGlobal( r.right, r.top+line );
SpoolChar( ch );
end loop;
DoneDrawing;
end if;
SetTextStyle( OldStyle );
CurrentPenColour := OldPenColour;
if SpoolCounter = 0 then
Refresh;
end if;
end FrameRect;
procedure FrameRect3D( r : in ARect ) is
-- Outline a rectangle, hilighting like SuSE 3D effect
lenx, leny: integer;
OldStyle : ATextStyle;
OldPenColour : APenColourName;
begin
OldStyle := GetTextStyle;
OldPenColour := CurrentPenColour;
SetTextStyle( normal );
if Colour_Flag > 0 then
CurrentPenColour := outline; -- ok to draw with special chars in
end if; -- colour, no need to fake colour
if Colour_Flag > 0 and CurrentPenColour = Outline then
CTextStyle( 'y', 'n', 'n' ); -- hilight
MoveToGlobal( r.left, r.top ); -- top-left
SpoolSpecial( upperleft );
MoveToGlobal( r.right, r.top ); -- and top-right
SpoolSpecial( upperright );
CTextStyle( 'n', 'n', 'n' ); -- no hilight on others
MoveToGlobal( r.left, r.bottom );
SpoolSpecial( lowerleft );
MoveToGlobal( r.right, r.bottom );
SpoolSpecial( lowerright );
lenx := r.right - r.left; -- computer width and height
leny := r.bottom - r.top;
MoveToGlobal( r.left+1, r.top );
CTextStyle( 'y', 'n', 'n' ); -- top side hilighted
for line in 2..LenX loop
SpoolSpecial( hline );
end loop;
MoveToGlobal( r.left+1, r.bottom );
CTextStyle( 'n', 'n', 'n' );
for line in 2..LenX loop
SpoolSpecial( hline );
end loop;
for line in 1..LenY-1 loop
MoveToGlobal( r.right, r.top+line );
SpoolSpecial( vline );
end loop;
CTextStyle( 'y', 'n', 'n' ); -- left side also hilighted
for line in 1..LenY-1 loop
MoveToGlobal( r.left, r.top+line );
SpoolSpecial( vline );
end loop;
else
FrameRect( r );
end if;
SetTextStyle( OldStyle );
CurrentPenColour := OldPenColour;
if SpoolCounter = 0 then
Refresh;
end if;
end FrameRect3D;
procedure FramedRect( r : in ARect; ForeColour, BackColour : in APenColourName ) is
-- Outline and fill a rectangle (ignores current colour settings)
lenx, leny: integer;
ch : character;
OldStyle : ATextStyle;
OldColour : APenColourName;
begin
OldColour := GetPenColour;
OldStyle := GetTextStyle;
SetTextStyle( normal ); -- delete?
SetPenColour( ForeColour );
if ForeColour = Outline or Colour_Flag > 0 then
MoveToGlobal(r.left, r.top);
SpoolSpecial( upperleft );
MoveToGlobal(r.left, r.bottom);
SpoolSpecial( lowerleft );
MoveToGlobal(r.right, r.top);
SpoolSpecial( upperright );
MoveToGlobal(r.right, r.bottom);
SpoolSpecial( lowerright );
lenx := r.right - r.left;
leny := r.bottom - r.top;
MoveToGlobal(r.left+1, r.top);
for line in 2..LenX loop
SpoolSpecial( hline );
end loop;
MoveToGlobal(r.left+1, r.bottom);
for line in 2..LenX loop
SpoolSpecial( hline );
end loop;
for line in 1..LenY-1 loop
MoveToGlobal( r.left, r.top+line );
SpoolSpecial( vline );
MoveToGlobal( r.right, r.top+line );
SpoolSpecial( vline );
end loop;
else
GetDrawChar( ForeColour, ch );
MoveToGlobal(r.left, r.top);
SpoolChar( ch );
MoveToGlobal(r.left, r.bottom);
SpoolChar( ch );
MoveToGlobal(r.right, r.top);
SpoolChar( ch );
MoveToGlobal(r.right, r.bottom);
SpoolChar( ch );
lenx := r.right - r.left;
leny := r.bottom - r.top;
MoveToGlobal(r.left+1, r.top);
for line in 2..LenX loop
SpoolChar( ch );
end loop;
MoveToGlobal(r.left+1, r.bottom);
for line in 2..LenX loop
SpoolChar( ch );
end loop;
for line in 1..LenY-1 loop
MoveToGlobal( r.left, r.top+line );
SpoolChar( ch );
MoveToGlobal( r.right, r.top+line );
SpoolChar( ch );
end loop;
--DoneDrawing;
end if;
SetPenColour( BackColour );
GetDrawChar( BackColour, ch );
CSpoolRect( r.left+1, r.top+1, r.right-1, r.bottom-1, ch );
DoneDrawing;
SetTextStyle( OldStyle );
SetPenColour( OldColour );
if SpoolCounter = 0 then
Refresh;
end if;
end FramedRect;
procedure FillRect( r : in ARect; Colour : APenColourName ) is
-- Fill in a rectangle with the specified colour
ch : character;
OldColour : APenColourName;
begin
OldColour := GetPenColour;
SetPenColour( Colour );
GetDrawChar( Colour, ch );
CSpoolRect( r.left, r.top, r.right, r.bottom, ch );
DoneDrawing;
SetPenColour( OldColour );
if SpoolCounter = 0 then
Refresh;
end if;
end FillRect;
procedure PaintRect( r : ARect ) is
-- Fill in a rectangle with the current pen colour
begin
FillRect( r, CurrentPenColour );
end PaintRect;
procedure EraseRect( r : in ARect ) is
-- Erase a rectangle (to black)
OldColour : APenColourName;
OldStyle : ATextStyle;
begin
OldStyle := GetTextStyle;
if Colour_Flag > 0 then
OldColour := CurrentPenColour;
SetTextStyle( Normal );
SetPenColour( Black );
else
SetTextStyle( Normal );
end if;
CSpoolRect( r.left, r.top, r.right, r.bottom, ' ' );
MoveToGlobal( r.left, r.top );
SetTextStyle( OldStyle );
if Colour_Flag > 0 then
SetPenColour( OldColour );
end if;
if SpoolCounter = 0 then
Refresh;
end if;
end EraseRect;
---> Sound
--
-- Just for show
procedure PlaySound( sound : ASound ) is
-- Play the specified sound
begin
NoError;
if IsLocal then
if NotEmpty( sound ) then
UNIX( "wavplay -q " & sound & " &" );
else
Error( TT_FileExistance );
end if;
end if;
end PlaySound;
procedure PlaySound( voice : AVoice; sound : ASound;
angle : float := 0.0;
volume : float := 100.0;
freqchange : float := 0.0 ) is
-- Play the specified sound with some special effects
begin
null;
end PlaySound;
procedure StopSound( voice : AVoice ) is
-- Stop a sound
begin
null;
end StopSound;
procedure StopSounds is
-- Stop all sounds
begin
null;
end StopSounds;
procedure PlaySong( song : ASong ) is
-- Play a song
begin
null;
end PlaySong;
procedure StopSong is
-- Stop playing a song
begin
null;
end StopSong;
function GetFreeVoice return AVoice is
-- Get a free sound channel
begin
return 0;
end GetFreeVoice;
procedure SetMasterVolume( volume : float ) is
-- Change the master volume
begin
null;
end SetMasterVolume;
function GetMasterVolume return float is
-- Get the master volume
begin
return 100.0;
end GetMasterVolume;
---> Input Event Handling
--
-- The Input Queue (sorted by arrival time)
function InputLowerThan (left, right : in AnInputRecord) return boolean is
begin
return left.TimeStamp < right.TimeStamp;
end InputLowerThan;
package InputList is new Ada.Containers.Ordered_Sets (AnInputRecord, InputLowerThan);
InputQueue : InputList.Set; -- input events, sorted by time
--- Input Subprograms
procedure DoMacro (K : in character) is
-- look up and process a macro for character k
begin
for I in 1 .. Integer (Macros.Length) loop
declare
Macrostr : constant String := Macros.Element (I);
begin
if MacroStr (Macrostr'First) = k then
SetInputString (Ada.Strings.Fixed.Tail (MacroStr, MacroStr'Length - 1));
exit;
end if;
end;
end loop;
end DoMacro;
procedure PollInput( Response : AResponseTime := Blocking ) is
-- check queue and add input
k : character; -- character pulled from input device
k2 : character; -- for interpreting alt key press
begin
-- check for input: wait if waiting is allowed and queue is empty
if InputQueue.Is_Empty then
--
-- Mouse Support for GPM Library
--
-- check mouse first since it's not blocking
-- if C_mousebutton = 1 then
-- EventPtr := new AnInputRecord( InputType => ButtonDownInput );
-- EventPtr.TimeStamp := Clock;
-- EventPtr.UpLocationX := C_mousex;
-- EventPtr.UpLocationY := C_mousey;
-- EventPtr.UpButton := 1; -- every button is 1
-- SessionLog( "Mouse up at " & integer'image( EventPtr.UpLocationX ) &
-- ", " & integer'image( EventPtr.UpLocationY ) );
-- InputList.Insert( InputQueue, EventPtr );
-- k := NullKey;
-- C_mousebutton := -1;
-- elsif C_mousebutton = 0 then
-- EventPtr := new AnInputRecord( InputType => ButtonUpInput );
-- EventPtr.TimeStamp := Clock;
-- EventPtr.DownLocationX := C_mousex;
-- EventPtr.DownLocationY := C_mousey;
-- EventPtr.DownButton := 1; -- every button is 1
-- SessionLog( "Mouse down at " & integer'image( EventPtr.DownLocationX ) &
-- ", " & integer'image( EventPtr.DownLocationY ) );
-- InputQueue.insert (EventPtr);
-- k := NullKey;
-- C_mousebutton := -1;
-- elsif Response = Blocking then
-- ------------- END OF GPM Mouse Support ----------
if Response = Blocking then
k := character'val( CGetKey ); -- wait for keypress availability
elsif Response = Instant then
k := character'val( CKeypress ); -- quick check
else
k := character'val( CKeyDelay ); -- semi-blocked
end if;
-- ncurses mouse support - ASCII 255 = button 1 clicked
if character'pos( k ) = 254 then
InputQueue.Insert ((Moveinput, Clock, C_Mousex, C_Mousey));
k := NullKey; -- discard ASCII 255
elsif character'pos( k ) = 255 then
InputQueue.Insert ((ButtonUpInput, Clock, 1, C_Mousex, C_Mousey));
k := NullKey; -- discard ASCII 255
end if;
else
k := character'val( CKeypress ); -- check for queued keypresses
end if;
-- if new input, add it to the queue
if MacroInProgress and k /= NullKey then
DoMacro( k );
MacroInProgress := false;
elsif k = MacroKey and AreMacros then
MacroInProgress := true;
elsif k /= NullKey then
-- IBM keyboard: alt = esc + character. Return with high bit set.
-- Note: can't do alt-ctrl-@ this way, since that's alt-nullkey
if k = character'val( 27 ) then
k2 := character'val( CKeypress ); -- quick check for another
if k2 /= NullKey then
k := character'val( 128 + character'pos( k2 ) );
end if;
end if;
InputQueue.Insert ((Keyinput, Clock, K));
end if;
end PollInput;
-- I wonder whether this does not crash, since a pulled
-- event'discriminant cannot be predicted.
procedure GetInput (E : out AnInputRecord;
response : AResponseTime := Blocking ) is
begin
PollInput (Response);
if InputQueue.Is_Empty then
E := (NullInput, Clock);
else
E := InputQueue.First_Element;
InputQueue.Delete_First;
end if;
end GetInput;
procedure SetInput (E : in AnInputRecord;
usetime : in Boolean := false ) is
-- add an input event to the input queue
e2 : AnInputRecord := e;
begin
if not UseTime then
e2.TimeStamp := Clock; -- stamp it
end if;
InputQueue.Insert (e2); -- and sort by timestamp
PollInput( Response => Instant );
end SetInput;
procedure SetInputString( s : string ) is
-- post a string as a series of key presses
begin
for i in S'Range loop
InputQueue.Insert ((KeyInput, Clock, S (I)));
end loop;
PollInput( Response => Instant );
end SetInputString;
procedure HeartBeat is
-- post a heart beat
begin
SetInput ((HeartBeatInput, Clock));
end HeartBeat;
procedure FlushInput is
-- flush the input queue
begin
FlushKeys;
Inputqueue.Clear;
MacroInProgress := false;
end FlushInput;
procedure WaitFor( ticks : integer ) is
-- check queue and add input, with timeout
k : character;
LoopTime : integer;
begin
looptime := ticks / 6;
if looptime < 0 then
PollInput( Response => Instant );
else
for i in 1..LoopTime loop
-- check for input: wait if waiting is allowed and queue is empty
k := character'val( CKeyDelay ); -- check for waiting keypress
-- if new input, add it to the queue
if MacroInProgress then
DoMacro( k );
MacroInProgress := false;
elsif k = MacroKey and AreMacros then
MacroInProgress := true;
elsif k /= NullKey then
InputQueue.Insert ((Keyinput, Clock, K));
end if;
end loop;
end if;
end WaitFor;
function GetInputLength return Natural is
-- return the length of the input queue
begin
return Natural (Inputqueue.Length);
end GetInputLength;
---> Regions
--
-- Mostly just for show, for now.
procedure RectInRegionSubRect (Rect : in ARect;
region : in out ARegion;
Result : out boolean ) is
-- support procedures if InRegion calls
-- determine if a rectangle is in any of the rectangles in a region
use Rectlist;
I : Cursor := Region.First;
begin
Result := false;
while I /= No_Element loop
if InsideRect (Inner => rect, Outer => Element (I)) then
Result := true;
exit;
end if;
Next (I);
end loop;
end RectInRegionSubRect;
procedure SetRectRegion( region : in out ARegion; rect : ARect ) is
begin
Region.Clear;
Region.Insert (Rect);
end SetRectRegion;
procedure OffsetRegion( region : in out ARegion; dx, dy : integer ) is
use Rectlist;
New_Region : Aregion;
I : Cursor := Region.First;
SubRect : ARect;
begin
while I /= No_Element loop
Subrect := Element (I);
OffsetRect (SubRect, dx, dy );
New_Region.Insert (Subrect);
Next (I);
end loop;
Move (Region, New_Region);
end OffsetRegion;
procedure InRegion ( x, y : integer;
region : in out ARegion;
result : out boolean ) is
use Rectlist;
I : Cursor := Region.First;
RegionRect : ARect;
begin
result := false;
while I /= No_Element loop
Regionrect := Element (I);
if InRect( x, y, RegionRect ) then
result := true;
exit;
end if;
Next (I);
end loop;
end InRegion;
procedure InRegion( r : ARect; region : in out ARegion;
result : out boolean ) is
SubRect : ARect;
-- is a rectangle contained in a region?
CenterX, CenterY : integer;
Subresult : boolean;
begin
-- a region is a list of rectangles, so start with the elementary
-- case of a retangle in a rectangle composing the region.
RectInRegionSubRect( r, region, subresult );
if subresult then
Result := true;
else
-- check corner points...they should all be in the region
InRegion( r.left, r.top, region, subresult );
if not subresult then
Result := false;
return;
end if;
InRegion( r.right, r.top, region, subresult );
if not subresult then
Result := false;
return;
end if;
InRegion( r.left, r.bottom, region, subresult );
if not subresult then
Result := false;
return;
end if;
InRegion( r.right, r.bottom, region, subresult );
if not subresult then
Result := false;
return;
end if;
-- OK? well that may be because the rectangle overlaps adjacent
-- rectangles in the region. All we can do is recursively subdivide
-- the rectangle into sub rectangles that fall into one or another
-- of the adjacent rectangles in the region. If all succeed, then
-- the rectangle is in the region.
CenterX := (r.right-r.left)/2+r.left;
CenterY := (r.bottom-r.top)/2+r.top;
SubRect.left := r.left; -- top-left
SubRect.right := CenterX;
SubRect.top := r.top;
SubRect.bottom := CenterY;
if not IsEmptyRect( SubRect ) then
InRegion( SubRect, Region, subresult );
if not subresult then
result := false;
return;
end if;
end if;
SubRect.left := CenterX + 1; -- top-right
SubRect.right := r.right;
if not IsEmptyRect( Subrect ) then
InRegion( SubRect, Region, subresult );
if not subresult then
result := false;
return;
end if;
end if;
SubRect.left := r.left; -- bottom-left
SubRect.right := CenterX;
SubRect.top := CenterY+1;
SubRect.bottom := r.bottom;
if not IsEmptyRect( Subrect ) then
InRegion( SubRect, Region, subresult);
if not subresult then
result := false;
return;
end if;
end if;
SubRect.left := CenterX+1; -- bottom-right
SubRect.right := r.right;
if not IsEmptyRect( SubRect ) then
InRegion( SubRect, Region, subresult );
if not subresult then
result := false;
return;
end if;
end if;
Result := true; -- all subrects in the region? great!
end if;
end InRegion;
procedure InRegion( r, region : in out ARegion; result : out boolean ) is
subresult : boolean;
RegionRect : ARect;
use Rectlist;
I : Cursor := R.First;
begin
result := true;
while I /= No_Element loop
RegionRect := Element (I);
InRegion( RegionRect, region, subresult );
if not subresult then
result := false;
exit;
end if;
Next (I);
end loop;
end InRegion;
procedure AddRegion( region, region2add : in out ARegion ) is
NewSubRect : ARect;
result : boolean;
-- add two regions together by adding all parts that aren't
-- common to both
use Rectlist;
I : Cursor := Region2add.First;
begin
while I /= No_Element loop
NewSubRect := Element (I);
RectInRegionSubRect( NewSubRect, region, result );
if not result then
Region.Insert (NewSubRect);
end if;
Next (I);
end loop;
end AddRegion;
-- procedure SetClipRegion( R : in out ARegion ) is
-- begin
-- Error( TT_NotYetWritten );
-- end SetClipRegion;
type APictureType is (TextImage, PixelImage);
package PictureList is new Ada.Containers.Indefinite_Vectors (Positive, String);
Pictures : PictureList.Vector;
function RegisterPicture (Path : in String) return APictureID is
begin
Pictures.Append (Path);
return APictureID (Pictures.Length);
end RegisterPicture;
function SavePicture( path, title : string; bounds : ARect )
return APictureID is
PictureFile: StrList.Vector;
es : EncodedString := Null_Unbounded_String;
begin
Pictures.Append (Path);
-- Encode( ges, title );
Picturefile.Append (Title);
Encode (Es, Integer'(APictureType'Pos (TextImage)));
Encode( es, bounds );
Picturefile.Append (To_String (Es));
for y in bounds.top..bounds.bottom loop
es := Null_Unbounded_String;
for x in bounds.left..bounds.right loop
Encode( es, CGetChar( x, y ) ); -- fake for now
end loop;
PictureFile.Append (To_String (Es));
end loop;
SaveList ( path, PictureFile );
return APictureID (Pictures.Length);
end SavePicture;
procedure DrawPicture( picture : APictureID; bounds : ARect ) is
TempInt : integer;
PictureFile : StrList.Vector;
es : EncodedString;
PictureType : Apicturetype;
PictureWidth : integer;
PictureHeight: integer;
PictureBounds: ARect;
ch : character;
begin
LoadList (Pictures.Element (Picture), PictureFile );
Picturefile.Delete_Last; -- discard title
Es := To_Unbounded_String (PictureFile.Last_Element);
Picturefile.Delete_Last; -- rectangle
Decode (es, TempInt );
PictureType := APictureType'val( TempInt );
Decode( es, PictureBounds );
PictureWidth := PictureBounds.right - PictureBounds.left;
if PictureWidth >= bounds.right - bounds.left then
PictureWidth := bounds.right - bounds.left;
end if;
PictureHeight := PictureBounds.bottom - PictureBounds.top;
if PictureHeight >= bounds.bottom - bounds.top then
PictureHeight := bounds.bottom - bounds.top;
end if;
if PictureType = TextImage then
for y in bounds.top..bounds.top + PictureHeight loop
Es := To_Unbounded_String (PictureFile.Last_Element);
Picturefile.Delete_Last; -- rectangle
MoveToGlobal( bounds.left, y );
for x in bounds.left..bounds.left + PictureWidth loop
Decode( es, ch );
SpoolChar( ch );
end loop;
end loop;
else -- unknown type
EraseRect( bounds );
end if;
if SpoolCounter = 0 then
Refresh;
end if;
end DrawPicture;
procedure ScreenDump is
info : ADisplayInfoRec;
scrn : ARect;
id : APictureID;
pragma Unreferenced (Id);
begin
GetDisplayInfo( info );
scrn.top := 0;
scrn.bottom := info.V_Res - 1;
scrn.left := 0;
scrn.right := info.H_Res - 1;
id := SavePicture ("./ScreenDump", Ada.Calendar.Formatting.Image (Clock), scrn);
-- discard from stack (optional)
end ScreenDump;
---> Output Spooling
procedure WaitToReveal is
-- Increment the wait to reveal counter
begin
--null; -- kludge for ncurses 1.9.9: spooling doesn't work right
SpoolCounter := SpoolCounter + 1;
-- NOTE: CSpoolRect is also klugded
end WaitToReveal;
procedure Reveal is
-- Decrement the wait to reveal counter, redraw if 0
begin
-- kludge for ncurses 1.9.9: spooling doesn't work right
if SpoolCounter > 0 then
SpoolCounter := SpoolCounter - 1;
end if;
if SpoolCounter = 0 then
Refresh;
end if;
end Reveal;
procedure RevealNow is
-- Force a screen refresh of spooled data
begin
Refresh;
end RevealNow;
procedure BlueBackground( blueOn : boolean ) is
begin
NoError;
BackgroundIsBlue := blueOn;
if blueOn then
SetColour( 0 );
else
SetColour( 1 );
end if;
end BlueBackground;
function IsBlueBackground return boolean is
begin
return BackgroundIsBlue;
end IsBlueBackground;
---> Housekeeping
procedure StartupUserIO is
-- Initialize this package, set defaults
begin
NoError;
if PackageRunning then
return;
end if;
CurrentAngle := 0.0;
ErrorLine := 2;
SpoolCounter := 0;
StartupCurses;
CurrentPenColour := none;
CurrentSize := 1;
SetPenColour( outline );
--if C_hasmouse = 1 then
-- SessionLog( "StartupUserIO: GPM Mouse detected" );
--else
-- SessionLog( "StartupUserIO: No GPM Mouse was detected" );
--end if;
C_mousebutton := -1; -- clear input
-- Load Macros
if NotEmpty( MacroFile ) then
LoadList( MacroFile, Macros );
if LastError /= TT_OK then
SessionLog( "StartupUserIO: Unable to load macro file ", LastError );
AreMacros := false;
else
SessionLog( "StartupUserIO: macro file loaded" );
AreMacros := true;
end if;
else
SessionLog( "StartupUserIO: no macro file detected" );
AreMacros := false;
end if;
MacroInProgress := false;
-- Play Sounds?
HasSounds := IsFile( SoundFlag );
if HasSounds then
SessionLog( "StartupUserIO: sound flag file detected" );
else
SessionLog( "StartupUserIO: no sound flag file detected" );
end if;
IdleJobsDone := false;
CLS;
CMoveTo( 0, 0 );
PackageRunning := true;
BackgroundIsBlue := true;
end StartupUserIO;
procedure IdleUserIO( IdlePeriod : in Duration ) is
begin
if IdlePeriod < 60.0 then -- do jobs once after 1 minute
IdleJobsDone := false;
elsif not IdleJobsDone then
RevealNow;
-- if AreMacros then
-- Str255List.Compact( Macros );
-- end if;
-- PictureList.Compact( Pictures );
-- InputList.Compact( InputQueue );
IdleJobsDone := true;
end if;
end IdleUserIO;
procedure ShutdownUserIO is
-- Shut down this package
begin
NoError;
if PackageRunning then
if AreMacros then
Macros.Clear;
end if;
PictureList.Clear( Pictures );
InputList.Clear( InputQueue );
RevealNow;
ShutdownCurses;
PackageRunning := false;
end if;
end ShutdownUserIO;
procedure ResetUserIO is
-- call when refreshing desktop. Clear curses cache.
begin
ResetCurses;
--ShutdownCurses;
--StartupCurses;
--CurrentPenColour := none;
--CurrentSize := 1;
--SetPenColour( outline );
end ResetUserIO;
end userio;
texttools/src/strings.adb 0000664 0000764 0000764 00000042612 11774715706 014225 0 ustar ken ken ------------------------------------------------------------------------------
-- STRINGS (package body) --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants;
package body strings is
dips : constant string := "upanlyscolableutalisifensusteasauayeeieoeseyiaotoouuichetirontrshaithoaghurngeregundewhbackamedorvarine a d f o n r s e_r_s_e.";
Case_Mappings : constant array (Boolean) of Ada.Strings.Maps.Character_Mapping
:= (True => Ada.Strings.Maps.Constants.Upper_Case_Map,
False => Ada.Strings.Maps.Identity);
procedure FixSpacing( s : in out unbounded_string ) is
-- remove leading and trailing spaces, as well as any double-spaces inside
i : Integer := 1;
begin
Trim (S, Side => Ada.Strings.Both);
while i < length(s) loop
if Element( s, i ) = ' ' and then Element( s, i+1 ) = ' ' then
Delete( s, i, i );
i := i - 1;
end if;
i := i + 1;
end loop;
end FixSpacing;
function PhoneticsOf( s : string ) return String is
-- reduce string to ENGLISH phonetics
-- equivalences from Talking Tools pg.12 (and from guessing)
pos : natural := S'First; -- position in s
ppos : natural := 1; -- position in PhoneticString
PhoneticString : Unbounded_String := Null_Unbounded_String; -- the resulting phonetics
ch : character; -- current character in s
AllowDuplicate : boolean := false; -- TRUE to discard same adjacents
function NextChar return character is
-- get the next character (if none, return a space)
ch : character;
begin
if Pos < S'Last then
Ch := S (pos+1);
if ch >= 'A' and ch <= 'Z' then
Ch := character'val( character'pos(ch) + 32 );
end if;
return ch;
else
return ' ';
end if;
end NextChar;
procedure Add( c : character ) is
-- add a phoeme to the Phonetic String, discarding adjacent duplicates
-- if it's OK. Some very similar sounds are grouped together (th & d)
begin
if ppos = 1 or AllowDuplicate then
Append( PhoneticString, c );
ppos := ppos + 1;
AllowDuplicate := false;
else
if Element( PhoneticString, ppos-1 ) /= c then
Append( PhoneticString, c );
ppos := ppos + 1;
end if;
end if;
end Add;
procedure SkipChar is
-- macro to advance to next position in s
begin
pos := pos + 1;
end SkipChar;
pragma Inline( SkipChar );
begin
while Pos <= S'Last loop
ch := S (Pos);
if ch >= 'A' and ch <= 'Z' then
ch := character'val( character'pos(ch) + 32 );
end if;
case ch is
when 'a' =>
case NextChar is
when 'a'|'e'|'i'|'y' => -- aa, ae, ai, ay
Add( 'A' );
SkipChar;
when 'r' => -- ar
Add( 'R' );
SkipChar;
when 'u' => -- au
Add( 'U' );
SkipChar;
when others =>
Add( 'A' ); -- a
end case;
when 'b' => -- b
Add( 'B' );
when 'd' => -- d
Add( 'D' );
when 't' =>
if NextChar = 'h' then -- th (H)
Add( 'H' );
SkipChar;
else
Add( 'D' ); -- t (=d)
end if;
when 'p' =>
if NextChar = 'h' then -- ph (F)
Add( 'F' );
SkipChar;
else
Add( 'P' ); -- p
end if;
when 'c' => -- c*
if NextChar = 'h' then -- ch (Y)
Add( 'Y' );
SkipChar;
else
Add( 'C' );
end if;
when 'e' =>
case NextChar is
when 'a' => Add( 'E' ); SkipChar; -- ea
when 'i' => Add( 'I' ); SkipChar; -- ei
when 'e' => Add( 'E' ); SkipChar; -- ee
when 'r' => Add( 'R' ); SkipChar; -- er
when 'u' => Add( 'U' ); SkipChar; -- eu
when 'y' => Add( 'A' ); SkipChar; -- ey
when ' '|'?'|'''|':'|';'|'.'|',' => SkipChar; -- e (silent)
when others => -- e
Add( 'E' );
end case;
when 'f' => -- f
Add( 'F' );
when 'g' => -- gh
if NextChar = 'h' then
SkipChar;
else
Add( 'G' ); -- g*
end if;
when 'h' => -- h
null;
when 'i' => -- i
if NextChar = 'e' then -- ie
Add( 'E' );
SkipChar;
elsif NextChar = 'r' then -- ir
Add( 'R' );
SkipChar;
elsif NextChar = 'o' then -- ion
pos := pos + 1;
if NextChar = 'n' then
Add( 'U' );
Add( 'N' );
SkipChar;
else
pos := pos - 1; -- treat normally
Add( 'I' );
end if;
else
Add( 'I' );
end if;
when 'j' => -- j
Add( 'J' );
when 'k'|'q' => -- k
Add('K');
if NextChar = 'u' then -- qu (KW)
Add( 'W' );
SkipChar;
end if;
when 'l'|'r' => -- l, r
Add( 'R' );
when 'm' => -- m
Add( 'N' );
when 'n' =>
if NextChar = 'g' then
SkipChar; -- ng (=n)
end if;
Add( 'N' ); -- n
when 'o' =>
case NextChar is
when 'a' => -- oa
Add( 'O' );
SkipChar;
when 'o' => -- oo
Add( 'U' );
SkipChar;
when 'r' => -- or
Add( 'R' );
SkipChar;
when 'u' => -- ou
Add( 'U' );
SkipChar;
when others => -- o
Add( 'O' );
end case;
when 's' => -- sh (H)
if NextChar = 'h' then
Add( 'H' );
SkipChar;
else
Add( 'S' ); -- s
end if;
when 'u' =>
if NextChar = 'y' then -- uy
Add( 'I' );
SkipChar;
elsif NextChar = 'r' then -- ur
Add( 'R' );
SkipChar;
else
Add ( 'U' ); -- u
end if;
when 'v' => -- v
Add( 'V' );
when 'w' => -- w
Add( 'W' );
when 'x'|'z' => -- x, z
Add( 'Z' );
when 'y' => -- y
Add( 'I' );
when others =>
AllowDuplicate := true; -- allow two together if sep by sp, ', etc
if ch >= '0' and ch <= '9' then -- 0...9
Add( ch );
AllowDuplicate := true;
end if;
end case;
pos := pos + 1;
end loop;
return To_String (PhoneticString);
end PhoneticsOf;
function TypoOf( BadString, GoodString : String) return boolean is
-- 80% of all typos are single insertions, deletions, exchanges, or subs.
begin
if BadString = GoodString
or BadString'Length < 4
or GoodString'Length < 4 then
-- identical or too short to test reliably?
return false;
end if;
-- Single Insertion
if BadString'Length = GoodString'Length + 1 then
for I in BadString'Range loop
if BadString (Badstring'First .. I - 1)
& Badstring (I + 1 .. Badstring'Last) = GoodString then
return True;
end if;
end loop;
end if;
-- Single Deletion
if BadString'Length = GoodString'Length - 1 then
for i in GoodString'Range loop
if GoodString (Goodstring'First .. I - 1)
& Goodstring (I + 1 .. Goodstring'Last) = BadString then
return True;
end if;
end loop;
end if;
-- Single Exchange or Substitution
if BadString'Length = GoodString'Length then
declare
TempStr : String := BadString;
Tempchar : Character;
begin
for i in Badstring'First .. BadString'Last - 1 loop
TempChar := tempstr (I);
tempstr (I) := Tempstr (I + 1);
tempstr (I + 1) := Tempchar;
if TempStr = GoodString then
return True;
end if;
Tempstr (I .. I + 1) := Badstring (I .. I + 1);
Tempstr (I) := Goodstring (I - Tempstr'First + Goodstring'First);
if Tempstr = Goodstring then
return True;
end if;
Tempstr (I) := Badstring (I);
end loop;
end;
end if;
return False;
end TypoOf;
procedure Tokenize (S : in string;
Words : in out strlist.Vector;
ch : in out character ) is
-- encode a word as a character > 127
Index : Natural;
begin
Index := Words.Find_Index (S);
if Index = 0 or Index > 128 then
ch := character'val( Index ); --' ';
else
ch := character'val( Index + 127 );
end if;
end Tokenize;
procedure Untokenize (Ch : in Character;
Words : in out Strlist.Vector;
S : in out unbounded_string) is
begin
s := Null_Unbounded_String;
if character'pos( ch ) > 127 then
S := To_Unbounded_String (Words.Element (Character'Pos (Ch) - 127));
end if;
end Untokenize;
function FGREP (s : string;
text : string;
filter_out : boolean := false;
case_insensitive : boolean := false )
return Boolean
is
begin
return Ada.Strings.Fixed.Index (Text,
S,
Mapping => Case_Mappings (Case_Insensitive)) > 0
xor Filter_Out;
end FGREP;
function FGREP (s : string;
text : string;
filter_out : boolean := false;
case_insensitive : boolean := false )
return String
is
begin
if FGREP (S, Text, Filter_Out, Case_Insensitive) then
return text;
else
return "";
end if;
end FGREP;
procedure FGREP (s : in String;
text : in Strlist.Vector;
result : out boolean;
filter_out : boolean := false;
case_insensitive : boolean := false )
is
begin
Result := False;
for I in 1 .. Integer (Text.Length) loop
Result := FGREP (S, Text.Element (I), Filter_Out, Case_Insensitive);
exit when Result;
end loop;
end FGREP;
procedure FGREP (s : string;
text : in out Strlist.Vector;
filter_out : boolean := false;
case_insensitive : boolean := false )
is
I : Positive := 1;
begin
while I <= Integer (Text.Length) loop
if FGREP (S, Text.Element (I), Filter_Out, case_insensitive) then
I := I + 1;
else
Text.Delete (I);
end if;
end loop;
end FGREP;
---> ASCII Encode/Decode
separator : constant character := character'val(1);
procedure Encode( estr : in out EncodedString; i : integer ) is
begin
Append( estr, integer'image( i ) );
Append( estr, separator );
end Encode;
procedure Encode( estr : in out EncodedString; r : ARect ) is
begin
Encode( estr, r.left );
Encode( estr, r.top );
Encode( estr, r.right );
Encode( estr, r.bottom );
end Encode;
procedure Encode( estr : in out EncodedString; l : long_integer ) is
begin
Append( estr, long_integer'image( l ) );
Append( estr, separator );
end Encode;
procedure Encode( estr : in out EncodedString; s : string) is
begin
Append( estr, s);
Append( estr, separator );
end Encode;
procedure Encode( estr : in out EncodedString; c : character ) is
begin
Append( estr, c );
end Encode;
procedure Encode( estr : in out EncodedString; b : boolean ) is
begin
if b then
Append( estr, 'T' );
else
Append( estr, 'F' );
end if;
end Encode;
procedure Decode( estr : in out EncodedString; i : out integer ) is
idx : integer := 1;
begin
while Element( estr, idx ) /= separator loop
idx := idx + 1;
end loop;
i := integer'Value (Slice (estr, 1, Idx - 1));
Tail (estr, Length (Estr) - Idx);
end Decode;
procedure Decode( estr : in out EncodedString; r : out ARect ) is
begin
Decode( estr, r.left );
Decode( estr, r.top );
Decode( estr, r.right );
Decode( estr, r.bottom );
end Decode;
procedure Decode( estr : in out EncodedString; l : out long_integer ) is
idx : integer := 2;
begin
while Element( estr, idx ) /= separator loop
idx := idx + 1;
end loop;
l := long_integer'Value (Slice (estr, 1, Idx - 1));
Tail (estr, Length (Estr) - Idx);
end Decode;
procedure Decode( estr : in out EncodedString; s : out Unbounded_String) is
pos : constant Natural := Index (Estr, (1 => Separator));
begin
s := Head (estr, pos - 1 );
Tail (estr, Length (Estr) - Pos);
end Decode;
procedure Decode( estr : in out EncodedString; c : out character ) is
begin
c := Element( estr, 1 );
Tail (estr, Length (Estr) - 1);
end Decode;
procedure Decode( estr : in out EncodedString; b : out boolean ) is
c : character := ASCII.NUL;
begin
Decode( estr, c );
pragma Assert (C = 'T' or C = 'F');
b := (c = 'T');
end Decode;
-- BASIC PACK
--
-- Compress string s using dipthong compression resulting in a new string of
-- 50% to 100% the size of the original. s must contain only lower ASCII
-- characters since the upper ASCII characters are used for the compression.
------------------------------------------------------------------------------
function basic_pack( s : string ) return packed_string is
dip : string(1..2);
i : positive;
dip_pos : natural;
result : unbounded_string;
begin
i := s'first;
result := null_unbounded_string;
loop
exit when i > s'last;
dip_pos := 0;
if i /= s'last then
dip := s(i..i+1);
for j in dips'first..dips'last-1 loop
if dip = dips(j..j+1) then
dip_pos := j;
exit;
end if;
end loop;
end if;
if dip_pos > 0 then
result := result & character'val( dip_pos + 127 );
i := i + 2;
else
result := result & s(i);
i := i + 1;
end if;
end loop;
return packed_string( to_string( result ) );
end basic_pack;
-- UNPACK
--
-- Decompress string s that was compressed using basic_pack.
------------------------------------------------------------------------------
function unpack( s : packed_string ) return string is
dip_pos : positive;
newstr : unbounded_string;
begin
for i in s'range loop
if character'pos( s(i) ) >= 128 then
dip_pos := character'pos( s(i) ) - 127;
newstr := newstr & dips( dip_pos..dip_pos+1 );
else
newstr := newstr & s(i);
end if;
end loop;
return to_string( newstr );
end unpack;
end strings;
texttools/src/strings.ads 0000664 0000764 0000764 00000013567 11774715706 014255 0 ustar ken ken ------------------------------------------------------------------------------
-- STRINGS --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with common; use common;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
pragma Elaborate( common ); -- remind Ada the common elaborates first
package strings is
---> Misc Functions
--
-- FixSpacing - remove leading/trailing spaces, etc.
-- PhoneticsOf - compute English phonetics of the string
-- TypoOf - true if first string is a typo of the second
-- Tokenize - represent the position of the string in a list as an
-- encoded character, or ' ' if not in list or list too long
-- Untokenize - return the string represented by the encoded character
-- FGREP - search for a string is a list of text
procedure FixSpacing( s : in out Unbounded_String );
function PhoneticsOf( s : String ) return string;
function TypoOf( BadString, GoodString : String ) return boolean;
procedure Tokenize( s : in string; words : in out StrList.Vector;
ch : in out character );
procedure Untokenize( ch : character ; words : in out StrList.Vector;
s : in out Unbounded_String );
function FGREP (s : in String;
text : in String;
filter_out : boolean := false;
Case_Insensitive : Boolean := False)
return boolean;
-- implementation of UNIX fgrep for a single line of text
-- true if fgrep matches
function FGREP (s : in String;
text : in String;
filter_out : in boolean := false;
case_insensitive : in boolean := false )
return string;
-- implementation of UNIX fgrep for a single line of text
-- returns the line if grep matches
procedure FGREP (s : in String;
text : in out StrList.Vector;
filter_out : boolean := false;
case_insensitive : boolean := false );
-- implementation of UNIX fgrep for a list of strings
-- filters in/out matching strings
procedure FGREP (s : in String;
text : in StrList.Vector;
result : out boolean;
filter_out : boolean := false;
case_insensitive : boolean := false );
-- implementation of UNIX fgrep for a list of strings
-- result is true if there were any matches
---> ASCII Encoding/Decoding
--
-- Compresses and appends a basic data item to the given string
subtype EncodedString is Unbounded_String;
procedure Encode( estr : in out EncodedString; b : in boolean );
procedure Encode( estr : in out EncodedString; c : in character );
procedure Encode( estr : in out EncodedString; i : in integer );
procedure Encode( estr : in out EncodedString; l : in Long_Integer );
procedure Encode( estr : in out EncodedString; r : in ARect );
procedure Encode( estr : in out EncodedString; s : in String );
procedure Decode( estr : in out EncodedString; b : out boolean );
procedure Decode( estr : in out EncodedString; c : out character );
procedure Decode( estr : in out EncodedString; i : out integer );
procedure Decode( estr : in out EncodedString; l : out Long_Integer );
procedure Decode( estr : in out EncodedString; r : out ARect );
procedure Decode( estr : in out EncodedString; s : out Unbounded_String );
type packed_string is new string;
-- BASIC PACK
--
-- Compress string s using dipthong compression resulting in a new string of
-- 50% to 100% the size of the original. s must contain only lower ASCII
-- characters since the upper ASCII characters are used for the compression.
------------------------------------------------------------------------------
function basic_pack( s : string ) return packed_string;
-- UNPACK
--
-- Decompress string s that was compressed using basic_pack.
------------------------------------------------------------------------------
function unpack( s : packed_string ) return string;
end strings;
texttools/src/common.adb 0000664 0000764 0000764 00000014217 11774715706 014024 0 ustar ken ken ------------------------------------------------------------------------------
-- COMMON (package body) --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
package body Common is
---> Housekeeping
procedure StartupCommon ( theProgramName, theShortProgramName : string ) is
-- start up this package
begin
LastError := 0;
RaisingErrors := false;
ProgramName := Ada.Strings.Unbounded.To_Unbounded_String (TheProgramName );
ShortProgramName := Ada.Strings.Unbounded.To_Unbounded_String ( theShortProgramName );
end StartupCommon;
procedure IdleCommon( IdlePeriod : in Duration ) is
-- idle-time tasks
pragma Unreferenced (Idleperiod);
begin
NoError;
end IdleCommon;
procedure ShutdownCommon is
-- shutdown this package
begin
NoError;
end ShutdownCommon;
---> Error Trapping
procedure NoError is
-- clear last error
begin
LastError := 0;
--Str255List.Clear( LastErrorDetails );
end NoError;
procedure Error( ErrorCode : AnErrorCode ) is
-- record an error, raising an exception if necessary
begin
LastError := ErrorCode;
if ErrorCode /= TT_OK and then RaisingErrors then
raise GeneralError;
end if;
end Error;
procedure RaiseErrors is
-- raise a general error on upcoming errors
begin
RaisingErrors := true;
end RaiseErrors;
procedure TrapErrors is
-- trap upcoming errors and put value in LastError
begin
RaisingErrors := false;
end TrapErrors;
function RaiseErrors return boolean is
WasRaising : boolean;
begin
WasRaising := RaisingErrors;
RaisingErrors := true;
return WasRaising;
end RaiseErrors;
function TrapErrors return boolean is
WasRaising : boolean;
begin
WasRaising := RaisingErrors;
RaisingErrors := false;
return WasRaising;
end TrapErrors;
procedure RestoreRaising( oldflag : boolean ) is
begin
RaisingErrors := oldflag;
end RestoreRaising;
---> Rectangles
procedure SetRect( r : out ARect; left, top, right, bottom : integer ) is
-- initialize a rectangle
begin
r.left := left;
r.top := top;
r.right := right;
r.bottom := bottom;
end SetRect;
procedure OffsetRect( r : in out ARect; dx, dy : integer ) is
-- shift a rectangle
begin
r.left := r.left + dx;
r.top := r.top + dy;
r.right := r.right + dx;
r.bottom := r.bottom + dy;
end OffsetRect;
function OffsetRect( r : in ARect; dx, dy : integer ) return ARect is
-- shift a rectangle returning the resulting rectangle
newRect : ARect;
begin
newRect.left := r.left + dx;
newRect.top := r.top + dy;
newRect.right := r.right + dx;
newRect.bottom := r.bottom + dy;
return newRect;
end OffsetRect;
procedure InsetRect( r : in out ARect; dx, dy : integer ) is
-- change the size of a rectangle
begin
r.left := r.left + dx;
r.top := r.top + dy;
r.right := r.right - dx;
r.bottom := r.bottom - dy;
end InsetRect;
function InsetRect( r : in ARect; dx, dy : integer ) return ARect is
-- change the size of a rectangle returning the resulting rectangle
newRect : ARect;
begin
newRect.left := r.left + dx;
newRect.top := r.top + dy;
newRect.right := r.right - dx;
newRect.bottom := r.bottom - dy;
return newRect;
end InsetRect;
function InsideRect( Inner, Outer : in ARect ) return boolean is
-- test for one rectangle inside of another
begin
return (Inner.left >= Outer.left) and then
(Inner.top >= Outer.top) and then
(Inner.right <= Outer.right ) and then
(Inner.bottom <= Outer.bottom );
end InsideRect;
function InRect( x, y : integer ; r : ARect ) return boolean is
-- test for a point inside of a rectangle
begin
return (x >= r.left and x <= r.right) and then
(y >= r.top and y <= r.bottom);
end InRect;
function IsEmptyRect( r : ARect ) return boolean is
begin
return (r.left > r.right ) or (r.top > r.bottom );
end IsEmptyRect;
---> Sorting order for a list of rectangles
function RectOrder( left, right : ARect ) return boolean is
-- used to order rectangles in a rectangle list
begin
return not InsideRect( left, right );
end RectOrder;
end Common;
texttools/src/os.adb 0000664 0000764 0000764 00000056570 11774715706 013165 0 ustar ken ken ------------------------------------------------------------------------------
-- OS (package body) --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with Interfaces.C; use Interfaces.C;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Directories;
with Ada.Calendar.Formatting;
with Ada.Environment_Variables;
with Ada.Strings.Fixed;
-- Implement some facilities not yet in GNAT.
-- with Ada.Strings.Fixed.Hash_Case_Insensitive;
with Hash_Case_Insensitive;
-- with Ada.Strings.Fixed.Equal_Case_Insensitive;
with Equal_Case_Insensitive;
package body os is
LockPath : constant string := "/home/ken/";
SessionLogPath : Unbounded_String;
ttyname : Unbounded_String;
IsLocaltty : boolean; -- true if not client/server
---> C Interface
--
-- These are POSIX system calls.
function System (Command : in char_array) return int;
pragma Import( C, System, "system");
-- These are all from C_code/system.c.
-- procedure CSync;
-- pragma Import( C, CSync, "CSync" );
function CRunIt (Cmd, Outfile, Parm1, Parm2, Parm3 : in char_array) return int;
pragma Import( C, CRunIt, "CRunIt" );
--->
--
-- Lintel Pathnames
package PathList is new Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => String,
Element_Type => String,
Hash => Hash_Case_Insensitive,
Equivalent_Keys => Equal_Case_Insensitive);
Paths : PathList.Map;
---> Housekeeping
procedure StartupOS is
WasRaising : boolean;
procedure InitializeSessionLog is
use Ada.Directories;
begin
if Exists (Containing_Directory (To_String (Sessionlogpath))) then
declare
use Ada.Text_IO;
File : File_Type;
begin
Create (File, Out_File, To_String (Sessionlogpath));
Close (File);
pragma Unreferenced (File);
end;
SessionLog( "StartupOS: New " & To_String (ProgramName) & " session log started" );
SessionLog( "StartupOS: " & Ada.Calendar.Formatting.Image (Ada.Calendar.Clock));
if LastError /= TT_OK then
Ada.Text_IO.Put_Line ( "StartupOS: Unable to write to session_log; error "
& AnErrorCode'Image (LastError));
end if;
end if;
end InitializeSessionLog;
procedure CheckOSServices is
begin
null;
--MakeTempFilename( TempFile );
--UNIX( ToString( "zoo a " & TempFile & " /etc/passwd > /dev/null" ) );
--if LastError /= CoreOK then -- wierdness when I used if UNIX(zoo)...
-- SessionLog( "StartupOS: Unable to find zoo command", LastError );
--end if;
--Erase( TempFile & ".zoo" );
end CheckOSServices;
use Ada.Environment_Variables;
begin
NoError;
WasRaising := TrapErrors;
if Exists ("TMPDIR") then
PathAlias ("tmp", Value ("TMPDIR"));
else
PathAlias ("tmp", "/tmp");
end if;
if Exists ("HOME") then
PathAlias ("home", Value ("HOME"));
-- Make the $SYS alias by adding ShortProgramName to $HOME
PathAlias ("sys", Value ("HOME") & "/" & To_String (ShortProgramName));
SessionLogPath := To_Unbounded_String (ExpandPath ("$SYS/session_log"));
else
SessionLogPath := Null_Unbounded_String;
end if;
InitializeSessionLog;
if LastError = TT_OK then
ttyname := To_Unbounded_String (UNIX( "tty" ));
IsLocaltty := (ttyname >= "/dev/tty1" and
ttyname <= "/dev/tty9" ) and Length (ttyname ) = 9;
if LastError = TT_OK then
CheckOSServices;
end if;
if LastError /= TT_OK then
LastError := TT_OSService;
null; --Put_Line( Standard_Error, "StartupOS: See session log for error details" );
end if;
end if;
RestoreRaising( WasRaising );
-- load system parameters
-- load user defaults
end StartupOS;
procedure IdleOS( IdlePeriod : in Duration ) is
pragma Unreferenced (Idleperiod);
begin
NoError;
--UNIX( "sync" ); -- should call sync() by C
--should really check and remove an old file from the .Trash
--directory, once per call
end IdleOS;
procedure ShutdownOS is
begin
NoError;
SessionLog( "ShutdownOS: End of session log" );
PathList.Clear( Paths );
end ShutdownOS;
---> OS Interfacing
function UNIX (s : in String) return boolean is
Res : constant Int := System (To_C (S));
begin
NoError;
if res /= 0 then -- DEBUG
SessionLog( "Call to system(""" & s & """) returned error code" & Int'Image (Res));
end if;
return res = 0;
end UNIX;
procedure UNIX( s : in String ) is
Command : constant Char_Array := To_C (S);
begin
NoError;
if System (Command) /= 0 then
Error( TT_SystemError );
end if;
end UNIX;
function UNIX ( s : string ) return String is
use Ada.Text_IO;
File : File_Type;
Output : Unbounded_String := Null_Unbounded_String;
Res : Int;
begin
NoError;
Create (File, In_File, Name => ""); -- temp file
Res := System (To_C (S & " > " & Name (File)));
if Res /= 0 then
SessionLog ("Call to system(""" & S & """) returned error code" & Int'Image (Res));
Error( TT_SystemError );
else
while not End_Of_File (File) loop
Append (Output, Get_Line (File));
end loop;
Delete (File);
end if;
return To_String (Output);
end UNIX;
procedure RunIt( cmd : string;
parm1, parm2, parm3 : string := "";
Results : out StrList.Vector) is
use Ada.Text_IO;
File : File_Type;
Status : Int;
begin
NoError;
Create (File, In_File, Name => ""); -- temp file
Status := CRunIt (To_C (Cmd), To_C (Name (File)), To_C (Parm1), To_C (Parm2), To_C (Parm3));
if Status = 0 then
LoadList (File, Results );
Error( TT_OK );
else
Error( TT_SystemError );
end if;
Delete (File);
pragma Unreferenced (File);
end RunIt;
function NotEmpty (S : in APathName ) return boolean is
P : constant String := Expandpath (S);
use Ada.Directories;
begin
NoError;
return Exists (P) and then Size (P) /= 0;
end NotEmpty;
function IsDirectory (S : in APathName ) return boolean is
P : constant String := Expandpath (S);
use Ada.Directories;
begin
NoError;
return Exists (P) and then Kind (P) = Directory;
end Isdirectory;
function IsFile (S : in APathName ) return boolean is
begin
NoError;
return Ada.Directories.Exists (ExpandPath (S));
end IsFile;
function Lock (File : in APathName) return Boolean is
-- This is equivalent to the previous version, but arguably
-- efficient since another instance is allowed to take the
-- lock...
use Ada.Text_IO;
File_Handler : File_Type;
begin
Create (File_Handler, Out_File, LockPath & ExpandPath (File));
Close (File_Handler);
return True;
exception
when others =>
return False;
end Lock;
procedure Unlock (File : in APathName ) is
begin
Ada.Directories.Delete_File (LockPath & Expandpath (File));
end Unlock;
procedure ValidateFilename (fs : in AFileSystem;
oldfn : in APathname;
newfn : out Unbounded_String;
errmsg : out Unbounded_String) is
Changed : Boolean := False;
procedure ValidateUNIX is -- hastily assembled
ch : character;
begin
-- length OK
-- leading character: no special requirements
Newfn := Null_Unbounded_String;
for i in Oldfn'Range loop
Ch := Oldfn (I);
if Ch < ' ' then -- control character?
ch := '_';
Changed := true;
elsif ch > '~' then -- control character?
ch := '_';
Changed := true;
--elsif ch <= 'A' then -- special character?
-- ch := '_';
-- Changed := true;
--elsif ch = '~' then
-- ch := '-';
-- Changed := true;
end if;
Append (Newfn, Ch);
end loop;
if Changed then
ErrMsg := To_Unbounded_String ( "bad characters for UNIX filesystem" );
end if;
end ValidateUNIX;
procedure ValidateUNIX14 is
begin
if Oldfn'Length > 14 then
newfn := To_Unbounded_String (Ada.Strings.Fixed.Head (oldfn, 14 ));
Changed := true;
ErrMsg := To_Unbounded_String ("too many characters for old UNIX filesystem" );
else
ValidateUNIX;
end if;
end ValidateUNIX14;
procedure ValidateDOS is
ch : character;
begin
Newfn := Null_Unbounded_String;
for i in Oldfn'Range loop
ch := Oldfn (i);
if ch <= ' ' then
ch := '_';
Changed := true;
end if;
Append (Newfn, Ch);
end loop;
if Changed then
ErrMsg := To_Unbounded_String ( "bad characters for DOS" );
end if;
end ValidateDOS;
procedure ValidateOS2 is
begin
ValidateUNIX; -- at least, for now
end ValidateOS2;
begin
ErrMsg := Null_Unbounded_String;
if Oldfn'Length = 0 then
Newfn := To_Unbounded_String ("untitled");
ErrMsg := To_Unbounded_String ("Empty file name.");
else
case fs is
when UNIXFS => ValidateUNIX;
when UNIX14FS => ValidateUNIX14;
when DOSFS => ValidateDOS;
when OS2FS => ValidateOS2;
when NONE => null;
end case;
end if;
end ValidateFilename;
procedure ValidatePathname
( fs : in AFileSystem;
oldfn : in APathname;
Newfn : out unbounded_string;
errmsg : out unbounded_string) is
SepChar : character;
SepPos1 : integer;
SepPos2 : integer;
CorrectedFile : Unbounded_String := null_unbounded_string;
thefs : AFileSystem;
LastErrMsg : Unbounded_String := Null_Unbounded_String;
begin
newfn := Null_Unbounded_String;
ErrMsg := Null_Unbounded_String;
case fs is
when UNIXFS => SepChar := '/';
thefs := UnixFS;
when UNIX14FS => SepChar := '/';
thefs := Unix14FS;
when DOSFS => SepChar := '\';
thefs := DosFS;
when OS2FS => SepChar := ':'; -- Is this right for OS/2?
thefs := OS2FS;
when NONE => -- guess at separator
if Ada.Strings.Fixed.Index( oldfn, "/" ) > 0 then
SepChar := '/';
thefs := UnixFS;
elsif Ada.Strings.Fixed.Index( oldfn, "\" ) > 0 then
SepChar := '\';
thefs := DosFS;
elsif Ada.Strings.Fixed.Index( oldfn, ":" ) > 0 then
SepChar := ':';
thefs := OS2FS;
else
SepChar := '/'; -- guess UNIX by default
thefs := UnixFS;
end if;
end case;
SepPos1 := Ada.Strings.Fixed.Index( oldfn, (1 => SepChar));
if SepPos1 = 0 then
ValidateFilename( fs, oldfn, newfn, Errmsg );
else
loop
SepPos2 := Oldfn'length;
for i in SepPos1+1..Oldfn'Last loop
if Oldfn (i) = SepChar then
SepPos2 := i;
exit;
end if;
end loop;
ValidateFilename ( thefs, Oldfn (SepPos1 + 1 .. SepPos2 - 1), CorrectedFile, Lasterrmsg );
if length( CorrectedFile ) /= 0 then
Append (Newfn, SepChar & CorrectedFile);
if length( LastErrMsg ) > 0 then
ErrMsg := LastErrMsg;
end if;
else
Append (Newfn, SepChar & Oldfn (SepPos1 + 1 .. SepPos2 - 1));
end if;
exit when SepPos2 = Oldfn'Last;
SepPos1 := SepPos2;
end loop;
if length( ErrMsg ) = 0 then -- no errors? no changes
newfn := Null_Unbounded_String;
end if;
end if;
end ValidatePathname;
procedure Erase( File : APathName ) is
use Ada.Directories;
begin
NoError;
Delete_File (Expandpath (File));
exception
when Name_Error | Use_Error =>
Error (TT_FileAccess);
end Erase;
procedure Trash( file : APathName ) is
-- remove a file to the trash can, erasing if necessary
WasRaising : boolean;
begin
--NoError called in UNIX
WasRaising := RaisingErrors;
TrapErrors;
UNIX ("mv " & Expandpath (File) & " $HOME/.Trash 2> /dev/null");
if WasRaising then
RaiseErrors;
end if;
if LastError /= TT_OK then
Erase( file );
end if;
end Trash;
procedure EmptyTrash is
begin
--NoError called in UNIX
UNIX ("find $HOME/.Trash -type f -mtime +3 -exec rm {} \;" );
end EmptyTrash;
procedure Move( file1, file2 : APathName ) is
begin
--NoError called in UNIX
UNIX ("mv " & ExpandPath (File1) & " " & ExpandPath (File2) & " 2> /dev/null");
end Move;
function Shrink( file : APathName ) return APathName is
Path : constant String := Expandpath (File);
begin
--NoError called in UNIX
--shrinkstr := To255( "zoo aPq " );
UNIX ("gzip " & Path & " " & Path);
-- if LastError = 0 then
-- Erase (Path & ".bak");
-- end if;
if LastError = 0 then
--return Append( path, ".zoo" );
return Path & ".gz";
else
return "";
end if;
end Shrink;
function Expand( file : APathName ) return APathName is
Path : constant String := Expandpath (File);
begin
--NoError called in UNIX
--expandstr := To255( "zoo x//qO " );
UNIX ("gunzip " & Path);
if LastError = 0 then
pragma Assert (Ada.Strings.Fixed.Tail (Path, 3) = ".gz");
return Ada.Strings.Fixed.Head (Path, Path'Length - 3);
else
return "";
end if;
end Expand;
procedure Archive( arch, file : APathName ) is
-- note possibility of overflow here!
ArchPath : constant String := ExpandPath (Arch);
FilePath : constant String := ExpandPath (File);
begin
--NoError called in UNIX
if Ada.Strings.Fixed.Tail (Archpath, 4) /= ".tgz"
or NotEmpty (Filepath) then
-- should really be not exists
Error( TT_FileExistance );
else
--Cmd := To255( "zoo aunqP " ) & ArchPath & To255(" " ) & FilePath;
UNIX ("tar cfz " & ArchPath & " " & FilePath);
end if;
end Archive;
procedure Extract( arch, file : APathName ) is
ArchPath : constant String := ExpandPath (Arch);
FilePath : constant String := ExpandPath (File);
begin
-- NoError called in UNIX
if NotEmpty (Archpath) then
-- should really be not exists
Error( TT_FileExistance );
return;
end if;
--Cmd := ( To255( "zoo xqO ") & ArchPath & To255(" ") ) & ( FilePath
-- & " > /dev/null" );
UNIX ("tar xfz " & ArchPath & " " & FilePath & " > /dev/null");
end Extract;
procedure Usage (file : in APathName;
me : in AFileUsage := Normal;
us : in AFileUsage := ReadOnly;
everyone : in AFileUsage := ReadOnly ) is
Octal : constant array (Afileusage) of Character
:= (ReadOnly => '4',
Normal => '6',
Run => '7',
None => '0');
begin
--NoError called in UNIX
UNIX ("chmod " & Octal (Me) & Octal (Us) & Octal (Everyone) & " " & ExpandPath (file));
end Usage;
procedure BeginSession is
begin
null;
end BeginSession;
procedure EndSession is
begin
null; -- sync
end EndSession;
---> Directory Utilities
function SpaceUsed( dir : APathName ) return integer is
begin
--NoError called in UNIX
return Integer'Value (UNIX ("du -fs " & ExpandPath (dir)));
end SpaceUsed;
---> Device Utilities
-- function SpaceFree( dev : APathName ) return long_integer is
-- pragma Unreferenced(Dev);
-- begin
-- return 1; -- NYI
-- end SpaceFree;
-- function TotalSpace( dev : APathName ) return long_integer is
-- pragma Unreferenced(Dev);
-- begin
-- return 1;
-- end TotalSpace;
-- function EntriesFree( dev : APathName ) return long_integer is
-- pragma Unreferenced(Dev);
-- begin
-- return 1;
-- end EntriesFree;
-- function TotalEntries( dev : APathname ) return long_integer is
-- pragma Unreferenced(Dev);
-- begin
-- return 1;
-- end TotalEntries;
-- function OnDevice( path : APathName ) return APathname is
-- pragma Unreferenced(Path);
-- begin
-- return NullStr255;
-- end OnDevice;
--->
function GetFreeClusterHost return string is
begin
return UNIX( "uname -n" );
end GetFreeClusterHost;
---> Str255Lists
procedure Loadlist (File : in Ada.Text_IO.File_Type;
StringList : out Strlist.Vector) is
use Ada.Text_IO;
begin
Stringlist.Clear;
while not End_Of_File (File) loop
StringList.Append (Get_Line (File));
end loop;
exception
when Storage_Error =>
StringList.Clear;
Error( TT_LowMemory );
end Loadlist;
procedure Loadlist (Path : in String;
StringList : out StrList.Vector) is
-- load a string list from a file
use Ada.Text_IO;
File : File_Type;
begin
begin
Open (File, In_File, Expandpath (Path));
exception
when Status_Error =>
Error( TT_FileLocking );
return;
when Name_Error =>
Error( TT_FileExistance );
return;
end;
Loadlist (File, Stringlist);
Close (File);
exception
when others =>
if Is_Open (File) then
Close (File);
end if;
end LoadList;
procedure savelist (File : in Ada.Text_IO.File_Type;
StringList : in Strlist.Vector) is
use Ada.Text_IO;
procedure Process (Position : in Strlist.Cursor);
procedure Process (Position : in Strlist.Cursor) is
begin
Put_Line (File, Strlist.Element (Position));
end Process;
begin
StringList.Iterate (Process'Access);
end Savelist;
procedure SaveList (Path : in APathName;
StringList : in StrList.Vector ) is
-- save a string list to a file
use Ada.Text_IO;
File : file_type;
begin
begin
Create (File, Out_File, ExpandPath (Path));
exception
when Status_Error =>
Error( TT_FileLocking );
return;
when Name_Error =>
Error( TT_FileExistance );
return;
end;
Savelist (File, Stringlist);
Close (File);
exception -- translate Text_IO errors into core errors
when others =>
if Is_Open (File) then
Close (File);
end if;
end SaveList;
function IsLocal return boolean is
begin
return IsLocaltty;
end IsLocal;
procedure SetPath( s : APathName ) is
use Ada.Directories;
Path : constant String := Expandpath (S);
begin
Set_Directory (Path);
exception
when Name_Error | Use_Error =>
SessionLog( "SetPath: can't change path to " & Path);
Ada.Text_IO.Put_Line( Ada.Text_IO.Standard_Error, "SetPath: TT_SystemError -- can't change path" );
Error( TT_SystemError );
end SetPath;
procedure PathAlias (Alias : in String;
Path : in APathName) is
begin
NoError;
Paths.Include (Alias, Path);
end PathAlias;
function ExpandPath (Path : in APathName )
return APathName is
-- check for leading number and convert to a path
use Pathlist;
posn : Natural;
Position : Cursor;
begin
if Path'Length = 0 or else Path (Path'First) /= '$' then
return Path;
end if;
Posn := Ada.Strings.Fixed.Index
(Source => Path (Path'First + 1 .. Path'Last),
Pattern => (1 => '/'));
if Posn = 0 then
Posn := Path'Last + 1;
end if;
Position := Paths.Find (Path (Path'First + 1 .. Posn - 1));
if Position = No_Element then
return Path (Posn .. Path'Last);
end if;
return Element (Position) & Path (Posn .. Path'Last);
end ExpandPath;
procedure SplitPath (path : in String;
dir : out Unbounded_String;
file : out unbounded_string) is
-- split path into directory and file
use Ada.Directories;
begin
Dir := To_Unbounded_String (Containing_Directory (Path));
File := To_Unbounded_String (Simple_Name (Path));
end SplitPath;
procedure DecomposePath( path : in APathname;
PathType : out APathType;
Host : out unbounded_string;
Filepath : out unbounded_string) is
SlashPos : Natural;
begin
FilePath := To_Unbounded_String (ExpandPath (Path));
--
-- Check for a standard path--process and bail out if is one
--
Slashpos := Index (FilePath, "://");
if slashPos = 0 then -- no ://?
PathType := File;
Host := To_Unbounded_String ("localhost"); -- then it's this machine
return;
end if;
--
-- Must be a URL.
-- Check for the leading transfer method in the URL.
--
Pathtype := Unknown;
for Kind in Apathtype'Succ (Unknown) .. Apathtype'Last loop
if Equal_Case_Insensitive (To_String (Head (FilePath, Slashpos + 2)),
Apathtype'Image (Kind) & "://") then
Tail (Filepath, Length (Filepath) - Slashpos - 2);
PathType := Kind;
exit;
end if;
end loop;
if Pathtype = Unknown then
Delete (Filepath, 1, SlashPos + 2); -- scrap unknown URL prefix
end if; -- and try to process anyway
--
-- all URL's are host and optional path
--
if Element( Filepath, length( Filepath ) ) = '/' then -- ending slash?
Head (Filepath, Length (Filepath) - 1); -- delete it
end if;
Ada.text_io.put_line( "checking " & To_String( Filepath ) );
SlashPos := Index( Filepath, "/" ); -- where's the next slash?
if SlashPos > 0 then -- if there is one
Ada.text_io.put_line("has path" );
Host := Head( Filepath, SlashPos-1 ); -- the address is before it
Ada.text_io.put_line("path = " & To_String( Filepath ) );
Delete( Filepath, 1, SlashPos ); -- removing it and slash
Ada.text_io.put_line("after host removal, path = " & To_String( Filepath ) );
else -- but if there isn't a slash
Ada.text_io.put_line("has no path" );
Host := Filepath; -- then it's just the address
FilePath := Null_Unbounded_String; -- with no path
end if;
end DecomposePath;
---> Append for Text File
procedure AddFile( file, text : in String ) is
use Ada.Text_IO;
F : File_Type;
begin
if Ada.Directories.Exists (File) then
Open (F, Append_File, File);
Put_Line (F, Text);
Close (F);
end if;
exception
when others =>
if Is_Open (F) then
Close (F);
end if;
raise;
end AddFile;
---> Logging
procedure SessionLog (Message : in String) is
WasRaising : boolean;
begin
NoError;
WasRaising := TrapErrors;
Addfile (To_String (Sessionlogpath), Message);
RestoreRaising( WasRaising );
end SessionLog;
procedure SessionLog (Message : in String;
ErrorCode : in AnErrorCode ) is
begin
--NoError implied
SessionLog (Message & " (Error Code" &
AnErrorCode'Image (ErrorCode) & ")" );
end SessionLog;
end os;
texttools/src/equal_case_insensitive.adb 0000664 0000764 0000764 00000000644 11774715706 017255 0 ustar ken ken with Ada.Characters.Handling;
function Equal_Case_Insensitive (Left, Right : String) return Boolean is
use Ada.Characters.Handling;
begin
if Left'Length /= Right'Length then
return False;
end if;
for I in 0 .. Left'Length-1 loop
if To_Upper (Left (Left'First + I)) /= To_Upper (Right (Right'First + I)) then
return False;
end if;
end loop;
return True;
end Equal_Case_Insensitive;
texttools/src/system.c 0000664 0000764 0000764 00000005471 11774715706 013556 0 ustar ken ken #include
#include
#include
#include
#include
#include
#include
#include /* unlink */
#include /* red hat */
#include /* for runit */
/*----------------------------*/
/* */
/* System C commands from Ada */
/* */
/*----------------------------*/
// char s[81]; /* temporary string */
/* CSYNC */
void CSync() {
sync();
sync();
sync();
}
int CRunIt (const char * path,
const char * outfile,
const char * param1,
const char * param2,
const char * param3 ) {
pid_t child, result;
int fd0, fd1, fd2;
int status;
int i;
if ( !(child = fork()) ) {
/* Redirect stdin, out, err */
for (i=0; i< FOPEN_MAX; ++i )
close( i );
fd0 = open( "/dev/null", O_RDONLY );
if (fd0 < 0 ) exit( 110 );
fd1 = open( outfile, O_WRONLY | O_CREAT | O_TRUNC, S_IRUSR | S_IWUSR);
if (fd1 < 0 ) exit( 111 );
fd2 = dup( 1 );
if (param1[0]=='\0') {
execlp( path, path, NULL );
} else if (param2[0]=='\0') {
execlp( path, path, param1, NULL );
} else if (param3[0]=='\0') {
execlp( path, path, param1, param2, NULL );
} else {
execlp( path, path, param1, param2, param3, NULL );
}
/* if we got here, file probably wasn't found */
exit( errno );
}
result = waitpid( child, &status, 0 );
/* wait( &status ); */
/* if ( WIFEXITED( status ) != 0 ) */
/* status = WEXITSTATUS( status ); */
status = 112;
if ( result >= 0 ) {
status = WIFEXITED( status );
}
return status;
}
int CRunItForStdErr (char * path,
char * outfile,
char * param1,
char * param2,
char * param3) {
/* dicard standard out, standard error to outfile */
/* written for uuchk */
pid_t child, result;
int fd0, fd1, fd2;
int status;
int i;
if ( !(child = fork()) ) {
/* Redirect stdin, out, err */
for (i=0; i< FOPEN_MAX; ++i ) close( i );
fd0 = open( "/dev/null", O_RDONLY );
if (fd0 < 0 ) exit( 110 );
fd1 = open( "/dev/null", O_WRONLY );
if (fd1 < 0 ) exit( 111 );
fd2 = open( outfile, O_WRONLY | O_CREAT | O_TRUNC, S_IRUSR | S_IWUSR);
if (fd2 < 0 ) exit( 111 );
if (param1[0]=='\0') {
execlp( path, path, NULL );
} else if (param2[0]=='\0') {
execlp( path, path, param1, NULL );
} else if (param3[0]=='\0') {
execlp( path, path, param1, param2, NULL );
} else {
execlp( path, path, param1, param2, param3, NULL );
}
/* if we got here, file probably wasn't found */
exit( errno );
}
status = 112;
result = waitpid( child, &status, 0 );
if ( result >= 0 )
status = WIFEXITED( status );
return status;
}
texttools/src/english.ads 0000664 0000764 0000764 00000010276 11774715706 014207 0 ustar ken ken ------------------------------------------------------------------------------
-- ENGLISH --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
package English is
-- Name of this language for being displayed in "About" window
-- should be in the form "language translation". eg. "English
-- Translation"
s_languagepackage : constant String := "English Translation";
-- Buttons
--
-- This is the text for screen buttons and menu items.
-- The "Hot" character is the hilighted letter in the text that
-- you press to activate the button (usually first letter).
s_About : constant String := "About";
s_About_Hot : constant character := 'a';
s_Cancel : constant String := "Cancel";
s_Cancel_Hot : constant character := 'l';
-- uses l instead of c so not to conflict with close
s_Close : constant String := "Close";
s_Close_Hot : constant character := 'c';
s_Find : constant String := "Find";
s_Find_Hot : constant character := 'f';
s_Next : constant String := "Next";
s_Next_Hot : constant character := 'n';
s_No : constant String := "No";
s_No_Hot : constant character := 'n';
s_OK : constant String := "OK";
s_OK_Hot : constant character := 'o';
s_Print : constant String := "Print";
s_Print_Hot : constant character := 'p';
s_Save : constant String := "Save";
s_Save_Hot : constant character := 's';
s_Yes : constant String := "Yes";
s_Yes_Hot : constant character := 'y';
-- Accessories Menu
s_Cal : constant String := "Calendar";
s_Cal_Hot : constant character := 'c';
s_CalTitle : constant String := "Calendar for ";
-- eg. "Calendar for 1998"
-- Common Window Titles
s_Note : constant String := "Note";
s_Caution : constant String := "Caution";
s_Warning : constant String := "Warning";
-- Other Common Words
s_Working : constant String := "Working";
end English;
texttools/src/hash_case_insensitive.adb 0000664 0000764 0000764 00000000426 11774715706 017067 0 ustar ken ken with Ada.Strings.Fixed.Hash;
with Ada.Strings.Maps.Constants;
function Hash_Case_Insensitive
(Key : String)
return Ada.Containers.Hash_Type
is
use Ada.Strings;
begin
return Fixed.Hash (Fixed.Translate (Key, Maps.Constants.Upper_Case_Map));
end Hash_Case_Insensitive;
texttools/src/windows.ads 0000664 0000764 0000764 00000035031 11774715706 014244 0 ustar ken ken ------------------------------------------------------------------------------
-- WINDOWS --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with common; use common;
pragma Elaborate( Common );
with os; use os;
with userio; use userio;
with controls; use controls;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package windows is
---> Housekeeping
procedure StartupWindows;
procedure IdleWindows( IdlePeriod : in Duration );
procedure ShutdownWindows;
---> Windows
type AWindowStyle is (Normal, Frameless, Success, Warning, Danger, Status,
Emphasis, Subdued, Floating, MenuBar, Menu);
pragma convention( C, AWindowStyle );
type AWindowNumber is new short_integer range 0..16; -- number of windows
CurrentWindow : AWindowNumber; -- the active window
type RedrawingAmounts is (none, frame, whole );
pragma convention( C, RedrawingAmounts );
-- You can optimize the redrawing:
-- none: draw only controls, don't redraw window itself
-- frame: draw window frame only and controls
-- whole: erase and redraw whole window and controls
type AWindowDrawingCallBack is access procedure;
type LongLineHandling is (none, justify, wrap );
pragma convention( C, LongLineHandling );
function OpenWindow( title : in String ; l, t, r, b : integer;
Style : AWindowStyle := Normal; HasInfoBar : boolean := false;
CallBack : AWindowDrawingCallBack := null ) return AWindowNumber;
procedure OpenWindow( title : in String ; l, t, r, b : integer;
Style : AWindowStyle := Normal; HasInfoBar : boolean := false;
CallBack : AWindowDrawingCallBack := null );
procedure SaveWindow( path : string; arch : APathName := "" );
procedure LoadWindow( path : string; arch : APathName := "" );
procedure EraseWindow;
procedure DrawWindow( id : AWindowNumber;
Redraw : RedrawingAmounts := none );
procedure DrawWindow( Redraw : RedrawingAmounts := none );
procedure MoveWindow( id : AWindowNumber; dx, dy : integer );
procedure MoveWindow( dx, dy : integer );
procedure ScrollWindow( id : AWindowNumber; dx, dy : integer );
procedure ScrollWindow( dx, dy : integer );
procedure CloseWindow; -- clears controls, too.
procedure ShellOut( cmd : In String );
procedure SetInfoText( text : in String );
procedure SetWindowTimeout( c : AControlNumber; t : in Duration );
procedure SetWindowTitle( title : in String );
function GetWindowTitle( id : AWindowNumber ) return String;
function GetWindowStyle( id : AWindowNumber ) return AWindowStyle;
function GetWindowCallBack(id : AWindowNumber) return AWindowDrawingCallBack;
function GetWindowHasFrame( id : AWindowNumber ) return boolean;
function GetWindowFrame( id : AWindowNumber ) return ARect;
function GetWindowFrameColour( id : AWindowNumber ) return APenColourName;
function GetWindowContent( id : AWindowNumber ) return ARect;
function GetWindowHasInfoBar( id : AWindowNumber ) return boolean;
function GetWindowInfoText( id : AWindowNumber ) return string;
function GetWindowXScroll( id : AWindowNumber ) return integer;
function GetWindowYScroll( id : AWindowNumber ) return integer;
--procedure SwapWindows( id1, id2 : AWindowNumber );
--procedure MoveToFront( id : AWindowNumber );
--procedure MoveToBack( id : AWindowNumber );
procedure ResetWindow( id : AWindowNumber );
procedure ResetWindow;
procedure RefreshDesktop;
---> Controls in Windows
--
procedure AddControl( ptr : AControlPtr; -- pointer to the control
IsGlobal : boolean := true ; -- true if control in global coords.
Control : boolean := true );-- false if pgm wants to handle hits
procedure DeleteControl( id : AControlNumber );
function FindControl( x, y : integer ) return AControlNumber;
function GetControl( id : AControlNumber ) return AControlPtr;
procedure InvalidateControls( ThisWindow : AWindowNumber );
---> Dialog Manager
--
-- The dialog routines are responsible for all control interactions.
-- Wherever possible, dialog details are kept out of the controls. One
-- exception is instant simple buttons: the button needs to know how to
-- draw itself (thus, the instant flag must be in it's fields), and it
-- doesn't know when it's selected by a hotkey scan so the dialog manager
-- must "manually" check to see if it hit an instant simple button.
-- Luckily only simple buttons are the only controls that can be instant
-- (unless a make a list of instant simple buttons later).
--
-- Also, scroll bar / list associations are kept in the fields of the
-- controls, though this is not strictly necessary since the controls
-- don't need to know this. Probably store it in the Window's control
-- list at some later point.
--
-- Dialog Tasks:
--
-- None -- time out
-- DialogError -- no controls in window so can't dialog it
-- Hit -- control was hit and control to program
-- Complete -- dialog is finished
-- NonControlHit -- window was hit, but not the control
--
-- Whether or not a particular control is handled is determined
-- when the control is added to the window. This is different than
-- the Apple IIgs where common tasks (over all controls) can be turned
-- on and off.
-- Window updates, focus changes not yet implemented.
type ADialogTask is (None, DialogError, Hit, Complete, NonControlHit);
-- Dialog Record
--
-- Control should be initialized to 1
type ADialogTaskRecord is record
MyTask : ADialogTask; -- what DoDialog is reporting
InputRec : AnInputRecord; -- input record received
Control : AControlNumber; -- control that is affected
Action : ADialogAction; -- result to return??
end record;
type ADialogTaskCallBack is access
procedure( DialogTask : in out ADialogTaskRecord);
-- DoDialog
--
-- DialogTask - record returned as result of the dialog
-- TaskCB - callback for handling manual controls
-- HearInCB - callback for filtering incoming InputRec
-- HearOutCB - callback for filtering outgoing Action
procedure DoDialog( DialogTask : in out ADialogTaskRecord;
TaskCB : in ADialogTaskCallBack := null;
HearInCB : in ADialogTaskCallBack := null;
HearOutCB : in ADialogTaskCallBack := null );
---> Standard Dialogs
procedure NoteAlert( message : string ); -- OK button
procedure CautionAlert( message : string ); -- OK button
procedure StopAlert( message : string ); -- OK button
function YesAlert( message : string; kind : BeepStyles )
return boolean; -- Yes (default) or No
function NoAlert( message : string; kind : BeepStyles )
return boolean; -- No (default) or Yes
function CancelAlert( message, OKCaption : string; kind : BeepStyles )
return boolean; -- OK (default,customized) or Cancel
function YesCancelAlert( message : string; kind : BeepStyles )
return AControlNumber; -- Yes, No or Cancel
---> General Window I/O
procedure MoveTo( x, y : integer ); -- move to local x, y
procedure Move( dx, dy : integer ); -- move by indicated x, y change
procedure ToLocal( r : in out ARect ); -- global to local
procedure ToLocal( x, y : in out integer ); -- coordinates
procedure ToGlobal( r : in out ARect ); -- local to global
procedure ToGlobal(x, y : in out integer ); -- coordinates
procedure print; -- move to next line
procedure print( s : string ); -- print a string
procedure print( i : integer ); -- print an integer
procedure print( l : long_integer );-- print a long integer
---> Standard File Dialogs
type AValidateFilenameRec is record
Filename : Unbounded_String; -- filename to be validated
Replied : boolean; -- true if not cancelled
end record;
procedure ValidateFilename( desc : in out AValidateFilenameRec );
-- These are based on the Apple IIgs file dialogs
type ASelectOpenFileRec is record
Prompt : unbounded_string; -- prompt for user
Replied : boolean; -- true if file was selected
Suffix : unbounded_string; -- desired file suffix
Direct : boolean; -- true if can select directories
Path : unbounded_string; -- file path
Fname : unbounded_string; -- file name (or "" if "accept"ed)
end record;
type ASelectSaveFileRec is record
Prompt : unbounded_string; -- prompt for user
Replied : boolean; -- true if file was selected
Default : unbounded_string; -- default file name
Path : unbounded_string; -- chosen path
Fname : unbounded_string; -- file name
end record;
procedure SelectOpenFile( sofrec : in out ASelectOpenFileRec );
procedure SelectSaveFile( ssfrec : in out ASelectSaveFileRec );
-- Display a dialog box for opening/saving a file and returning the
-- path chosen by the user.
procedure ShowListInfo( title : string;
t : integer;
lst : in out StrList.Vector;
last : boolean := false;
longLines : LongLineHandling := none);
-- display a list for the user to view; list isn't cleared. List is
-- full-screen except for the top of the window at t.
procedure ShowListInfo( title : string;
l, t, r, b : integer;
lst : in out StrList.vector;
last : boolean := false;
longLines : LongLineHandling := none);
procedure EditListInfo( title : string;
t : integer;
lst : in out StrList.vector;
result : out boolean;
last : boolean := false);
procedure EditListInfo( title : string;
l, t, r, b : integer;
lst : in out StrList.vector;
result : out boolean;
last : boolean := false );
-- Put up a window in the given coordinates and display the string list
-- that you specify. If you use EditListInfo, the user can edit the
-- list and result is true if the list has been changed.
procedure AppendNotepad( s : in StrList.Vector);
-- Add contents of list to end of notepad accessory
--- These entries for use by Window Editor program ONLY
--- pretend they're private, will ya?!
--- Control Table Definitions (for Windows)
type AControlTableRecord is record
ptr : AControlPtr; -- pointer to a control
mine : boolean; -- true if controlled by Window Manager
end record;
type ControlTableEntries is array(1..AControlNumber'Last)
of AControlTableRecord;
type AControlTable is record -- a control table is
size : AControlNumber; -- number of entries in the table
current : AControlNumber; -- currently active control
control : ControlTableEntries; -- the actual table
end record;
---> Window Definition (should be tagged)
type AWindow is record
Title : unbounded_string; -- title of the window
HasFrame : boolean; -- true if the window has a visible frame
Relative : boolean; -- frame relative to last window (NYI)
Frame : ARect; -- rectangle around whole window
FrameColour : APenColourName; -- colour of frame
Content : ARect; -- rectangle inside window border
table : AControlTable; -- list of controls in the window
HasInfoBar : boolean; -- true if has an info bar
InfoBar : ARect; -- dimensions of the info bar
InfoText : unbounded_string; -- text in the info bar
Style : AWindowStyle; -- style (purpose) of window
Loaded : Boolean; -- true if loaded with LoadWindow
SaveX, SaveY : integer; -- for saving X & Y of Curses' cursor
DrawCB : AWindowDrawingCallBack; -- drawing routine (or null)
SoundPath : Unbounded_string; -- path for sound to play on openx
SoundID : unbounded_string; -- id for same
SongPath : unbounded_string; -- path for song to play on open
SongID : unbounded_string; -- id for same
Timeout : Duration := -1.0; -- timeout in seconds (-1 = none)
TimeoutControl : AControlNumber; -- control to execute on timeout (NYI)
ParentFile : unbounded_string; -- file to inherit controls from (NYI)
XScroll : integer; -- amount of scrolling from home position
YScroll : integer; -- ditto
end record;
pragma Pack( AWindow );
Window : array( 1..AWindowNumber'Last ) of AWindow; -- stack of windows
NextWindow : AWindowNumber; -- next free window, 0 = no more
private
pragma InLine( ToGlobal );
pragma InLine( ToLocal );
end windows;
texttools/src/equal_case_insensitive.ads 0000664 0000764 0000764 00000000113 11774715706 017265 0 ustar ken ken function Equal_Case_Insensitive
(Left, Right : String)
return Boolean;
texttools/src/userio.ads 0000664 0000764 0000764 00000050656 11774715706 014072 0 ustar ken ken ------------------------------------------------------------------------------
-- USER IO --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
-- Design notes:
-- 1. Errors are only returned at startup and shutdown (with the
-- exception of constraint errors and the like.)
-- 2. As much as possible, the package supports both logical and
-- real pen/text attributes. Unless you really need to use the
-- actual attribute (eg. RGB), use the logical one (ColourName's).
with common; use common;
pragma Elaborate( common ); -- remind Ada that Common elaborates first
with os; use os;
with Ada.Calendar;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package userio is
---> Definitions of Important Control Characters
--
-- These maybe represented by more than one key (see C sources)
NullKey : constant character := character'val( 0); -- no keypress
LeftKey : constant character := character'val( 8); -- left arrow
RightKey : constant character := character'val( 21); -- right arrow
UpKey : constant character := character'val( 11); -- up key
DownKey : constant character := character'val( 10); -- down key
HomeKey : constant character := character'val( 25); -- home key (& ctrl-y)
PageUpKey : constant character := character'val( 16); -- page up (& ctrl-p)
PageDownKey:constant character := character'val( 14); -- page up (& ctrl-n)
EndKey : constant character := character'val( 5); -- end key (& ctrl-e)
ClearKey : constant character := character'val( 24); -- clear (ctrl-x)
DeleteKey : constant character := character'val(127); -- delete/backspace
CopyKey : constant character := character'val( 2); -- copy key (& ctrl-b)
PasteKey : constant character := character'val( 22); -- paste key (ctrl-v)
ReturnKey : constant character := character'val( 13); -- ok
TabKey : constant character := character'val( 9); -- ok
BackKey : constant character := character'val( 20); -- backtab (& ctrl-t)
HelpKey : constant character := character'val( 27); -- help key (F1/ESC)
MacroKey : constant character := character'val( 1); -- do mac (F2/ctrl-a)
RedrawKey : constant character := character'val( 12); -- redraw scrn (ctr-l)
MarkKey : constant character := character'val( 30); -- mark key (ctrl-r)
CSearchKey: constant character := character'val( 29); -- fwd chr search (ctrl-])
---> Error Codes
--
-- (none, yet)
---> Housekeeping
--
-- LastError = error
procedure StartupUserIO;
pragma export( C, StartupUserIO, "startup_userio" );
procedure IdleUserIO( IdlePeriod : in Duration );
procedure ShutdownUserIO;
pragma export( C, ShutdownUserIO, "shutdown_userio" );
procedure ResetUserIO; -- for Windows refresh desktop
pragma export( C, ResetUserIO, "reset_userio" );
procedure BlueBackground( blueOn : boolean );
-- Set the default background to blue or black. On startup, it's
-- blue.
-- Errors: none
function IsBlueBackground return boolean;
-- return whether background is blue or black
-- Errors: none
---> Terminal Info
--
-- True device independance is difficult: these calls let you determine
-- if the I/O devices support some general features.
type ADisplayInfoRec is record -- (eg. for vt-100)
fields : natural; -- count of number of fields (>=8) (eg. 8)
TextBased : boolean; -- true if a text-based display (eg. true)
H_Res : natural; -- horizontal resolution (eg. 80)
V_Res : natural; -- vertical resolution (eg. 24)
C_Res : natural; -- R/G/B bits (0=N/A) (eg. 0)
P_Len : natural; -- length of the palette (0=N/A) (eg. 0)
D_Buf : natural; -- total number of display buffers (eg. 1)
S_Res : natural; -- sound resolution (0=N/A) (eg. 0)
Y_Res : natural; -- sound voices/channels (0=N/A) (eg. 0)
end record;
procedure GetDisplayInfo( info : in out ADisplayInfoRec );
pragma export( C, GetDisplayInfo, "get_display_info" );
type AnInputInfoRec is record -- (eg for vt-100)
fields : natural; -- count of number of fields (>=4) (eg. 4)
HasKeyboard : boolean; -- true if has active keyboard (eg. true)
HasDirection : boolean; -- true if has direction device(eg. false)
HasVelocity : boolean; -- true if dir dev can do velocity (eg.false)
HasLocator : boolean; -- true if has locator device (eg. false)
end record;
procedure GetInputInfo( info : in out AnInputInfoRec );
pragma export( C, GetInputInfo, "get_input_info" );
---> Pen and Palette Attributes
--
-- APenColourName is a shortform for a particular colour
-- ARGBComponent is the percentage of a colour component
-- APaletteEntryNumber is for access the colour palette
type APenColourName is (None, Outline, ScrollBack, ScrollThumb,
ThermBack, ThermFore, White, Red, Purple, Green, Blue, Yellow, Black );
pragma convention( C, APenColourName );
subtype ARGBComponent is float;
subtype APaletteColour is natural;
-- Setting the current pen colour
procedure SetPenColour( name : APenColourName );
pragma export( C, SetPenColour, "set_pen_colour" );
procedure SetPenColour( redC, greenC, blueC : ARGBComponent );
procedure SetPenColour( colour : APaletteColour );
-- Setting palette colours (if device has palettes)
procedure SetPaletteColour( colour : APaletteColour; name : APenColourName );
procedure SetPaletteColour( colour : APaletteColour; redC, greenC, blueC
: ARGBComponent );
-- Getting the current pen colour
function GetPenColour return APenColourName;
pragma export( C, GetPenColour, "get_pen_colour" );
procedure GetPenColour( redC, greenC, blueC : in out ARGBComponent );
function GetPenColour return APaletteColour;
function GetPenColour( colour : APaletteColour ) return APenColourName;
-- not written
-- procedure GetPenColour( colour : APaletteColour; redC, greenC, blueC
-- : in out ARGBComponent );
-- Getting palette colours (if device has palettes)
procedure GetPaletteColour( colour : APaletteColour; redC, greenC, blueC
: in out ARGBComponent );
function GetPaletteColour( colour : APaletteColour ) return APenColourName;
function FindPaletteColour( redC, greenC, blueC : ARGBComponent )
return APaletteColour;
procedure GetPenPos( x, y : out integer );
pragma export( C, GetPenPos, "get_pen_pos" );
procedure GetPixel( x, y : integer; redC, greenC, blueC : out ARGBComponent );
procedure SetPenSize( p : Points );
function GetPenSize return Points;
-- Turtle Graphics
procedure SetPenAngle( angle : float );
procedure ChangePenAngle( degrees : float );
function GetPenAngle return float;
procedure DrawForward( dist : float );
---> Text attributes
--
-- TextStyles describe the type of text to be drawn
type ATextStyle is (Normal, Bold, Underline, Italic, BoldUnderline,
BoldItalic, ItalicUnderline, BoldItalicUnderline, Success, Failure,
Warning, Status, Citation, SectionHeading, SubHeading, Heading, Title,
Emphasis, Input, Marquee, Headline, FinePrint, DefinedTerm, Footnote,
ToAddress, FromAddress, SubScript, SuperScript );
-- Text Styles
procedure SetTextStyle( style : ATextStyle );
function GetTextStyle return ATextStyle;
-- Text Colour
procedure SetTextColour( name : APenColourName );
function GetTextColour return APenColourName;
-- Text Font
procedure SetTextFont( font : in string; size : natural := 0 );
procedure SetTextFont( fonts : in StrList.Vector; size : natural := 0 );
procedure GetTextFont( font : out Unbounded_String; size : out natural );
procedure GetFontNameList( TheList : out StrList.Vector);
procedure GetFontSizeList( Font : in String; TheList : out StrList.Vector);
-- Text Sizes (always 1 pixel each for text screens)
function GetTextHeight( ch : character ) return integer;
function GetTextHeight( s : string) return integer;
function GetTextWidth( ch : character ) return integer;
function GetTextWidth( s : string ) return integer;
pragma Inline( GetTextHeight );
pragma Inline( GetTextWidth );
---> Sound Functions
--
-- This is strickly a draft.
subtype AVoice is natural; -- voice number
subtype ASound is APathName; -- sound path
subtype ASong is natural; -- song number
-- Digital Sound
procedure PlaySound( sound : ASound );
procedure PlaySound( voice : AVoice; sound : ASound;
angle : float := 0.0;
volume : float := 100.0;
freqchange : float := 0.0 );
procedure StopSound( voice : AVoice );
procedure StopSounds;
-- Songs
procedure PlaySong( song : ASong );
procedure StopSong;
-- Misc Functions
function GetFreeVoice return AVoice;
function GetMasterVolume return float;
procedure SetMasterVolume( volume : float );
---> Misc I/O Functions
--
-- BeepStyles describe the type of beep to be used
type BeepStyles is (Normal, Success, Failure, Warning, Status, BadInput,
HourChime, QuarterChime1, QuarterChime2, QuarterChime3, Alarm,
NewMail, LowPower, Startup, Shutdown );
procedure MoveToGlobal( x, y : in integer );
pragma export( C, MoveToGlobal, "move_to_global" );
procedure MoveForward( dist : float );
procedure Beep( style : BeepStyles );
procedure Cls;
pragma Import( C, Cls, "Cls" ); -- Curses move/clrtobot
procedure FlushKeys; -- Curses' flushinp
pragma Import( C, FlushKeys, "FlushKeys" );
--procedure Refresh; -- Curses' refresh
-- pragma Import( C, Refresh, "Refresh" );
---> Basic Input
--
-- Modeled on three device types:
-- 1. ASCII Input Device (eg. keyboard) -- required
-- 2. Location Device (eg. mouse)
-- 3. Direction Device (eg. joystick)
--
-- On demand functions (avoids input event handling):
--
-- Mouse location is especially useful
subtype ADirection is float; -- 0 to 360 degrees
subtype AVelocity is float; -- 0 to 100 percent
function Keypress( shortblock : boolean ) return character;
-- get key, null if none; shortblock uses half-delay
procedure GetKey( c : out character ); -- get key, wait if none
pragma export( C, GetKey, "get_key" );
procedure GetLocation( x, y : out integer ); -- get mouse
procedure GetDirection( direction : out ADirection;
velocity : out AVelocity ); -- get joystick
---> Input Event Handling
--
-- Assumes that there is only one data entry stream and one locator
-- stream (may represent the input of more than one device). OS events
-- handled by core_system's IPC.
--
-- NullInput - return with no wait on GetInput
-- KeyInput - given key was pressed
-- HeldKeyInput - give key is being held (may not be supported)
-- DirectionInput - direction and distance (eg. joystick)
-- LocationInput - a pair of coordinates (eg. change in mouse)
-- ButtonDownInput - button being pressed (eg. mouse or joystick)
-- ButtonUpInput - button being released (eg. mouse or joystick)
-- MoveInput - mouse moved
-- HeartBeatInput - "application busy" event for screen savers, etc.
-- UserInput - user-defined event
type AnInput is (NullInput, KeyInput, HeldKeyInput, DirectionInput,
LocationInput, ButtonDownInput, ButtonUpInput, HeartBeatInput,
MoveInput, UserInput);
pragma convention( C, AnInput );
type AnInputRecord (InputType : AnInput := NullInput) is record
TimeStamp : Ada.Calendar.Time; -- time of the event
case InputType is
when NullInput => null; -- no data
when KeyInput => Key : character; -- key typed
when HeldKeyInput => HeldKey : character; -- key held
when DirectionInput => Direction : ADirection;-- dir/degrees
Velocity : AVelocity; -- 0...100%
when LocationInput => X, Y : integer; -- location/grid
when ButtonDownInput => DownButton : integer; -- button pressed
DownLocationX : integer;
DownLocationY : integer;
when ButtonUpInput => UpButton : integer; -- button released
UpLocationX : integer;
UpLocationY : integer;
when HeartBeatInput => null; -- no data
when MoveInput => MoveLocationX : integer; -- moved
MoveLocationY : integer;
when UserInput => id : long_integer; -- user defined
end case;
end record;
type AResponseTime is (Blocking, -- Wait Indefinitely for input
Erratic, -- Give up after a fraction of a sec.
Instant -- Give up immediately
);
pragma convention( C, AResponseTime );
-- Standard Calls
procedure GetInput( e : out AnInputRecord; response : AResponseTime
:= Blocking );
--pragma export( CPP, GetInput, "get_input" );
procedure SetInput( e : AnInputRecord; usetime : boolean := false );
--pragma export( CPP, SetInput, "set_input" );
procedure HeartBeat; -- shorthand call for SetInput( SomeHeartBeatRec );
pragma export( C, Heartbeat, "heart_beat" );
procedure SetInputString( s : string ); -- post string to input queue
procedure FlushInput;
pragma export( C, FlushInput, "flush_input" );
function GetInputLength return Natural;
pragma export( C, GetInputLength, "get_input_length" );
procedure WaitFor( ticks : integer ); -- wait, handling any input
pragma export( C, WaitFor, "wait_for" );
---> Text Output
--
procedure Draw( s : string );
procedure Draw( s : in string; fieldwidth : integer; elipsis:boolean := false );
procedure DrawEdit( s : in String; fieldwidth : integer; am:boolean );
procedure Draw( c : character );
procedure Draw( i : integer );
procedure Draw( l : long_integer );
procedure Draw( f : float );
procedure DrawLn;
pragma export( C, DrawLn, "draw_ln" );
-- Intended for C++ since Ada can't mangle names
procedure DrawCoord( r : ARect );
--- Error Output
--
-- Work the same as Draw commands, but automatically position themselves
-- on the screen and switch text style to normal for visibility.
procedure DrawErr( s : string ); -- write a string
procedure DrawErr( i : integer ); -- write an integer
procedure DrawErr( l : long_integer ); -- write a long integer
procedure DrawErr( i : AnInputRecord ); -- dump an input record
procedure DrawErrLn; -- move to next free error line
pragma export( C, DrawErrLn, "draw_errln" );
---> Basic Pen Drawing
--
-- Works with the assumption of 80x24 grid.
-- Line Drawing functions
procedure DrawLine( x1, y1, x2, y2 : in integer );
pragma export( CPP, DrawLine, "draw_line" );
procedure DrawHorizontalLine( x1, x2, y1 : in integer );
pragma export( CPP, DrawHorizontalLine, "draw_horizontal_line" );
procedure DrawVerticalLine( y1, y2, x1 : in integer );
pragma export( CPP, DrawVerticalLine, "draw_vertical_line" );
-- Rectangle Drawing functions
procedure FrameRect( r : in ARect );
pragma export( CPP, FrameRect, "frame_rect" );
procedure FrameRect3D( r : in ARect );
pragma export( CPP, FrameRect3D, "frame_rect_3d" );
procedure FramedRect( r : in ARect; ForeColour,BackColour:in APenColourName);
pragma export( CPP, FramedRect, "framed_rect" );
procedure FillRect( r : in ARect; Colour : in APenColourName );
pragma export( CPP, FillRect, "fill_rect" );
procedure PaintRect( r : in ARect );
pragma export( CPP, PaintRect, "paint_rect" );
procedure EraseRect( r : in ARect );
pragma export( CPP, EraseRect, "erase_rect" );
-- Circle/Oval drawing functions
procedure FrameOval( r : in ARect ) renames FrameRect;
procedure FramedOval( r : in ARect; ForeColour, BackColour : in APenColourName)
renames FramedRect;
procedure FillOval( r : ARect; Colour : in APenColourName ) renames FillRect;
procedure PaintOval( r : ARect ) renames PaintRect;
procedure EraseOval( r : ARect ) renames EraseRect;
---> Region Drawing functions
--
-- For some future day when you can draw to all windows.
subtype ARegion is RectList.Set; -- just a list of rectangles
-- Region Allocation
-- allocate
-- deallocate
procedure ClearRegion( region : in out ARegion ) renames RectList.Clear;
-- Defining Regions
procedure SetRectRegion( region : in out ARegion; rect : ARect );
-- Manipulating and Testing Regions
procedure OffsetRegion( region : in out ARegion; dx, dy : integer );
--procedure InsetRegion( region : in out ARegion );
procedure InRegion( x, y : integer; region : in out ARegion; result : out boolean );
procedure InRegion( r : ARect; region : in out ARegion; result : out boolean );
procedure InRegion( r, region : in out ARegion; result : out boolean );
procedure AddRect( region : in out ARegion; r : ARect ) renames
RectList.Insert;
procedure AddRegion( region, region2add : in out ARegion );
--procedure SubRegion( region, region2sub : in out ARegion );
-- procedure SetClipRegion( r : in out ARegion );
-- Not yet written.
---> Pictures
--
subtype APictureID is natural;
NoPictureID : constant APictureID := 0;
function RegisterPicture( path : string ) return APictureID;
--function CopyPicture( id : APictureID ) return APictureID;
--procedure ClearPicture( id : APictureID );
--procedure InsetPicture( id : APictureID, dx, dy : integer );
function SavePicture( path, title : in String; bounds : ARect )
return APictureID;
procedure DrawPicture( picture : APictureID; bounds : ARect );
procedure ScreenDump;
---> Caching/Spooling support
--
-- In part to support Curses' caching, and in part to allow clients in
-- a client/server scenario to optimize their drawing. On displays
-- that don't use caching, has no effect.
procedure WaitToReveal; -- enable spooling/caching
pragma export( C, WaitToReveal, "wait_to_reveal" );
procedure Reveal; -- spooling/caching complete
pragma export( C, Reveal, "reveal" );
procedure RevealNow; -- forced revealing, no effect on reveal nesting
pragma export( C, RevealNow, "reveal_now" );
private
pragma Inline( GetPenColour );
pragma Inline( SetTextStyle );
pragma Inline( GetTextStyle );
pragma Inline( MoveToGlobal );
end userio;
texttools/src/hash_case_insensitive.ads 0000664 0000764 0000764 00000000151 11774715706 017103 0 ustar ken ken with Ada.Containers;
function Hash_Case_Insensitive
(Key : String)
return Ada.Containers.Hash_Type;
texttools/src/common.ads 0000664 0000764 0000764 00000026232 11774715706 014045 0 ustar ken ken ------------------------------------------------------------------------------
-- COMMON --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Vectors;
with Ada.Containers.Ordered_Sets;
with Ada.Strings.Unbounded;
package Common is
--- Compile Flags
--
-- Differentiate between compiling the finder (ie. the server that first
-- runs and establishes the environment and contains routines to answer
-- all questions) from the normal applications running under it (ie. the
-- clients which must negotiate with the finder for control of the screen.
IsFinder : constant boolean := true; -- true if compiling for a server
pragma export( C, IsFinder, "is_finder" );
---> Basic Rectangles
--
-- Rectangles are used all over.
subtype Points is positive;
type ARect is record
left, top, right, bottom : integer;
end record;
nullRect : constant ARect := (0, 0, -1, -1);
pragma export( C, nullRect, "null_rect" );
procedure SetRect( r : out ARect; left, top, right, bottom : integer );
pragma export( C, SetRect, "set_rect" );
procedure OffsetRect( r : in out ARect; dx, dy : integer );
function OffsetRect( r : in ARect; dx, dy : integer ) return ARect;
pragma export( C, offsetRect, "offset_rect" );
procedure InsetRect( r : in out ARect; dx, dy : integer );
function InsetRect( r : in ARect; dx, dy : integer ) return ARect;
pragma export( C, insetRect, "inset_rect" );
function InsideRect( Inner, Outer : in ARect ) return boolean;
function InRect( x, y : integer; r : ARect ) return boolean;
function IsEmptyRect( r : ARect ) return boolean;
-- Lists of Bounded Strings
package StrList is new Ada.Containers.Indefinite_Vectors (Positive, String);
---> Lists of Booleans
package BooleanList is new Ada.Containers.Vectors (Positive, Boolean);
---> Lists of Rectangles
function RectOrder( left, right : ARect ) return boolean;
package RectList is new Ada.Containers.Ordered_Sets (ARect, Rectorder);
---> Various Pointer Types
--
-- These are listed for convenience.
type BooleanPtr is access all Boolean;
type IntegerPtr is access all Integer;
type Short_IntegerPtr is access all Short_Integer;
type Long_IntegerPtr is access all Long_Integer;
type FloatPtr is access all Float;
type RectPtr is access all ARect;
---> Error Handling
---
--- To get the best of all worlds, I'm providing the following vars/
--- procs. If RaiseErrors is used, all calls to Error will result
--- in a GeneralError being raised (the error code is in LastError).
--- If TrapErrors (default) is used, all calls to Error will save the
--- error code in LastError and return and it's up to the program to
--- check to see if an error occurred. If you need to save the error
--- handling method of the caller, save the value of RaisingErrors.
--- (I was going to create a stack, but that's slower and more work.
--- This is better when memory is low, and often the flag doesn't need
--- saving.) If your subprogram uses these routines, call NoError first
--- to clear any outstanding error codes.
---
--- Core Error Codes
---
--- Listed here for convenience and to ensure they are unique
---
--- Core System Errors
type AnErrorCode is new short_integer range -1..short_integer'last;
subtype ACoreErrorCode is AnErrorCode range -1..499;
subtype AnUserErrorCode is AnErrorCode range 500..AnErrorCode'last;
TT_NotYetWritten : constant ACoreErrorCode := -1; -- routine not yet written
TT_OK : constant ACoreErrorCode := 0; -- no error
TT_MemoryLeak : constant ACoreErrorCode := 10; -- memory not deallocated
TT_LowMemory : constant ACoreErrorCode := 11; -- low on memory
pragma export( C, TT_NotYetWritten, "TT_not_yet_written" );
pragma export( C, TT_OK, "TT_ok" );
pragma export( C, TT_MemoryLeak, "TT_memory_leak" );
pragma export( C, TT_LowMemory, "TT_low_memory" );
--- Core System and related
TT_SystemError : constant ACoreErrorCode := 100; -- command failed
TT_ParamError : constant ACoreErrorCode := 101; -- param too long
TT_FileExistance : constant ACoreErrorCode := 110; -- file found/not found
TT_PathExistance : constant ACoreErrorCode := 111; -- path found/not found
TT_VolExistance : constant ACoreErrorCode := 112; -- volume found/not found
TT_DevExistance : constant ACoreErrorCode := 113; -- device found/not found
TT_FileStatus : constant ACoreErrorCode := 114; -- open / not open
TT_FileLocking : constant ACoreErrorCode := 115; -- file is locked/unlocked
TT_FileAccess : constant ACoreErrorCode := 116; -- file is un/accessible
TT_VolLocking : constant ACoreErrorCode := 117; -- volume readonly or not
TT_VolAccess : constant ACoreErrorCode := 118; -- volume is un/accessible
TT_VolFull : constant ACoreErrorCode := 119; -- no space on disk
TT_DevSequential : constant ACoreErrorCode := 120; -- tape device
TT_IOError : constant ACoreErrorCode := 121; -- hardware or media error
TT_PathError : constant ACoreErrorCode := 122; -- bad path for file sys
TT_FileBounds : constant ACoreErrorCode := 123; -- position out of bounds
TT_OSOld : constant ACoreErrorCode := 130; -- UNIX too old
TT_OSService : constant ACoreErrorCode := 131; -- UNIX service missing
TT_Integrity : constant ACoreErrorCode := 140; -- integrity test failure
TT_TestData : constant ACoreErrorCode := 141; -- test data in operation
pragma export( C, TT_SystemError, "TT_system_error" );
pragma export( C, TT_ParamError, "TT_param_error" );
pragma export( C, TT_FileExistance, "TT_file_existance" );
pragma export( C, TT_PathExistance, "TT_path_existance" );
pragma export( C, TT_VolExistance, "TT_vol_existance" );
pragma export( C, TT_DevExistance, "TT_dev_existance" );
pragma export( C, TT_FileStatus, "TT_file_status" );
pragma export( C, TT_FileLocking, "TT_file_locking" );
pragma export( C, TT_FileAccess, "TT_file_access" );
pragma export( C, TT_VolLocking, "TT_vol_locking" );
pragma export( C, TT_VolAccess, "TT_vol_access" );
pragma export( C, TT_VolFull, "TT_vol_full" );
pragma export( C, TT_DevSequential, "TT_dev_sequential" );
pragma export( C, TT_IOError, "TT_io_error" );
pragma export( C, TT_PathError, "TT_path_error" );
pragma export( C, TT_FileBounds, "TT_file_bounds" );
pragma export( C, TT_OSOld, "TT_os_old" );
pragma export( C, TT_OSService, "TT_os_service" );
pragma export( C, TT_Integrity, "TT_integrity" );
pragma export( C, TT_TestData, "TT_test_data" );
---> Interpreter Errors
-- (not used)
TT_UnexpErr : constant ACoreErrorCode := 200; -- unexpected character
TT_ParanErr : constant ACoreErrorCode := 201; -- Bad paranthesis
TT_OperandErr : constant ACoreErrorCode := 202; -- missing operand
TT_SyntaxErr : constant ACoreErrorCode := 203; -- bad syntax
TT_TooCompErr : constant ACoreErrorCode := 204; -- formula too complex
TT_ClashErr : constant ACoreErrorCode := 205; -- type clash
TT_NotDeclErr : constant ACoreErrorCode := 206; -- ident not declared
TT_EOProgErr : constant ACoreErrorCode := 207; -- end of prog encountered
TT_QuoteErr : constant ACoreErrorCode := 208; -- bad quote marks
TT_DivZeroErr : constant ACoreErrorCode := 209; -- divide by zero
---> Core Userio Errors
---> Core Control Errors
---> Core Window Errors
TT_WindowExistance : constant ACoreErrorCode := 160; --window found/not
TT_NoControls : constant ACoreErrorCode := 161; --no controls in window
TT_ControlExistance: constant ACoreErrorCode := 162;
TT_NoDialogTaskCB : constant ACoreErrorCode := 163; --no manual handler
pragma export( C, TT_WIndowExistance, "TT_window_existance" );
pragma export( C, TT_NoControls, "TT_no_controls" );
pragma export( C, TT_ControlExistance, "TT_control_existance" );
pragma export( C, TT_NoDialogTaskCB, "TT_no_dialog_task_cb" );
---> Error Variables/Functions
GeneralError : exception; -- exception raised by Error();
LastError : AnErrorCode; -- last Error error code
RaisingErrors : boolean; -- TRUE if GeneralError will be raised
procedure NoError; -- clear LastError
pragma Inline( NoError );
pragma Export( C, NoError, "no_error" );
procedure Error( ErrorCode : AnErrorCode ); -- log an error
pragma Inline( Error );
pragma Export( C, Error, "error" );
procedure RaiseErrors; -- cause Error to raise a GeneralError
pragma Inline( RaiseErrors );
procedure TrapErrors; -- cause Error to return normally
pragma Inline( TrapErrors );
function RaiseErrors return boolean;
function TrapErrors return boolean;
procedure RestoreRaising( oldflag : boolean );
pragma Inline( RestoreRaising );
--- Housekeeping
--
ProgramName : Ada.Strings.Unbounded.Unbounded_String;
ShortProgramName : Ada.Strings.Unbounded.Unbounded_String;
-- Short program name is used for $SYS directory in os package.
-- and (when I get to it) temp file name prefix.
procedure StartupCommon( theProgramName, theShortProgramName : string );
procedure IdleCommon( IdlePeriod : in Duration );
procedure ShutdownCommon;
pragma export( C, ShutdownCommon, "shutdown_common" );
end Common;
texttools/src/curses.c 0000664 0000764 0000764 00000052232 11774715706 013533 0 ustar ken ken /****************************************************
* *
* Ada-to-C interface for Curses library *
* *
* Compile: gcc -O -c curses.c *
* Bind: include C_code/curses.o -lcurses *
* *
****************************************************/
/* Mouse support incomplete: mouse causes character gets to be non-
blocking...was going to try GetEvent, but since GPM is GNU,
there was no point */
/* Configuration ---------------------------------------------- */
/* #define NCURSES3 */ /* define for NCURSES 3.x */
#define NCURSES5 /* define for NCURSES 5.x */
#define NCURSES /* define for Linux NCURSES library */
/* curses is freeware */
/* #define GPM */ /* define for Linux GPM library */
/* unfortunately GPM is under GNU licence */
/* Includes ----------------------------------------------------*/
#include /* first 3 just to get O_WRONLY */
#include
#include
#include
#ifdef GPM
#include
#endif
#ifdef NCURSES
/* #include */
/* #include */
#include
#include
#else
#include
#endif
#include
extern char Interface_String[255];
/* Curses Globals ------------------------------------------------- */
int colour_flag; /* true if has_colours() is true, shared with Ada */
int lines, cols; /* screen dimensions, shared with Ada */
chtype chline[181]; /* line of characters -- shouldn't be more than 133 */
char sline[181];
/* Mouse Globals -------------------------------------------------- */
#ifdef GPM
Gpm_Connect conn; /* General Purpose Mouse Connection */
int mouse_fid; /* File ID for the mouse */
#endif
MEVENT mousedata; /* ncurses mouse data */
int C_mousex; /* mouse x coordinate, shared with Ada */
int C_mousey; /* mouse y coordinate, shared with Ada */
int C_hasmouse; /* 1 = mouse is running, shared with Ada */
/* for GPM */
int C_mousebutton; /* 1 = mouse button down, shared with Ada */
/* Ada will set to -1 when handled */
/* Mouse Handler - GPM Prototype */
#ifdef GPM
int MouseHandler(Gpm_Event * event, void *data);
#endif
void CMoveTo( x, y )
int x, y;
{
move( y, x );
}
char CGetChar( x, y )
int x, y;
{
return mvinch( y, x );
}
long CGetXY()
{ int x, y;
getyx( stdscr, y, x );
return y*256+x;
}
void CTextStyle( char bold, char so, char under )
{
#ifdef NCURSES3
int current;
#else
attr_t current = 0;
short temp = 0;
#endif
/* current attributes - and out important bits */
int total; /* total for attron command */
int offtotal; /* total for attroff command */
/* NCURSES isn't smart enough to use the following code. eg. it
doesn't handle terminals that toggle bold, standout or underline.
So we'll have to check the values ourselves, and triple the
length of this simple subroutine!!
total=0;
if (bold == 'y') total |= A_BOLD;
if (so == 'y') total |= A_STANDOUT;
if (under == 'y') total |= A_UNDERLINE;
attroff( A_BOLD | A_UNDERLINE | A_STANDOUT );
attron( total );
*/
total=0; /* clear the totals */
offtotal=0;
/* get current attributes */
#ifdef NCURSES3
/* Old ncurses format */
current=attr_get();
#else
#ifdef NCURSES5
/* ncurses 5 will hang with attr_get: need wattr_get */
wattr_get( stdscr, ¤t, &temp, NULL );
#else
/* Normal ncurses */
attr_get( ¤t, &temp, NULL );
#endif
#endif
if (bold == 'y') {
if (( current & A_BOLD )==0) {
total |= A_BOLD;
}
}
if (bold == 'n') {
if (( current & A_BOLD )>=1) {
offtotal |= A_BOLD;
}
}
if (so == 'y') {
if (( current & A_STANDOUT )==0) {
total |= A_STANDOUT;
}
}
if (so == 'n') {
if (( current & A_STANDOUT )>=1) {
offtotal |= A_STANDOUT;
}
}
if (under == 'y') {
if (( current && A_UNDERLINE )==0) {
total |= A_UNDERLINE;
}
}
if (under == 'n') {
if (( current & A_UNDERLINE )>=1) {
offtotal |= A_UNDERLINE;
}
}
attroff( offtotal ); /* turn off anything that needs to be off */
attron( total ); /* turn on active attributes */
}
void DrawChar( ch )
char ch;
{
echochar( (chtype)ch ); /* echo character and redraw */
}
char CGetKey () /* Get a Keypress or wait for one */
{
chtype c; /* to hold the keypress */
cbreak();
/* no keyboard buffering; nonl() implied */
noecho(); /* don't echo to the screen */
intrflush(stdscr, FALSE); /* no fancy keyboard flushing */
keypad(stdscr, TRUE); /* return special function keys */
#ifdef GPM
if (C_hasmouse) {
c = Gpm_Getch();
} else {
c = getch(); /* get a keypress */
}
#else
c = getch(); /* get a keypress */
#endif
/* Can't recover this way */
/* echo(); */ /* in case of problems */
/* nocbreak(); */
/* nonl(); */
/* translate special keys into 7-bit ASCII chars */
if ( KEY_BACKSPACE != KEY_LEFT ) { /* we've gotta be able to move left! */
if ( (char)c == (char)8 ) /* then equate ASCII backspace */
c = (chtype) 127; /* with delete! */
if ( c == KEY_BACKSPACE ) c = (chtype) 127; /* ditto */
}
/* --- ncurses mouse support -- */
if ( c == KEY_MOUSE ) { /* mouse event? */
if ( getmouse( &mousedata )==OK ) { /* then get the info */
C_mousex = mousedata.x; /* save mouse location */
C_mousey = mousedata.y;
if ( mousedata.bstate == BUTTON2_CLICKED ) /* treat buttons 2,3,4 */
c = (chtype) 27; /* as ESC key for */
if ( mousedata.bstate == BUTTON3_CLICKED ) /* accessories menu */
c = (chtype) 27;
if ( mousedata.bstate == BUTTON4_CLICKED )
c = (chtype) 27;
if ( mousedata.bstate == REPORT_MOUSE_POSITION ) /* movement */
c = (chtype) 254; /* character 254 */
if ( mousedata.bstate == BUTTON1_CLICKED ) /* note button 1 as */
c = (chtype) 255; /* character 255 */
}
}
/* --- end of mouse handling --- */
if ( c == KEY_UP ) c = (chtype) 11; /* up arrow = vertical tab */
if ( c == KEY_DOWN ) c = (chtype) 10; /* down arrow = line feed */
if ( c == KEY_LEFT ) c = (chtype) 8; /* left arrow = backspace */
if ( c == KEY_RIGHT ) c = (chtype) 21; /* right arrow = forespace */
if ( c == KEY_HOME ) c = (chtype) 25; /* home key = ctrl-y */
if ( c == KEY_BEG ) c = (chtype) 25; /* beginning key = "home" */
if ( c == KEY_PPAGE ) c = (chtype) 16; /* page up = ctrl-p */
if ( c == KEY_NPAGE ) c = (chtype) 14; /* page down = ctrl-n */
if ( c == KEY_END ) c = (chtype) 5; /* end key = ctrl-e 2 */
if ( c == KEY_HELP ) c = (chtype) 27; /* help = ESC key */
if ( c == KEY_OPTIONS ) c = (chtype) 27; /* options = "help" (for now) */
if ( c == KEY_BTAB ) c = (chtype) 20; /* back tab = ctrl-t */
if ( c == KEY_NEXT ) c = (chtype) 9; /* next object = tab */
if ( c == KEY_PREVIOUS ) c = (chtype) 20; /* previous object = backtab */
if ( c == KEY_COPY ) c = (chtype) 2; /* copy = ctrl-b (for now) */
if ( c == KEY_REPLACE ) c = (chtype) 22; /* paste = ctrl-v */
return (char) c;
}
char CKeyDelay () /* Get a Keypress, or return null if none */
/* Wait up to 1/10th second. */
{
chtype c; /* to hold the keypress */
halfdelay(1); /* wait 1/10th sec before giving up */
noecho(); /* don't echo to the screen */
nonl(); /* don't translate return into newline */
intrflush(stdscr, FALSE); /* no fancy keyboard flushing */
keypad(stdscr, TRUE); /* return special function keys */
#ifdef GPM
if (C_hasmouse) {
c = Gpm_Getch();
} else {
c = getch(); /* get a keypress */
}
#else
c = getch(); /* get a keypress */
#endif
/* Can't recover this way */
/* echo(); */ /* in case of problems */
/* nocbreak(); */
/* nonl(); */
/* translate special keys into ASCII chars */
if ( c == (chtype)ERR ) c = (chtype) 0; /* no key = ASCII null */
if ( (char)c == (char)8 ) c = (chtype) 127; /* backspace = delete! */
if ( c == KEY_BACKSPACE ) c = (chtype) 127; /* ditto */
/* --- ncurses mouse support -- */
if ( c == KEY_MOUSE ) { /* mouse event? */
if ( getmouse( &mousedata )==OK ) { /* then get the info */
C_mousex = mousedata.x; /* save mouse location */
C_mousey = mousedata.y;
if ( mousedata.bstate == BUTTON2_CLICKED ) /* treat buttons 2,3,4 */
c = (chtype) 27; /* as ESC key for */
if ( mousedata.bstate == BUTTON3_CLICKED ) /* accessories menu */
c = (chtype) 27;
if ( mousedata.bstate == BUTTON4_CLICKED )
c = (chtype) 27;
if ( mousedata.bstate == BUTTON1_CLICKED ) /* note button 1 as */
c = (chtype) 255; /* character 255 */
}
}
/* --- end of mouse handling --- */
if ( c == KEY_UP ) c = (chtype) 11; /* up arrow = vertical tab */
if ( c == KEY_DOWN ) c = (chtype) 10; /* down arrow = line feed */
if ( c == KEY_LEFT ) c = (chtype) 8; /* left arrow = backspace */
if ( c == KEY_RIGHT ) c = (chtype) 21; /* right arrow = forespace */
if ( c == KEY_HOME ) c = (chtype) 25; /* home key = ctrl-y */
if ( c == KEY_BEG ) c = (chtype) 25; /* beginning key = "home" */
if ( c == KEY_PPAGE ) c = (chtype) 16; /* page up = ctrl-p */
if ( c == KEY_NPAGE ) c = (chtype) 14; /* page down = ctrl-n */
if ( c == KEY_END ) c = (chtype) 5; /* end key = ctrl-e 2 */
if ( c == KEY_HELP ) c = (chtype) 27; /* help = ESC key */
if ( c == KEY_OPTIONS ) c = (chtype) 27; /* options = "help" (for now) */
if ( c == KEY_BTAB ) c = (chtype) 20; /* back tab = ctrl-t */
if ( c == KEY_NEXT ) c = (chtype) 9; /* next object = tab */
if ( c == KEY_PREVIOUS ) c = (chtype) 20; /* previous object = backtab */
if ( c == KEY_COPY ) c = (chtype) 2; /* copy = ctrl-b (for now) */
if ( c == KEY_REPLACE ) c = (chtype) 22; /* paste = ctrl-v */
return (char) c;
}
char CKeypress () /* Get a Keypress, or return null if none */
{
chtype c; /* to hold the keypress */
cbreak();
nodelay(stdscr,TRUE); /* don't wait before giving up */
noecho(); /* don't echo to the screen */
nonl(); /* don't translate return into newline */
intrflush(stdscr, FALSE); /* no fancy keyboard flushing */
keypad(stdscr, TRUE); /* return special function keys */
#ifdef GPM
if (C_hasmouse) {
c = Gpm_Getch();
} else {
c = getch(); /* get a keypress */
}
#else
c = getch(); /* get a keypress */
#endif
/* Can't recover via nocbreak mode */
/* echo(); */ /* in case of problems */
nodelay(stdscr,FALSE); /* back to normal */
/* nocbreak(); */
/* nonl(); */
/* translate special keys into ASCII chars */
if ( c == (chtype)ERR ) c = (chtype) 0; /* no key = ASCII null */
if ( (char)c == (char)8 ) c = (chtype) 127; /* backspace = delete! */
if ( c == KEY_BACKSPACE ) c = (chtype) 127; /* ditto */
/* --- ncurses mouse support -- */
if ( c == KEY_MOUSE ) { /* mouse event? */
if ( getmouse( &mousedata )==OK ) { /* then get the info */
C_mousex = mousedata.x; /* save mouse location */
C_mousey = mousedata.y;
if ( mousedata.bstate == BUTTON2_CLICKED ) /* treat buttons 2,3,4 */
c = (chtype) 27; /* as ESC key for */
if ( mousedata.bstate == BUTTON3_CLICKED ) /* accessories menu */
c = (chtype) 27;
if ( mousedata.bstate == BUTTON4_CLICKED )
c = (chtype) 27;
if ( mousedata.bstate == BUTTON1_CLICKED ) /* note button 1 as */
c = (chtype) 255; /* character 255 */
}
}
/* --- end of mouse handling --- */
if ( c == KEY_UP ) c = (chtype) 11; /* up arrow = vertical tab */
if ( c == KEY_DOWN ) c = (chtype) 10; /* down arrow = line feed */
if ( c == KEY_LEFT ) c = (chtype) 8; /* left arrow = backspace */
if ( c == KEY_RIGHT ) c = (chtype) 21; /* right arrow = forespace */
if ( c == KEY_HOME ) c = (chtype) 25; /* home key = ctrl-y */
if ( c == KEY_BEG ) c = (chtype) 25; /* beginning key = "home" */
if ( c == KEY_PPAGE ) c = (chtype) 16; /* page up = ctrl-p */
if ( c == KEY_NPAGE ) c = (chtype) 14; /* page down = ctrl-n */
if ( c == KEY_END ) c = (chtype) 5; /* end key = ctrl-e 2 */
if ( c == KEY_HELP ) c = (chtype) 27; /* help = ESC key */
if ( c == KEY_OPTIONS ) c = (chtype) 27; /* options = "help" (for now) */
if ( c == KEY_BTAB ) c = (chtype) 20; /* back tab = ctrl-t */
if ( c == KEY_NEXT ) c = (chtype) 9; /* next object = tab */
if ( c == KEY_PREVIOUS ) c = (chtype) 20; /* previous object = backtab */
if ( c == KEY_COPY ) c = (chtype) 2; /* copy = ctrl-b (for now) */
if ( c == KEY_REPLACE ) c = (chtype) 22; /* paste = ctrl-v */
return (char) c;
}
void FlushKeys()
{
flushinp();
}
void CSpoolRect( left, top, right, bottom, ch )
int left, top, right, bottom;
char ch;
{
int x, y;
for( x=0; x<=right-left; x++) sline[x] = ch;
sline[right-left+1] = '\0';
for ( y=top; y<=bottom; y++) {
mvaddstr( y, left, sline );
}
}
void CANSIColour ( int colour ) {
if (has_colors() ) {
if (colour<0) attron( COLOR_PAIR( 8 ) );
if (colour==0) attron( COLOR_PAIR( 1 ) );
if (colour==1) attron( COLOR_PAIR( 2 ) );
if (colour==2) attron( COLOR_PAIR( 3 ) );
if (colour==3) attron( COLOR_PAIR( 4 ) ); /* yellow */
if (colour==4) attron( COLOR_PAIR( 5 ) );
if (colour==5) attron( COLOR_PAIR( 6 ) );
if (colour==6) attron( COLOR_PAIR( 7 ) );
if (colour==7) attron( COLOR_PAIR( 8 ) );
if (colour==8) attron( COLOR_PAIR( 9 ) );
if (colour==9) attron( COLOR_PAIR( 10 ) );
if (colour==10) attron( COLOR_PAIR( 11 ) );
if (colour==11) attron( COLOR_PAIR( 12 ) ); /* therm back */
if (colour==12) attron( COLOR_PAIR( 13 ) ); /* scroll bar back */
if (colour>12) attron( COLOR_PAIR( 7 ) );
}
/*
if (colour==100) printf( "40m" );
if (colour==101) printf( "41m" );
if (colour==102) printf( "42m" );
if (colour==103) printf( "43m" );
if (colour==104) printf( "44m" );
if (colour==105) printf( "45m" );
if (colour==106) printf( "46m" );
if (colour==107) printf( "47m" );
*/
/*
if (colour==-1) printf( "\033[0;37;40m" );
printf( "\033[" );
if (colour<100) printf( "40;" );
if (colour==0) printf( "30m" );
if (colour==1) printf( "31m" );
if (colour==2) printf( "32m" );
if (colour==3) printf( "33m" );
if (colour==4) printf( "34m" );
if (colour==5) printf( "35m" );
if (colour==6) printf( "36m" );
if (colour==7) printf( "37m" );
if (colour>=100) printf( "37;" );
if (colour==100) printf( "40m" );
if (colour==101) printf( "41m" );
if (colour==102) printf( "42m" );
if (colour==103) printf( "43m" );
if (colour==104) printf( "44m" );
if (colour==105) printf( "45m" );
if (colour==106) printf( "46m" );
if (colour==107) printf( "47m" );
*/
}
void Cls()
{
move( 0, 0 );
clrtobot();
refresh();
if (colour_flag) {
CANSIColour( 0 );
CSpoolRect( 0, 0, cols-1, lines-1, ' ' );
}
}
void Refresh ()
{
refresh(); /* redraw the screen */
}
void ShutdownCurses ()
{
#ifdef GPM
Gpm_Close();
C_hasmouse = 0;
#endif
endwin(); /* shutdown curses */
}
void SpoolChar( char ch )
{
if ( ch == (char) 9 ) { /* change tabs to spaces */
ch=' ';
}
if ( ch < ' ' ) { /* change control chars to ? */
ch='?';
}
addch( (chtype) ch ); /* character will be drawn at next refresh */
}
void CDesktop( int maxx, int maxy ) {
int x, y;
if (has_colors()) attron( COLOR_PAIR( 14 ) );
for (x=0; x<=maxx; x++) {
chline[x]=ACS_CKBOARD;
}
for (y=0; y<=maxy; y++) mvaddchstr( y, 0, chline );
}
void CBeep() {
beep(); /* beep terminal */
}
void SpoolSpecial( val )
int val;
{
if (val==0) addch( ACS_ULCORNER );
if (val==1) addch( ACS_LLCORNER );
if (val==2) addch( ACS_URCORNER );
if (val==3) addch( ACS_LRCORNER );
if (val==4) addch( ACS_HLINE );
if (val==5) addch( ACS_VLINE );
}
void ResetCurses() {
/* redrawwin( stdscr ); doesnt seem to work */
/* endwin();
initscr(); */
/* if the window has been resized, this can cause problems */
clearok( curscr, TRUE );
}
void SetColour( int cmode ) {
/* set background colour to blue or black */
colour_flag = 0;
if (has_colors()) {
colour_flag = 1;
start_color(); /* start colour support */
if (cmode==0) { /* blue background */
init_pair( 1, COLOR_BLACK, COLOR_BLUE );
init_pair( 2, COLOR_RED, COLOR_BLUE );
init_pair( 3, COLOR_GREEN, COLOR_BLUE );
init_pair( 4, COLOR_YELLOW, COLOR_BLUE );
init_pair( 5, COLOR_BLUE, COLOR_BLUE );
init_pair( 6, COLOR_MAGENTA, COLOR_BLUE );
init_pair( 7, COLOR_CYAN, COLOR_BLUE );
init_pair( 8, COLOR_WHITE, COLOR_BLUE );
init_pair( 9, COLOR_WHITE, COLOR_BLACK ); /* input */
init_pair( 10, COLOR_YELLOW, COLOR_RED ); /* thermometer */
init_pair( 11, COLOR_YELLOW, COLOR_RED ); /* scroll bar */
init_pair( 12, COLOR_RED, COLOR_YELLOW ); /* thermometer back */
init_pair( 13, COLOR_RED, COLOR_WHITE ); /* scroll bar back */
init_pair( 14, COLOR_BLUE, COLOR_BLACK ); /* desktop back */
} else { /* black background */
start_color(); /* start colour support */
init_pair( 1, COLOR_BLACK, COLOR_BLACK );
init_pair( 2, COLOR_RED, COLOR_BLACK );
init_pair( 3, COLOR_GREEN, COLOR_BLACK );
init_pair( 4, COLOR_YELLOW, COLOR_BLACK );
init_pair( 5, COLOR_BLUE, COLOR_BLACK );
init_pair( 6, COLOR_MAGENTA, COLOR_BLACK );
init_pair( 7, COLOR_CYAN, COLOR_BLACK );
init_pair( 8, COLOR_WHITE, COLOR_BLACK );
init_pair( 9, COLOR_WHITE, COLOR_BLUE ); /* input */
init_pair( 10, COLOR_YELLOW, COLOR_RED ); /* thermometer */
init_pair( 11, COLOR_YELLOW, COLOR_RED ); /* scroll bar */
init_pair( 12, COLOR_RED, COLOR_YELLOW ); /* thermometer back */
init_pair( 13, COLOR_RED, COLOR_WHITE ); /* scroll bar back */
init_pair( 14, COLOR_BLUE, COLOR_BLACK ); /* desktop back */
}
}
}
void StartupCurses()
{
extern int colour_flag;
extern int lines;
extern int cols;
initscr(); /* startup curses */
if ( strcmp( NCURSES_VERSION, "4.0" ) < 0 ) {
printf( "This versionr requires ncurses 4.0 or greater\n" );
}
SetColour( 0 );
lines=LINES; /* number of lines */
cols=COLS; /* number of columns */
/* Normally, Return counts as a NewLine (LF+CR) */
/* If I leave things as normal, CR's when not waiting for input */
/* become LF's! I would like to leave things in normal curses' */
/* mode in case of a crash, but I can't with this! */
cbreak(); /* curses doesn't set mode at startup...we'll take cbreak */
/* nonl() is irrelivant is cbreak mode */
flushinp(); /* throw away any waiting characters */
refresh();
C_hasmouse = 0;
/* --- ncurses mouse support --- */
C_hasmouse = ( mousemask( REPORT_MOUSE_POSITION |
BUTTON1_CLICKED |
BUTTON2_CLICKED |
BUTTON3_CLICKED |
BUTTON4_CLICKED, 0 )==0 ) ? 0 : 1;
/* --- end of ncurses mouse support */
/* --- GPM mouse support not finished */
#ifdef GPM
conn.eventMask = ~0;
conn.defaultMask = GMP_MOVE | GPM_HARD;
conn.maxMod = ~0;
conn.minMod = 0;
if ( (mouse_fid = Gpm_Open(&conn, 0)) == -1) {
/* attrset(COLOR_PAIR(TITLE_COLOR) | A_BOLD | A_ALTCHARSET);
move(0, 35);
addstr("mouse off");
*/
refresh();
} else {
C_hasmouse = 1;
gpm_handler = MouseHandler;
}
#endif
}
/* Mouse Handler -------------------------------------------------- */
/* */
/* Set the global variables: */
/* int C_mousebutton; --1 = mouse button down, shared with Ada */
/* int C_mousex; --mouse x coordinate, shared with Ada */
/* int C_mousey; --mouse y coordinate, shared with Ada */
/* ---------------------------------------------------------------- */
#ifdef GPM
int MouseHandler(Gpm_Event * event, void *data) {
if (event->type & GPM_DOWN) {
C_mousebutton = 1;
C_mousex = event->x;
C_mousey = event->y;
} else if (event->type & GPM_UP) {
C_mousebutton = 0;
C_mousex = event->x;
C_mousey = event->y;
}
return 0;
}
#endif /* end of GPM stuff */
texttools/src/windows.adb 0000664 0000764 0000764 00000372670 11774715706 014240 0 ustar ken ken ------------------------------------------------------------------------------
-- WINDOWS (package body) --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
-- Had to hard code dispatching in Open/Save dialogs under Gnat 3.05-why?
with unchecked_deallocation;
with system.address_to_access_conversions;
with Ada.Text_Io.Unbounded_IO; use Ada.text_io;
with strings; use strings;
with English; use English;
with Ada.Directories;
with Ada.IO_Exceptions;
with Ada.Containers;
with Ada.Calendar.Formatting;
with Ada.Strings.Fixed;
package body windows is
PackageRunning : boolean := false;
type AStdioFileID is new System.Address;
-- a C standard IO (stdio) file id
function popen( command, mode : string ) return AStdioFileID;
pragma import( C, popen, "popen" );
-- opens a pipe to command
procedure pclose( result : out integer; fid : AStdioFileID );
pragma import( C, pclose, "pclose" );
pragma import_valued_procedure( pclose );
-- closes a pipe
function fputc( c : integer; fid : AStdioFileID ) return integer;
pragma import( C, fputc, "fputc" );
-- part of standard C library. Writes one charctera to a file.
function fputs( s : string; fid : AStdioFileID ) return integer;
pragma import( C, fputs, "fputs" );
-- part of standard C library. Writes a string to a file.
type ADirectoryEntry is array(1..256) of Character;
package de_conv is new system.address_to_access_conversions(
aDirectoryEntry );
use de_conv;
procedure CDesktop( maxx, maxy : integer );
pragma import( C, CDesktop, "CDesktop" );
-- Simple Clipboard for cut/paste of values between controls
type DataTypes is (ListData, StringData, IntegerData, BooleanData);
type ClipboardRec( DataType : DataTypes ) is record
case DataType is
when ListData => l : StrList.vector;
when StringData => s : Unbounded_String;
when IntegerData => i : integer;
--when BooleanData => b : boolean;
--gnat 2.00 gave me a constraint error after saving a false boolean
--saving boolean as integer instead.
when BooleanData => b : integer;
end case;
end record;
type ClipboardType is access ClipboardRec;
Clipboard : ClipboardType := null;
-- Utilities
procedure GetDirectory (L : in out StrList.vector;
Path : in String) is
-- load the specified directory listing into the given list
use Ada.Directories;
procedure Process (Directory_Entry : in Directory_Entry_Type);
procedure Process (Directory_Entry : in Directory_Entry_Type) is
File : constant String := Simple_name (Directory_Entry);
begin
if Kind (Directory_Entry) = Directory then
L.Append (File & "/");
else
L.Append (File);
end if;
end Process;
package Sorting is new Strlist.Generic_Sorting;
begin
Search (Path, "", Process => Process'Access);
Sorting.Sort (L);
exception
when Ada.IO_Exceptions.Name_Error | Ada.IO_Exceptions.Use_Error =>
Sessionlog ("getdirectory: error opening directory '"
& path & "' - no such file or directory" );
end GetDirectory;
-- Shared Controls
--
-- To make the standard dialogs work in low memory situations, and to
-- get around some limitations to 'access, we allocate some basic controls
-- at startup to be shared amongst the standard dialogs.
type ASharedControlsRecord is record
button1 : AControlPtr;
button2 : AControlPtr;
button3 : AControlPtr;
text : AControlptr;
-- others for Save/Open dialogs later
end record;
Shared : ASharedControlsRecord; -- the shared controls
procedure SharedButton( sc : AControlPtr; x1, y1, x2, y2 : integer;
HotKey : character; text : string ) is
-- initialized a button shared amongst the standard dialogs
begin
if sc = null then
SessionLog( "SharedButton: the pointer is null. Package not started?" );
end if;
Finalize( ASimpleButton( sc.all ) );
Init( ASimpleButton( sc.all ), x1, y1, x2, y2, HotKey );
SetText( ASimpleButton( sc.all ), text );
AddControl( sc, IsGlobal => false );
end SharedButton;
procedure SharedLine( sc : AControlPtr; x1, y1, x2, y2 : integer;
text : string ) is
-- initialized a static line shared amongst the standard dialogs
begin
if sc = null then
SessionLog( "SharedLine: the pointer is null. Package not started?" );
end if;
Finalize( AStaticLine( sc.all ) );
Init( AStaticLine( sc.all ), x1, y1, x2, y2 );
SetText( AStaticLine( sc.all ), text );
--SetStyle( AStaticLine( sc.all ), Normal );
AddControl( sc, IsGlobal => false );
end SharedLine;
-- These should be replaced, not renamed
ChimeSkipMinutes : Ada.Calendar.Formatting.Minute_Number := 0;
-- last minutes chime rang (set in DoDialog)
-- Display Info
DisplayInfo : ADisplayInfoRec;
procedure Free is new Unchecked_Deallocation(
Object => ClipboardRec,
Name => ClipboardType );
-- Note Pad
NotePadData : StrList.Vector;
procedure AppendNotepad (S : in StrList.Vector) is
begin
NotePadData := S;
end AppendNotepad;
-- General Window I/O
--
-- Pen motion
procedure MoveTo( x, y : integer ) is
-- move the pen to a new position in the current window. The pen will
-- not move if the position is outside of the current window. Use
-- absolute coordinates.
newx, newy : integer;
begin
newx := Window( CurrentWindow ).content.left -1 + x;
newy := Window( CurrentWindow ).content.top - 1 + y;
if InRect( newx, newy, Window( CurrentWindow ).content ) then
MoveToGlobal( newx, newy );
end if;
exception when others =>
DrawErrLn;
DrawErr( "MoveTo RT exception" );
raise;
end MoveTo;
procedure Move( dx, dy : integer ) is
-- move the pen to a new position in the current window. The pen will
-- not move if the position is outside of the current window. Use
-- relative coordinates.
x, y : integer;
begin
GetPenPos( x, y );
x := x + dx;
y := y + dy;
if InRect( x, y, Window( CurrentWindow ).content ) then
MoveToGlobal( x, y );
end if;
exception when others =>
DrawErrLn;
DrawErr( "Move RT exception" );
raise;
end Move;
-- Coordinate Conversion
procedure ToGlobal( r : in out ARect ) is
-- convert a rectangle with coordinates local to a window to global
-- screen coordinates
begin
OffsetRect( r, Window( CurrentWindow ).content.left - 1,
Window( CurrentWindow ).content.top - 1 );
end ToGlobal;
procedure ToGlobal( x, y : in out integer ) is
-- convert a point with coordinates local to a window to global
-- screen coordinates
begin
x := x + Window( CurrentWindow ).content.left - 1;
y := y + Window( CurrentWindow ).content.right - 1;
end ToGlobal;
procedure ToLocal( r : in out ARect ) is
-- convert a rectangle with global screen coordinates to coordinates
-- local to the current window
begin
OffsetRect( r, - (Window( CurrentWindow ).content.left - 1),
- (Window( CurrentWindow ).content.top - 1) );
end ToLocal;
procedure ToLocal( x, y : in out integer ) is
-- convert a point with global screen coordinates to coordinates
-- local to the current window
begin
x := x - (Window( CurrentWindow ).content.left - 1);
y := y - (Window( CurrentWindow ).content.top - 1);
end ToLocal;
-- General Window I/O
procedure print is
begin
DrawLn;
RevealNow;
end print;
procedure print( s : string ) is
begin
Draw( s );
RevealNow;
end print;
procedure print( i : integer ) is
begin
Draw( i );
RevealNow;
end print;
procedure print( l : long_integer ) is
begin
Draw( l );
RevealNow;
end print;
-- Window Info Bars
procedure DrawInfo( id : AWindowNumber ) is
-- Draw a window's info bar (if any)
win : AWindow renames Window( id );
InfoBar : ARect renames Window( id ).InfoBar;
begin
if win.HasInfoBar then
SetTextStyle( Status );
SetPenColour( White );
MoveToGlobal( InfoBar.left, InfoBar.top );
Draw( To_String (Win.InfoText), InfoBar.right - InfoBar.left + 1, true );
end if;
exception when others =>
DrawErrLn;
DrawErr( "DrawInfo RT exception" );
raise;
end DrawInfo;
procedure DrawInfo is
-- short-cut for current window
begin
DrawInfo( CurrentWindow );
end DrawInfo;
procedure SetInfoText( text : in string ) is
-- change text in the info bar and redraw
cw : AWindow renames Window( CurrentWindow );
begin
if cw.HasInfoBar then
cw.InfoText := To_Unbounded_String (Text);
DrawInfo;
end if;
exception when others =>
DrawErrLn;
DrawErr( "SetInfoText RT exception" );
raise;
end SetInfoText;
-- Window timeouts
procedure SetWindowTimeout( c : AControlNumber; t : in Duration ) is
begin
Window( CurrentWindow ).TimeoutControl := c;
Window( CurrentWindow ).Timeout := t;
end SetWindowTimeout;
-- Window titles
procedure SetWindowTitle( title : in string) is
begin
Window( CurrentWindow ).title := To_Unbounded_String (Title);
DrawWindow;
end SetWindowTitle;
-- Window Inquiries
function GetWindowTitle( id : AWindowNumber ) return string is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return "";
end if;
NoError;
return To_String (Window( id ).Title);
end GetWindowTitle;
function GetWindowStyle( id : AWindowNumber ) return AWindowStyle is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return Normal;
end if;
NoError;
return Window( id ).style;
end GetWindowStyle;
function GetWindowCallBack( id : AWindowNumber ) return
AWindowDrawingCallBack is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return null;
end if;
NoError;
return Window( id ).DrawCB;
end GetWindowCallBack;
function GetWindowHasFrame( id : AWindowNumber ) return boolean is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return False;
end if;
NoError;
return Window( id ).HasFrame;
end GetWindowHasFrame;
function GetWindowFrame( id : AWindowNumber ) return ARect is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return Nullrect;
end if;
NoError;
return Window( id ).Frame;
end GetWindowFrame;
function GetWindowFrameColour( id : AWindowNumber ) return APenColourName is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return White;
end if;
NoError;
return Window( id ).FrameColour;
end GetWindowFrameColour;
function GetWindowContent( id : AWindowNumber ) return ARect is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return nullrect;
end if;
NoError;
return Window( id ).Content;
end GetWindowContent;
function GetWindowHasInfoBar( id : AWindowNumber ) return boolean is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return False;
end if;
NoError;
return Window( id ).HasInfoBar;
end GetWindowHasInfoBar;
function GetWindowInfoText( id : AWindowNumber ) return String is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return "";
end if;
NoError;
return To_String (Window( id ).InfoText);
end GetWindowInfoText;
function GetWindowXScroll( id : AWindowNumber ) return integer is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return 0;
end if;
NoError;
return Window( id ).XScroll;
end GetWindowXScroll;
function GetWindowYScroll( id : AWindowNumber ) return integer is
begin
if Id not in Window'First .. Nextwindow - 1 then
Error( TT_WindowExistance );
return 0;
end if;
NoError;
return Window( id ).YScroll;
end GetWindowYScroll;
-- Window Controls
procedure InitControlTable( ct : in out AControlTable ) is
-- reset counters in a control table. Does not deallocate existing
-- controls.
begin
ct.current := 0; -- initial selection is none
ct.size := 0; -- initial size is 0
end InitControlTable;
procedure AddControl( ptr : AControlPtr; -- pointer to the control
IsGlobal : boolean := true ; -- true if control in global coords.
Control : boolean := true ) is -- false if pgm wants to handle hits
-- add a control entry to the table
-- ct : AControlTable renames Window( CurrentWindow ).table;
-- Content : ARect renames Window( CurrentWindow ).Content;
frame, frame2 : ARect;
-- dtop, dleft, dbottom, dright : integer := 0;
begin
Frame := GetFrame( ptr.all );
-- convert from local to global coordinates, if required
if not IsGlobal then
Frame2 := Frame;
ToGlobal( frame );
Move( ptr.all, frame.left - frame2.left, frame.top - frame2.top );
end if;
-- with scrollable windows, we can no longer constraint to the frame
-- contrain frame to window (dirty trick, but safer this way)
--if frame.left < content.left then
-- dleft := frame.left - content.left;
--end if;
--if frame.top < content.top then
-- dtop := frame.top - content.top;
--end if;
--if frame.right > content.right then
-- dright := content.right - frame.right;
--end if;
--if frame.bottom > content.bottom then
-- dbottom := content.bottom - frame.bottom;
--end if;
--Resize( ptr.all, dleft, dtop, dright, dbottom );
-- GNAT 3.14 bug: rename clause doesn't point "ct" to right entry in
-- control table.
--if ct.size < AControlNumber'last then
-- ct.size := ct.size + 1;
-- if ct.size = 1 then
-- ct.current := 1;
-- end if;
-- ct.control( ct.size ).ptr := ptr;
-- ct.control( ct.size ).kind := kind;
-- ct.control( ct.size ).mine := control;
if Window( CurrentWindow ).table.size < AControlNumber'last then
Window( CurrentWindow ).table.size := Window( CurrentWindow ).table.size + 1;
if Window( CurrentWindow ).table.size = 1 then
Window( CurrentWindow ).table.current := 1;
end if;
Window( CurrentWindow ).table.control( Window( CurrentWindow).table.size ).ptr := ptr;
Window( CurrentWindow ).table.control( Window( CurrentWindow).table.size ).mine := control;
else
null;
end if;
exception when others =>
DrawErrLn;
DrawErr( "AddControl RT exception" );
raise;
end AddControl;
procedure DeleteControl( id : AControlNumber ) is
-- Remove a control from the current window. Shift other controls
-- down to fill in gap in the control table.
ct : AControlTable renames Window( CurrentWindow ).Table;
begin
if id <= ct.size then
if Window( CurrentWindow ).Loaded then
Free( ct.control(id).ptr );
end if;
for i in id..ct.size-1 loop
ct.control( i ) := ct.control(i+1);
end loop;
ct.size := ct.size - 1;
else
Error( TT_ControlExistance );
end if;
exception when others =>
DrawErrLn;
DrawErr( "DeleteControl RT exception" );
raise;
end DeleteControl;
function FindControl( x, y : integer ) return AControlNumber is
-- find the control with this point inside its enclosing frame
begin
for i in 1..Window( CurrentWindow ).Table.size loop
if InControl( Window( CurrentWindow ).Table.Control(i).ptr.all,
x, y ) then
return i;
end if;
end loop;
return 0;
exception when others =>
DrawErrLn;
DrawErr( "FindControl RT exception" );
raise;
end FindControl;
function GetControl( id : AControlNumber ) return AControlPtr is
--return a pointer to a control (for an application to work with)
cp : AControlPtr;
begin
if id > Window( CurrentWindow ).Table.Size then
cp := null;
else
cp := Window( CurrentWindow ).Table.Control( id ).ptr;
end if;
return cp;
end GetControl;
procedure DrawControls( ThisWindow : AWindowNumber ) is
-- Draw a control. If the control is off-screen, it will not be
-- drawn.
begin
WaitToReveal;
for i in 1..Window( ThisWindow ).table.size loop
if insideRect( getFrame( Window( ThisWindow ).table.control(i).ptr.all ),
Window( CurrentWindow ).Content ) then
Draw( Window( ThisWindow ).table.control(i).ptr.all );
end if;
end loop;
Reveal;
exception when others => DrawErrLn;
DrawErr("DrawControls RT Error" );
raise;
end DrawControls;
procedure DrawControls is
begin
DrawControls( CurrentWindow );
end DrawControls;
-- Hilighting Controls
procedure HilightControl( ctr : in out AControlTableRecord ) is
-- Dispatch Hilight, if the control is on the screen.
begin
if insideRect( getFrame( ctr.ptr.all ), Window( CurrentWindow ).Content ) then
if HasInfo( ctr.ptr.all ) then
SetInfoText( GetInfo( ctr.ptr.all ) );
end if;
SetStatus( ctr.ptr.all, On );
Draw( ctr.ptr.all );
else
error( TT_ParamError );
DrawErrLn;
DrawErr( "HilightControl: control not on screen" );
end if;
exception when others =>
DrawErrLn;
DrawErr( "HilightControl RT exception" );
raise;
end HilightControl;
procedure UnhilightControl( ctr : in out AControlTableRecord ) is
-- set control to standby and redraw the control, if the control is on
-- the screen.
begin
if insideRect( getFrame( ctr.ptr.all ), Window( CurrentWindow ).Content ) then
SetStatus( ctr.ptr.all, StandBy );
Draw( ctr.ptr.all );
else
error( TT_ParamError );
DrawErrLn;
DrawErr( "UnhilightControl: control not on screen" );
end if;
end UnhilightControl;
-- Searching Controls
function NextSelectableControl( ct : AControlTable ) return AControlNumber is
-- Find the next active control that is on the screen. The control
-- status is not changed.
ThisControl : AControlNumber;
GiveUp : AControlNumber;
begin
ThisControl := ct.current;
GiveUp := ct.current;
while GetStatus( ct.control( ThisControl ).ptr.all ) = Off or
not insideRect( getFrame( ct.control( thisControl ).ptr.all ),
Window( CurrentWindow ).Content ) loop
if ThisControl < ct.size then
ThisControl := ThisControl + 1;
else
ThisControl := 1;
end if;
if ThisControl = GiveUp then
DrawErr("NextSelectableControl: No selectable controls");
DrawLn;
exit;
end if;
end loop;
return ThisControl;
end NextSelectableControl;
function BackSelectableControl( ct : AControlTable ) return AControlNumber is
-- Like NextSelectableControl but search in reverse direction. The
-- control status is not changed.
ThisControl : AControlNumber;
GiveUp : AControlNumber;
begin
ThisControl := ct.current;
GiveUp := ct.current;
while GetStatus( ct.control( ThisControl ).ptr.all ) = Off or
not insideRect( getFrame( ct.control( thisControl ).ptr.all ),
Window( CurrentWindow ).Content ) loop
if ThisControl > 1 then
ThisControl := ThisControl - 1;
else
ThisControl := ct.size;
end if;
if ThisControl = GiveUp then
DrawErr("BackSelectableControl: No selectable controls");
DrawLn;
exit;
end if;
end loop;
return ThisControl;
exception when others =>
DrawErrLn;
DrawErr( "BackSelectableControl RT exception" );
raise;
end BackSelectableControl;
procedure NextControl is
-- Select the next control (wrap at bottom of table) that is on the
-- screen. The control is not necessarily active. Used when user
-- types tab key.
-- GNAT 3.14 bug
--ct : AControlTable renames Window( CurrentWindow ).table;
-- NOTE: should probably have a "give up" variable for bad windows
begin
if Window( CurrentWindow ).table.size = 0 then
Window( CurrentWindow ).table.current := 0;
return;
end if;
loop
if Window( CurrentWindow ).table.current < Window( CurrentWindow ).table.size then
Window( CurrentWindow ).table.current := Window( CurrentWindow ).table.current + 1;
Window( CurrentWindow ).table.current := NextSelectableControl( Window( CurrentWindow ).table );
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
else
Window( CurrentWindow ).table.current := 1;
Window( CurrentWindow ).table.Current := NextSelectableControl( Window( CurrentWindow ).table );
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
end if;
exit when insideRect( getFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all ), Window( CurrentWindow ).Content );
end loop;
exception when others =>
DrawErrLn;
DrawErr( "NextControl RT exception" );
raise;
end NextControl;
procedure BackControl is
-- select the control before the current one (wrap at top of table).
-- Used when the user types ctrl-t.
-- GNAT 3.14 bug
-- ct : AControlTable renames Window( CurrentWindow ).table;
begin
if Window( CurrentWindow ).table.size = 0 then
Window( CurrentWindow ).table.current := 0;
return;
end if;
loop
if Window( CurrentWindow ).table.current >= 2 then
Window( CurrentWindow ).table.current := Window( CurrentWindow ).table.current - 1;
Window( CurrentWindow ).table.current := BackSelectableControl( Window( CurrentWindow ).table );
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
else
Window( CurrentWindow ).table.current := Window( CurrentWindow ).table.size;
Window( CurrentWindow ).table.current := BackSelectableControl( Window( CurrentWindow ).table );
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
end if;
exit when insideRect( getFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all ), Window( CurrentWindow ).Content );
end loop;
exception when others =>
DrawErrLn;
DrawErr( "BackControl RT exception" );
raise;
end BackControl;
procedure MoveToNextControl( ct : in out AControlTable ) is
-- Move to next control, no hilight (wrap at bottom of table). The
-- control must be on the screen.
begin
if ct.size = 0 then
ct.current := 0;
return;
end if;
loop
if ct.current < ct.size then
ct.current := ct.current + 1;
ct.current := NextSelectableControl( ct );
else
ct.current := 1;
ct.Current := NextSelectableControl( ct );
end if;
exit when insideRect( getFrame( ct.control( ct.current ).ptr.all ), Window( CurrentWindow ).Content );
end loop;
exception when others =>
DrawErrLn;
DrawErr( "MoveToNextControl RT exception" );
raise;
end MoveToNextControl;
procedure NextControlUp is
-- Move up vertically to next control, no hilight (wrap at bottom of
-- table). Used when user moves "up". The control must be on the screen.
-- GNAT 3.14 bug
--ct : AControLTable renames Window( CurrentWindow ).table;
Distance : integer;
Perpend : integer;
BestDistance : integer;
BestPerpend : integer;
BestControl : AControlNumber;
ThisFrame : ARect;
CurrentFrame : ARect;
begin
CurrentFrame := GetFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all );
BestDistance := integer'last;
BestPerpend := integer'last;
BestControl := Window( CurrentWindow ).table.current;
for c in 1..Window( CurrentWindow ).table.size loop
if c /= Window( CurrentWindow ).table.current and GetStatus( Window( CurrentWindow ).table.control( c ).ptr.all )
/= Off and
insideRect( getFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all ), Window( CurrentWindow ).Content ) then
ThisFrame := GetFrame( Window( CurrentWindow ).table.control( c ).ptr.all );
distance := CurrentFrame.Bottom - ThisFrame.Bottom;
if Distance < 0 then
Distance := 1000 + Distance; -- last resort, start from bottom
end if;
perpend := abs( ( ThisFrame.left +
( ThisFrame.right - ThisFrame.left ) / 2 ) -
( CurrentFrame.left +
( CurrentFrame.right - CurrentFrame.left ) / 2 ) );
if Distance /= 0 then
if Perpend < BestPerpend or
( Perpend = BestPerpend and Distance < BestDistance ) then
--if Distance < BestDistance or (Distance = BestDistance
-- and Perpend < BestPerpend) then
BestDistance := Distance;
BestPerpend := Perpend;
BestControl := c;
end if;
end if;
end if;
end loop;
Window( CurrentWindow ).table.current := BestControl;
exception when others =>
DrawErrLn;
DrawErr( "NextControlUp RT exception" );
raise;
end NextControlUp;
procedure NextControlDown is
-- Move down vertically to next control, no hilight (wrap at bottom of
-- table). Used when user moves "down". The control must be on the screen.
-- GNAT 3.14 bug
-- ct : AControLTable renames Window( CurrentWindow ).table;
Distance : integer;
Perpend : integer;
BestDistance : integer;
BestPerpend : integer;
BestControl : AControlNumber;
ThisFrame : ARect;
CurrentFrame : ARect;
begin
CurrentFrame := GetFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all );
BestDistance := integer'last;
BestPerpend := integer'last;
BestControl := Window( CurrentWindow ).table.current;
for c in 1..Window( CurrentWindow ).table.size loop
if c /= Window( CurrentWindow ).table.current and GetStatus( Window( CurrentWindow ).table.control( c ).ptr.all )
/= Off and
insideRect( getFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all ), Window( CurrentWindow ).Content ) then
ThisFrame := GetFrame( Window( CurrentWindow ).table.control( c ).ptr.all );
distance := ThisFrame.Top - CurrentFrame.Top;
if Distance < 0 then
Distance := 1000 + Distance; -- last resort, start from top
end if;
perpend := abs( ( ThisFrame.left +
( ThisFrame.right - ThisFrame.left ) / 2 ) -
( CurrentFrame.left +
( CurrentFrame.right - CurrentFrame.left ) / 2 ) );
if Distance /= 0 then
if Perpend < BestPerpend or
( Perpend = BestPerpend and Distance < BestDistance ) then
--if Distance < BestDistance or (Distance = BestDistance and
-- Perpend < BestPerpend) then
BestDistance := Distance;
BestPerpend := Perpend;
BestControl := c;
end if;
end if;
end if;
end loop;
Window( CurrentWindow ).table.current := BestControl;
exception when others =>
DrawErrLn;
DrawErr( "NextControlDown RT exception" );
raise;
end NextControlDown;
procedure NextControlLeft is
-- Move left horizontally to next control, no hilight (wrap at bottom of
-- table). Used when user moves "left". The control must be on the screen.
-- GNAT 3.14 bug
-- ct : AControLTable renames Window( CurrentWindow ).table;
Distance : integer;
Perpend : integer;
BestDistance : integer;
BestPerpend : integer;
BestControl : AControlNumber;
ThisFrame : ARect;
CurrentFrame : ARect;
begin
CurrentFrame := GetFrame( Window( CurrentWIndow ).table.control( Window( CurrentWIndow ).table.current ).ptr.all );
BestDistance := integer'last;
BestPerpend := integer'last;
BestControl := Window( CurrentWIndow ).table.current;
for c in 1..Window( CurrentWIndow ).table.size loop
if c /= Window( CurrentWIndow ).table.current and GetStatus( Window( CurrentWindow ).table.control( c ).ptr.all )
/= Off and
insideRect( getFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all ), Window( CurrentWindow ).Content ) then
ThisFrame := GetFrame( Window( CurrentWindow ).table.control( c ).ptr.all );
distance := CurrentFrame.Right - ThisFrame.Right;
if Distance < 0 then
Distance := 1000 + Distance; -- last resort, start from right
end if;
perpend := abs( ( ThisFrame.top +
( ThisFrame.bottom - ThisFrame.top ) / 2 ) -
( CurrentFrame.top +
( CurrentFrame.bottom - CurrentFrame.top ) / 2 ) );
if Distance /= 0 then
if Perpend < BestPerpend or
( Perpend = BestPerpend and Distance < BestDistance ) then
--if Distance < BestDistance or (Distance = BestDistance and
-- Perpend < BestPerpend) then
BestDistance := Distance;
BestPerpend := Perpend;
BestControl := c;
end if;
end if;
end if;
end loop;
Window( CurrentWindow ).table.current := BestControl;
exception when others =>
DrawErrLn;
DrawErr( "NextControlLeft RT exception" );
raise;
end NextControlLeft;
procedure NextControlRight is
-- Move right horizontally to next control, no hilight (wrap at bottom of
-- table). Used when user moves "right". The control must be on the screen.
-- GNAT 3.14 bug
-- ct : AControLTable renames Window( CurrentWindow ).table;
Distance : integer;
Perpend : integer;
BestDistance : integer;
BestPerpend : integer;
BestControl : AControlNumber;
ThisFrame : ARect;
CurrentFrame : ARect;
begin
CurrentFrame := GetFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all );
BestDistance := integer'last;
BestPerpend := integer'last;
BestControl := Window( CurrentWindow ).table.current;
for c in 1..Window( CurrentWindow ).table.size loop
if c /= Window( CurrentWindow ).table.current and GetStatus( Window( CurrentWindow ).table.control( c ).ptr.all )
/= Off and
insideRect( getFrame( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all ), Window( CurrentWindow ).Content ) then
ThisFrame := GetFrame( Window( CurrentWindow ).table.control( c ).ptr.all );
distance := ThisFrame.Left - CurrentFrame.Left;
if Distance < 0 then
Distance := 1000 + Distance; -- last resort, start from left
end if;
perpend := abs( ( ThisFrame.top +
( ThisFrame.bottom - ThisFrame.top ) / 2 ) -
( CurrentFrame.top +
( CurrentFrame.bottom - CurrentFrame.top ) / 2 ) );
if Distance /= 0 then
if Perpend < BestPerpend or
( Perpend = BestPerpend and Distance < BestDistance ) then
--if Distance < BestDistance or (Distance = BestDistance and
-- Perpend < BestPerpend) then
BestDistance := Distance;
BestPerpend := Perpend;
BestControl := c;
end if;
end if;
end if;
end loop;
Window( CurrentWindow ).table.current := BestControl;
exception when others =>
DrawErrLn;
DrawErr( "NextControlRight RT exception" );
raise;
end NextControlRight;
procedure FirstControl is
-- select the first control in the table. The control must be on the
-- screen.
-- GNAT 3.14 bug
-- ct : AControLTable renames Window( CurrentWindow ).table;
begin
if Window( CurrentWindow ).table.size = 0 then
Window( CurrentWindow ).table.current := 0;
else
Window( CurrentWindow ).table.current := 1;
Window( CurrentWindow ).table.current := NextSelectableControl( Window( CurrentWindow ).table );
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
end if;
exception when others =>
DrawErrLn;
DrawErr( "FirstControl RT exception" );
raise;
end FirstControl;
function ScanControls( ScanKey : character ) return boolean is
-- Do a hot key search. The control must be on the screen.
-- GNAT 3.14 bug
-- ct : AControlTable renames Window( CurrentWindow ).table;
KeyToFind : character;
function ScanControlsForKey return boolean is
GiveUp : AControlNumber;
ThisKey : character;
NoMatch : boolean;
begin
GiveUp := Window( CurrentWindow ).table.current;
loop
ThisKey := GetHotKey( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ).ptr.all );
if ThisKey /= NullKey then
if ThisKey = KeyToFind then
NoMatch := false;
exit;
end if;
end if;
MoveToNextControl( Window( CurrentWindow ).table );
if Window( CurrentWindow ).table.current = GiveUp then
NoMatch := true;
exit;
end if;
end loop;
if not NoMatch then
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
end if;
return not NoMatch;
end ScanControlsForKey;
begin
KeyToFind := ScanKey;
if ScanControlsForKey then
return true;
else
if KeyToFind >= 'a' and KeyToFind <= 'z' then
KeyToFind := character'val( character'pos( KeyToFind ) - 32 );
return ScanControlsForKey;
elsif KeyToFind >= 'A' and KeyToFind <= 'Z' then
KeyToFind := character'val( character'pos( KeyToFind ) + 32 );
return ScanControlsForKey;
end if;
end if;
return false;
exception when others =>
DrawErrLn;
DrawErr( "ScanControls RT exception" );
raise;
end ScanControls;
function CurrentControl return AControlNumber is
-- Return a pointer to the active control
-- GNAT 3.14 bug
-- ct : AControlTable renames Window( CurrentWindow ).table;
begin
return Window( CurrentWindow ).table.current;
end CurrentControl;
function FindClickedControl( dt : aDialogTaskRecord ) return boolean is
-- find an active control that mouse was clicked in, if any
-- GNAT 3.14 bug
-- ct : AControlTable renames Window( CurrentWindow ).table;
Found : boolean := false;
OldCurrent : AControlNumber;
Frame : aRect;
begin
-- no controls in window? nothing to detect
if Window( CurrentWindow ).table.size = 0 then
return false;
end if;
-- save old current so we know when we've checked every control
OldCurrent := CurrentControl;
loop
Frame := GetFrame( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all );
if InRect( dt.InputRec.UpLocationX, dt.InputRec.UpLocationY,
Frame ) then
Found := true;
exit;
end if;
-- this changes CurrentControl
if Window( CurrentWindow ).table.current < Window( CurrentWindow ).table.size then
Window( CurrentWindow ).table.current := Window( CurrentWindow ).table.current + 1;
else
Window( CurrentWindow ).table.current := 1;
end if;
Window( CurrentWindow ).table.current := NextSelectableControl( Window( CurrentWindow ).table );
exit when CurrentControl = OldCurrent;
end loop;
HilightControl( Window( CurrentWindow ).table.control( Window( CurrentWindow ).table.current ) );
return Found;
end FindClickedControl;
procedure FixRadioFamily( selectedButton : AControlNumber ) is
-- For a radio button family, turn off all other radio buttons
-- except for the selected radio button. It does not select
-- the selected button. Radio buttons are redrawn if they are
-- visible.
-- GNAT 3.14 bug
-- ct : AControlTable renames Window( CurrentWindow ).table;
Target : integer;
begin
WaitToReveal;
Target :=GetFamily(ARadioButton(Window( CurrentWindow ).table.control(selectedButton).ptr.all));
for c in 1..Window( CurrentWindow ).table.size loop
if Window( CurrentWindow ).table.control(c).ptr.all in aRadioButton'class and then c /= selectedButton then
if GetFamily( ARadioButton( Window( CurrentWindow ).table.control(c).ptr.all ) ) = Target then
if GetCheck( ARadioButton( Window( CurrentWindow ).table.control(c).ptr.all ) ) then
SetCheck( ARadioButton( Window( CurrentWindow ).table.control(c).ptr.all ), false );
Invalid( Window( CurrentWindow ).table.control(c).ptr.all );
if insideRect( getFrame( Window( CurrentWindow ).table.control( c ).ptr.all ), Window( CurrentWindow ).Content ) then
Draw( ARadioButton( Window( CurrentWindow ).table.control(c).ptr.all ) );
end if;
end if;
end if;
end if;
end loop;
Reveal;
exception when others =>
DrawErrLn;
DrawErr( "FixRadioFamily RT exception" );
raise;
end FixRadioFamily;
procedure InvalidateControls( ThisWindow : AWindowNumber ) is
-- Mark all controls in a window as invalid (needing to be redrawn).
begin
for i in 1..Window( ThisWindow ).table.size loop
Invalid( Window( ThisWindow ).table.control(i).ptr.all );
end loop;
end InvalidateControls;
--- Clipboard for the Window Manager
procedure ClearClipboard is
-- Clear contents of clipboard
begin
if Clipboard /= null then
Free( Clipboard );
Clipboard := null;
end if;
end ClearClipboard;
procedure NewClipboard( s : string ) is
-- Add string data to clipboard
begin
ClearClipboard;
Clipboard := new ClipboardRec( StringData );
Clipboard.all.s := To_Unbounded_String (S);
exception when others =>
StopAlert( "NewClipboard(s): RT Error" );
end NewClipboard;
procedure NewClipboard (sl : strList.Vector) is
-- Add string list data to clipboard
begin
ClearClipboard;
Clipboard := new ClipboardRec( ListData );
Clipboard.all.l := sl;
exception when others =>
StopAlert( "NewClipboard(sl): RT Error" );
end NewClipboard;
procedure NewClipboard( i : integer ) is
-- Add integer data to clipboard
begin
ClearClipboard;
Clipboard := new ClipboardRec( IntegerData );
Clipboard.all.i := i;
exception when others =>
StopAlert( "NewClipboard(i): RT Error" );
end NewClipboard;
procedure NewClipboard( b : boolean ) is
-- Add boolean data to clipboard
begin
ClearClipboard;
Clipboard := new ClipboardRec( BooleanData );
Clipboard.all.b := boolean'pos(b);
exception when constraint_error =>
StopAlert( "NewClipboard(b): Constraint Error" );
when others =>
StopAlert( "NewClipboard(b): RT Error" );
end NewClipboard;
procedure LoadClipboard is
-- Copy value from the current control into the window manager clipboard.
-- Don't know if GNAT 3.14 bug affects this, but I'll expand it anyway
--ctr : AControlTableRecord renames
-- Window( CurrentWindow ).table.control( CurrentControl );
Sl : StrList.Vector;
begin
if Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aThermometer then
NewClipboard( GetValue( AThermometer( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aScrollBar then
NewClipboard( GetThumb( AScrollBar( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aStaticLine then
NewClipboard( GetText( AStaticLine( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in anEditLine then
NewClipboard( GetText( AnEditLine( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aCheckBox then
NewClipboard( GetCheck( ACheckBox( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aRadioButton then
NewClipboard( GetCheck( ARadioButton( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aSimpleButton then
NewClipboard( GetText( ASimpleButton( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aRectangle then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aLine then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aWindowButton then
NewClipboard( GetText( AWindowButton( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aStaticLine then
if GetMark( AStaticList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) < 0 then
NewClipboard (CopyLine (AStaticList (Window (CurrentWindow).table.Control (CurrentControl).ptr.all)));
else
CopyLines( AStaticList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ),
GetCurrent( AStaticList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ), sl );
NewClipboard( sl );
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aCheckList then
if GetMark( ACheckList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) < 0 then
NewClipboard (CopyLine (AcheckList (Window (CurrentWindow).table.Control (CurrentControl).ptr.all)));
else
CopyLines( ACheckList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ),
GetCurrent( ACheckList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ), sl );
NewClipboard( sl );
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aRadioList then
if GetMark( ARadioList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) < 0 then
NewClipboard (CopyLine (ARadioList (Window (CurrentWindow).table.Control (CurrentControl).ptr.all)));
else
CopyLines( ARadioList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ),
GetCurrent( ARadioList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ), sl );
NewClipboard( sl );
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in anEditList then
if GetMark( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) < 0 then
NewClipboard (CopyLine (AnEditList (Window (CurrentWindow).table.Control (CurrentControl).ptr.all)));
else
CopyLines( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ),
GetCurrent( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ), sl );
NewClipboard( sl );
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aTreeList then
if GetMark( ATreeList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) < 0 then
NewClipboard (CopyLine (ATreeList (Window (CurrentWindow).table.Control (CurrentControl).ptr.all)));
else
CopyLines( ATreeList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ),
GetCurrent( ATreeList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ), sl );
NewClipboard( sl );
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aSourceEditList then
if GetMark( ASourceEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ) < 0 then
NewClipboard (CopyLine (ASourceEditList (Window (CurrentWindow).table.Control (CurrentControl).ptr.all)));
else
CopyLines( ASourceEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ),
GetCurrent( ASourceEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) ), sl );
NewClipboard( sl );
end if;
else
SessionLog( "LoadClipboard: Unknown control type" );
end if;
exception when others =>
DrawErrLn;
DrawErr( "LoadClipboard RT exception" );
raise;
end LoadClipboard;
procedure PasteClipboard is
-- Copy the value in the window manager clipboard into the current
-- control.
procedure PasteTypeError is
-- show a warning for pasting invalid data for a control
begin
case Clipboard.all.DataType is
when IntegerData =>
CautionAlert( "Can't paste numbers here" );
when StringData =>
CautionAlert( "Can't paste text here" );
when BooleanData =>
CautionAlert( "Can't paste checks here" );
when others =>
StopAlert( "Can't paste this kind of info" );
end case;
end PasteTypeError;
-- GNAT 3.14 bug maybe
--ctr : AControlTableRecord renames
-- Window( CurrentWindow ).table.control( CurrentControl );
begin
if Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aThermometer then
if Clipboard /= null and then Clipboard.all.DataType = IntegerData then
SetValue( AThermometer( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), Clipboard.all.i );
else
PasteTypeError;
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aScrollBar then
if Clipboard /= null and then Clipboard.all.DataType = IntegerData then
SetThumb( AScrollBar( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), Clipboard.all.i );
else
PasteTypeError;
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aStaticLine then
if Clipboard /= null and then Clipboard.all.DataType = StringData then
SetText( AStaticLine( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), To_String (Clipboard.all.S) );
else
PasteTypeError;
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in anEditLine then
if Clipboard /= null then
if Clipboard.all.DataType = StringData then
SetText( AnEditLine( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), To_String (Clipboard.all.S) );
elsif Clipboard.all.DataType = IntegerData then
SetText( AnEditLine( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), integer'image( Clipboard.all.i ));
else
PasteTypeError;
end if;
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aCheckBox then
if Clipboard /= null and then Clipboard.all.DataType = BooleanData then
SetCheck( ACheckBox( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), boolean'val( Clipboard.all.b ) );
else
PasteTypeError;
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aRadioButton then
if Clipboard /= null and then Clipboard.all.DataType = BooleanData then
SetCheck( ARadioButton( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), boolean'val( Clipboard.all.b ) );
FixRadioFamily( CurrentControl );
else
PasteTypeError;
end if;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aSimpleButton then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aRectangle then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aLine then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aWindowButton then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aStaticList then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aCheckList then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aRadioList then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aTreeList then
null;
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in anEditList then
if Clipboard /= null then
if Clipboard.all.DataType = StringData then
PasteLine( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), To_String (Clipboard.all.S) );
elsif Clipboard.all.DataType = IntegerData then
PasteLine( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), integer'image( Clipboard.all.i ) );
elsif Clipboard.all.DataType = ListData then
PasteLines( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), Clipboard.all.l );
else
PasteTypeError;
end if;
end if;
Invalid( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all );
Touch( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) );
elsif Window( CurrentWindow ).table.control( CurrentControl ).ptr.all in aSourceEditList then
if Clipboard /= null then
if Clipboard.all.DataType = StringData then
PasteLine( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), To_String (Clipboard.all.S) );
elsif Clipboard.all.DataType = IntegerData then
PasteLine( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), integer'image( Clipboard.all.i ) );
elsif Clipboard.all.DataType = ListData then
PasteLines( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ), Clipboard.all.l );
else
PasteTypeError;
end if;
end if;
Invalid( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all );
Touch( AnEditList( Window( CurrentWindow ).table.control( CurrentControl ).ptr.all ) );
else
null;
end if;
exception when others =>
DrawErrLn;
DrawErr( "PasteClipboard RT exception" );
raise;
end PasteClipboard;
procedure DoDialog( DialogTask : in out ADialogTaskRecord;
TaskCB : in ADialogTaskCallBack := null;
HearInCB : in ADialogTaskCallBack := null;
HearOutCB : in ADialogTaskCallBack := null ) is
use Ada.Calendar;
--
-- This is the dialog manager. This procedure handles input in the
-- current window and returns events for the application to handle.
-- Its duties include:
-- * displaying the clock on the screen
-- * ringing the chime every 15
-- * invoking the idle tasks for the other packages
-- * the accessories window
-- * following window button links
-- * handling interaction between scroll bars / thermometers & boxes)
-- * handling hot keys
-- * handling cut/copy/paste, screen redraw key, etc.
-- An application spends most of its time here.
--
cp : AControlPtr; -- just a control pointer
MovedToNewControl : boolean; -- true if scancontrols was successful
table : AControlTable renames Window(CurrentWindow).table;
LoopTime : Time; -- time input loop was started
IdleMark : Time; -- for idle tasks
IdleTime : Duration; -- for idle tasks
-- Chime
ChimeMark : Time; -- time clock was last check for chime
-- ChimeSkipMinutes is global (ie across all executions of DoDialog)
Minutes : Formatting.Minute_Number;
procedure ShowAccessoriesWindow is
-- Show the pop-up desk accessories window
dialogWindow : AWindowNumber; -- last window
dialogControl : AControlNumber; -- last active control
pragma Unreferenced (DialogWindow, Dialogcontrol);
item : AControlNumber;
width : constant integer := 20; -- content dimensions of our window
height : constant integer := 5;
DialogTask : ADialogTaskRecord;
procedure ShowCalendar is
-- The Calendar desk accessor
Y : constant String := Year_Number'Image (Year (Clock));
CalList : StrList.Vector;
begin
Runit ("/usr/bin/cal", "-y", Y, Results => Callist);
CalList.Append ("Today is " & Formatting.Image (Clock));
ShowListInfo( "Calendar for" & Y, 0, 1, 79, 24, CalList );
pragma Unreferenced (Callist);
end ShowCalendar;
procedure ShowNotepad is
-- Notepad desk accessory
NotePadSave : StrList.Vector;
SaveChanges : boolean;
begin
NotePadSave := Notepaddata;
EditListInfo( "Notepad", 0, 1, 79, 24, NotePadData, SaveChanges );
if not SaveChanges then
Notepaddata := NotePadSave;
end if;
end ShowNotePad;
begin
dialogWindow := CurrentWindow;
dialogControl := CurrentControl;
OpenWindow( "Accessories Menu", 2, 2, width + 1 + 2, height + 1 + 2 );
SharedButton( Shared.Button1, 2, 2, 7, 2, 'o', s_OK );
SharedButton( Shared.Button2, 2, 3, 13, 3, 'c', "Calendar");
SharedButton( Shared.Button3, 2, 4, 13, 4, 'n', "Notepad");
DialogTask.control := 1;
DoDialog( DialogTask ); -- recursion here
item := DialogTask.Control;
if item = 2 then
ShowCalendar;
elsif item = 3 then
ShowNotepad;
end if;
CloseWindow;
HilightControl( Window( CurrentWindow ).table.control(CurrentControl));
end ShowAccessoriesWindow;
function DoFollowLink return AControlNumber is
-- For a window button, load the new window indicated
-- by the window button or launch an application (lynx) to
-- display the web page/etc. Returns control hit, or 0.
wb : AWindowButton renames AWindowButton(
Window( CurrentWindow ).Table.control( CurrentControl ).ptr.all );
link : constant String := GetLink( wb );
DT : ADialogTaskRecord;
begin
if Ada.Strings.Fixed.Head (Link, 9) = "window://" then
LoadWindow( Ada.Strings.Fixed.Tail (Link, Link'Length - 10));
NoteAlert( link ); -- testing
DoDialog( DT ); -- recursion here;
NoteAlert( "Closing autowindow" ); -- testing
CloseWindow;
return DT.control;
elsif Ada.Strings.Fixed.Head (Link, 6) = "http:/" then
SessionLog( "DoFollowLink: following " & link );
ShellOut( "lynx " & link );
return 0;
elsif Ada.Strings.Fixed.Head (Link, 6) = "file:/" then
SessionLog( "DoFollowLink: following " & link );
ShellOut( "lynx " & link );
return 0;
elsif Ada.Strings.Fixed.Head (link, 7 ) = "unix://" then
SessionLog( "DoFollowLink: following " & link );
ShellOut( Ada.Strings.Fixed.Tail (Link, Link'Length - 8) );
return 0;
else
StopAlert( "DoFollowLink: Can't follow this type" );
return 0;
end if;
exception
when Status_Error =>
NoteAlert( "DoFollowLink: " & Link & " open" );
return 0;
when Use_Error =>
NoteAlert( "DoFollowLink: Use error" );
return 0;
when Name_Error =>
NoteAlert( "DoFollowLink: " & Link & " not found" );
return 0;
when others =>
NoteAlert( "DoFollowLink: Unable to load " & Link);
return 0;
end DoFollowLink;
procedure AdjustScrollBar is
-- Fix a scroll bar or thermometer to accurately reflect a list
-- control's position. The list control must be the current control.
-- If the bar/thermometer is on the screen, it will be redrawn.
sb : AControlNumber;
psn : Natural;
max : integer;
list: AControlTableRecord renames Table.Control( CurrentControl );
begin
if Table.Control( CurrentControl ).ptr.all in aStaticList then
sb := GetScrollBar( AStaticList( list.ptr.all ) );
psn:= GetCurrent( AStaticList( list.ptr.all ) ) - 1;
max:= GetLength( AStaticList( list.ptr.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aCheckList then
sb := GetScrollBar( ACheckList( list.ptr.all ) );
psn:= GetCurrent( ACheckList( list.ptr.all ) ) - 1;
max:= GetLength( ACheckList( list.ptr.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aRadioList then
sb := GetScrollBar( ARadioList( list.ptr.all ) );
psn:= GetCurrent( ARadioList( list.ptr.all ) ) - 1;
max:= GetLength( ARadioList( list.ptr.all ) );
elsif Table.Control( CurrentControl ).ptr.all in anEditList then
sb := GetScrollBar( AnEditList( list.ptr.all ) );
psn := GetCurrent( AnEditList( list.ptr.all ) );
max := GetLength( AnEditList( list.ptr.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aTreeList then
sb := GetScrollBar( ATreeList( list.ptr.all ) );
psn := GetCurrent( ATreeList( list.ptr.all ) );
max := GetLength( ATreeList( list.ptr.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aSourceEditList then
sb := GetScrollBar( ASourceEditList( list.ptr.all ) );
psn := GetCurrent( ASourceEditList( list.ptr.all ) );
max := GetLength( ASourceEditList( list.ptr.all ) );
else
StopAlert( "AdjustScrollBar: unknown control type" );
end if;
if sb /= 0 then
if Table.Control( sb ).ptr.all in aScrollBar then
if GetMax( AScrollBar( Table.Control( sb ).ptr.all ) ) /= max then
SetMax( AScrollBar( Table.Control( sb ).ptr.all ), max );
end if;
SetThumb( AScrollBar( Table.Control( sb ).ptr.all ), psn);
UnhilightControl( list );
if insideRect( getFrame( Window( CurrentWindow ).table.control( sb ).ptr.all ), Window( CurrentWindow ).Content ) then
Draw( Table.Control( sb ).ptr.all );
end if;
HilightControl( list );
elsif Table.Control( sb ).ptr.all in aThermometer then
if GetMax( AThermometer( Table.Control( sb ).ptr.all ) ) /= max then
SetMax( AThermometer( Table.Control( sb ).ptr.all ), max );
end if;
SetValue( AThermometer( Table.Control( sb ).ptr.all ), psn);
if insideRect( getFrame( Window( CurrentWindow ).table.control( sb ).ptr.all ), Window( CurrentWindow ).Content ) then
Draw( Table.Control( sb ).ptr.all );
end if;
else
StopAlert( "AdjustScrollBar: Control not a scroll bar or therm" );
end if;
end if;
exception when others => DrawErrLn;
DrawErr("AdjustScrollBar: RT error");
raise;
end AdjustScrollBar;
procedure AdjustListControl is
-- Fix a list control so its current position is updated to
-- reflect an associated scroll bar or thermometer. The list
-- is redrawn if it is on the screen.
list: AControlNumber;
psn : integer;
max : integer;
len : Natural;
sb : AControlTableRecord renames Table.Control( CurrentControl );
begin
if Table.Control( CurrentControl ).ptr.all in aScrollBar then
list := GetOwner( AScrollBar( sb.ptr.all ) );
psn := GetThumb( AScrollBar( sb.ptr.all ) ) + 1;
max := GetMax( AScrollBar( sb.ptr.all ) );
else
StopAlert( "AdjustListControl: not a scroll bar" );
end if;
if list /= 0 then
if Table.Control( list ).ptr.all in aStaticList then
len := GetLength( AStaticList( Table.Control( list ).ptr.all ) );
SetOrigin( AStaticList( Table.Control( list ).ptr.all ), len * psn / max );
if insideRect( getFrame( Window( CurrentWindow ).table.control( currentControl ).ptr.all ), Window( CurrentWindow ).Content ) then
UnhilightControl( sb );
Draw( Table.Control( list ).ptr.all );
HilightControl( sb );
end if;
elsif Table.Control( list ).ptr.all in aCheckList then
len := GetLength( ACheckList( Table.Control( list ).ptr.all ) );
SetOrigin( ACheckList( Table.Control( list ).ptr.all ), len * psn / max );
if insideRect( getFrame( Window( CurrentWindow ).table.control( currentControl ).ptr.all ), Window( CurrentWindow ).Content ) then
UnhilightControl( sb );
Draw( Table.Control( list ).ptr.all );
HilightControl( sb );
end if;
elsif Table.Control( list ).ptr.all in aRadioList then
len := GetLength( ARadioList( Table.Control( list ).ptr.all ) );
SetOrigin( ARadioList( Table.Control( list ).ptr.all ), len * psn / max );
if insideRect( getFrame( Window( CurrentWindow ).table.control( currentControl ).ptr.all ), Window( CurrentWindow ).Content ) then
UnhilightControl( sb );
Draw( Table.Control( list ).ptr.all );
HilightControl( sb );
end if;
elsif Table.Control( list ).ptr.all in anEditList then
len := GetLength( AnEditList( Table.Control( list ).ptr.all ) );
SetOrigin( AnEditList( Table.Control( list ).ptr.all ), len * psn / max );
if insideRect( getFrame( Window( CurrentWindow ).table.control( currentControl ).ptr.all ), Window( CurrentWindow ).Content ) then
UnhilightControl( sb );
Draw( Table.Control( list ).ptr.all );
HilightControl( sb );
end if;
elsif Table.Control( list ).ptr.all in aTreeList then
len := GetLength( ATreeList( Table.Control( list ).ptr.all ) );
SetOrigin( ATreeList( Table.Control( list ).ptr.all ), len * psn / max );
if insideRect( getFrame( Window( CurrentWindow ).table.control( currentControl ).ptr.all ), Window( CurrentWindow ).Content ) then
UnhilightControl( sb );
Draw( Table.Control( list ).ptr.all );
HilightControl( sb );
end if;
elsif Table.Control( list ).ptr.all in aSourceEditList then
len := GetLength( ASourceEditList( Table.Control( list ).ptr.all ) );
SetOrigin( ASourceEditList( Table.Control( list ).ptr.all ), len * psn / max );
if insideRect( getFrame( Window( CurrentWindow ).table.control( currentControl ).ptr.all ), Window( CurrentWindow ).Content ) then
UnhilightControl( sb );
Draw( Table.Control( list ).ptr.all );
HilightControl( sb );
end if;
else
StopAlert( "AdjustListControl: Control not a List" );
end if;
end if;
exception when others => DrawErrLn;
DrawErr("AdjustListControl: RT error ");
raise;
end AdjustListControl;
procedure AdjustMyScrollBars is
begin
if Table.Control( CurrentControl ).ptr.all in aScrollBar then
AdjustListControl;
elsif Table.Control( CurrentControl ).ptr.all in aStaticList then
AdjustScrollBar;
elsif Table.Control( CurrentControl ).ptr.all in aCheckList then
AdjustScrollBar;
elsif Table.Control( CurrentControl ).ptr.all in aRadioList then
AdjustScrollBar;
elsif Table.Control( CurrentControl ).ptr.all in anEditList then
AdjustScrollBar;
elsif Table.Control( CurrentControl ).ptr.all in aTreeList then
AdjustScrollBar;
elsif Table.Control( CurrentControl ).ptr.all in aSourceEditList then
AdjustScrollBar;
else
null;
end if;
end AdjustMyScrollBars;
function DoStandardActions return boolean is
-- handle standard actions return from a control's Hear
-- call
exitloop : boolean := false; -- true if exit event loop
begin
case DialogTask.Action is
when Next =>
UnhilightControl( Table.Control( CurrentControl ) );
NextControl;
HilightControl( Table.Control( CurrentControl ) );
when Back =>
UnhilightControl( Table.Control( CurrentControl ) );
BackControl;
HilightControl( Table.Control( CurrentControl ) );
when Up =>
UnhilightControl( Table.Control( CurrentControl ) );
NextControlUp;
HilightControl( Table.Control( CurrentControl ) );
when Down =>
UnhilightControl( Table.Control( CurrentControl ) );
NextControlDown;
HilightControl( Table.Control( CurrentControl ) );
when Left =>
UnhilightControl( Table.Control( CurrentControl ) );
NextControlLeft;
HilightControl( Table.Control( CurrentControl ) );
when Right =>
UnhilightControl( Table.Control( CurrentControl ) );
NextControlRight;
HilightControl( Table.Control( CurrentControl ) );
when Complete =>
DialogTask.MyTask := Complete;
DialogTask.Control := CurrentControl;
--- inputrec and action already filled
exitloop := true;
when ScanNext =>
UnhilightControl( Table.Control( CurrentControl ) );
MovedToNewControl := ScanControls( DialogTask.InputRec.Key );
HilightControl( Table.Control( CurrentControl ) );
-- if moved to a different control, check for a button
-- and if it's instant, give it a return key to activate
-- it.
if MovedToNewControl then
if Table.Control( CurrentControl ).ptr.all in aSimpleButton then
if GetInstant( ASimpleButton( Table.Control( CurrentControl ).ptr.all ) ) then
declare
fakeInput : AnInputRecord (KeyInput);
begin
fakeInput.key := ReturnKey;
Hear( Table.Control( CurrentControl ).ptr.all, fakeInput, DialogTask.action );
end;
DialogTask.MyTask := Complete;
DialogTask.Control := CurrentControl;
exitloop := true;
end if;
elsif Table.Control( CurrentControl ).ptr.all in aWindowButton then
if GetInstant( AWindowButton( Table.Control( CurrentControl ).ptr.all ) ) then
declare
fakeInput : AnInputRecord (KeyInput);
begin
fakeInput.key := ReturnKey;
Hear( Table.Control( CurrentControl ).ptr.all, fakeInput, DialogTask.action );
end;
-- handle instant follow links here since it won't make it
-- around again after top of loop. Normal follow links
-- will hit the "when FollowLink" case.
if DialogTask.action = FollowLink then
SetControlHit( AWindowButton( cp.all ), DoFollowLink );
--DialogTask.Action := none;
end if;
end if;
end if;
end if; --b
when FollowLink =>
SetControlHit( AWindowButton( cp.all ), DoFollowLink );
when None =>
if Table.Control( CurrentControl ).mine then
AdjustMyScrollBars;
else
DialogTask.MyTask := Hit;
DialogTask.Control := CurrentControl;
-- InputRec and Action already filled
if TaskCB /= null then
TaskCB.all( DialogTask );
else
DialogTask.MyTask := DialogError;
Error( TT_NoDialogTaskCB );
exitloop := true;
end if;
end if;
when others =>
DrawErr ("DoDialog: unabled to handle control result");
DrawErrLn;
end case;
return exitloop;
end DoStandardActions;
procedure DrawTime( timestr : in string ) is
-- draw time in bottom-right of screen, but don't lose
-- current cursor position or pen attributes
OldX, OldY : integer;
OldColour : APenColourName;
OldStyle : ATextStyle;
begin
GetPenPos( OldX, OldY );
OldColour := GetPenColour;
OldStyle := GetTextStyle;
SetTextStyle( Footnote );
SetPenColour( outline );
MoveToGlobal( DisplayInfo.H_Res-7, DisplayInfo.V_Res-1 );
Draw( Ada.Strings.Fixed.Head (TimeStr, 5) ); -- show "hh:mm"
MoveToGlobal( OldX, OldY );
SetPenColour( OldColour );
SetTextStyle( OldStyle );
end DrawTime;
use Ada.Containers;
begin -- DoDialog
NoError;
DialogTask.MyTask := None;
DialogTask.Action := None;
if length( Window( CurrentWindow ).Title ) > 0 then
SessionLog( "DoDialog: Dialog for window called '" &
To_String (Window( CurrentWindow ).Title) & "'" );
else
SessionLog( "DoDialog: Running dialog for untitled window" );
end if;
if Window( CurrentWindow ).table.size = 0 then
DialogTask.MyTask := DialogError;
DialogTask.control := AControlNumber'First;
Error( TT_NoControls );
return;
end if;
DrawControls;
FirstControl;
HilightControl( Table.Control( CurrentControl ) );
IdleMark := Clock;
ChimeMark := Clock;
loop
LoopTime := Clock;
-- Hour and Quarterly Chimes
if LoopTime - ChimeMark > 15.0 then -- check every 15 seconds
ChimeMark := LoopTime; -- update the chime mark
Minutes := Formatting.Minute (Clock);
DrawTime (Formatting.Image (Clock));
if Minutes /= ChimeSkipMinutes then -- already chimed this min?
if Minutes = 0 then -- if not, 00 is hour chime
Beep( HourChime ); -- etc.
ChimeSkipMinutes := Minutes;
elsif Minutes = 15 then
Beep( QuarterChime1 );
ChimeSkipMinutes := Minutes;
elsif Minutes = 30 then
Beep( QuarterChime2 );
ChimeSkipMinutes := Minutes;
elsif Minutes = 45 then
Beep( QuarterChime3 );
ChimeSkipMinutes := Minutes;
end if;
end if;
end if;
GetInput( DialogTask.InputRec, Response => Erratic );
if DialogTask.InputRec.InputType = NullInput then
IdleTime := LoopTime - IdleMark;
if IdleTime > 30.0 then -- 30 seconds of null activity?
IdleCommon (IdleTime);
IdleOS( IdleTime );
IdleUserIO( IdleTime );
IdleControls( IdleTime );
IdleWindows( IdleTime );
end if;
if Window( CurrentWindow ).Timeout > 0.0 then
if IdleTime > Window( CurrentWindow ).Timeout then
SessionLog ("DoDialog: Time out after"
& Duration'Image (Window (CurrentWindow).Timeout)
& " second(s).");
UnhilightControl( Table.Control( CurrentControl ) );
Table.current := Window( CurrentWindow ).TimeoutControl;
HilightControl( Table.Control( CurrentControl ) );
SetInputString (" ");
end if;
end if;
else
IdleMark := LoopTime; -- return secs
end if;
--
-- Intercept Dialog Input
--
if DialogTask.InputRec.InputType = KeyInput then
case DialogTask.InputRec.Key is
when TabKey => UnhilightControl( Table.Control( CurrentControl ) );
NextControl;
HilightControl( Table.Control( CurrentControl ) );
when BackKey => UnhilightControl( Table.Control( CurrentControl ) );
BackControl;
HilightControl( Table.Control( CurrentControl ) );
when HelpKey => ShowAccessoriesWindow;
when CopyKey => LoadClipboard;
if Clipboard.all.DataType = ListData
and then Clipboard.all.L.Length > 1 then
if Window( CurrentWindow ).HasInfoBar then
Window( CurrentWindow ).InfoText := To_Unbounded_String
("Coped" & Count_Type'Image (Clipboard.all.L.Length) & " lines");
DrawInfo( CurrentWIndow );
end if;
end if;
when PasteKey => PasteClipboard;
DrawControls;
HilightControl( Table.Control( CurrentControl ) );
if Clipboard.all.DataType = ListData
and then Clipboard.all.L.Length > 1 then
if Window( CurrentWindow ).HasInfoBar then
Window( CurrentWindow ).InfoText := To_Unbounded_String
( "Pasted" & Count_Type'Image (Clipboard.all.L.Length) & " lines" );
DrawInfo( CurrentWIndow );
end if;
end if;
if Table.Control( CurrentControl ).mine then
AdjustMyScrollBars;
end if;
when RedrawKey => RefreshDesktop;
HilightControl( Table.Control( CurrentControl ) );
SessionLog( "DoDialog: User refreshed screen" );
when MarkKey =>
declare
cp : AControlPtr renames Table.Control( CurrentControl ).ptr;
begin
if Table.Control( CurrentControl ).ptr.all in aStaticList then
if GetCurrent( AStaticList( cp.all ) ) =
GetMark( AStaticList( cp.all ) ) then
SetMark( AStaticList( cp.all ), -1 );
else
SetMark( AStaticList( cp.all ),
GetCurrent( AStaticList( cp.all ) ) );
end if;
Draw( AStaticList( cp.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aRadioList then
if GetCurrent( ARadioList( cp.all ) ) =
GetMark( ARadioList( cp.all ) ) then
SetMark( ARadioList( cp.all ), -1 );
else
SetMark( ARadioList( cp.all ),
GetCurrent( ARadioList( cp.all ) ) );
end if;
Draw( ARadioList( cp.all ) );
elsif Table.Control( CurrentControl ).ptr.all in anEditList then
if GetCurrent( AnEditList( cp.all ) ) =
GetMark( AnEditList( cp.all ) ) then
SetMark( AnEditList( cp.all ), -1 );
else
SetMark( AnEditList( cp.all ),
GetCurrent( AnEditList( cp.all ) ) );
end if;
Draw( AnEditList( cp.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aTreeList then
if GetCurrent( ATreeList( cp.all ) ) =
GetMark( ATreeList( cp.all ) ) then
SetMark( ATreeList( cp.all ), -1 );
else
SetMark( ATreeList( cp.all ),
GetCurrent( ATreeList( cp.all ) ) );
end if;
Draw( ATreeList( cp.all ) );
elsif Table.Control( CurrentControl ).ptr.all in aSourceEditList then
if GetCurrent( ASourceEditList( cp.all ) ) =
GetMark( ASourceEditList( cp.all ) ) then
SetMark( ASourceEditList( cp.all ), -1 );
else
SetMark( ASourceEditList( cp.all ),
GetCurrent( ASourceEditList( cp.all ) ) );
end if;
Draw( ASourceEditList( cp.all ) );
end if;
end;
when others =>
-- ClearKey => LoadClipboard first, then process normally
-- by allowing control to do the clearing
if DialogTask.InputRec.Key = ClearKey then
LoadClipboard;
if Clipboard.all.DataType = ListData and then Clipboard.all.L.Length > 1 then
if Window( CurrentWindow ).HasInfoBar then
Window( CurrentWindow ).InfoText := To_Unbounded_String( "Cut" & Count_Type'Image (Clipboard.all.L.Length) & " lines" );
DrawInfo( CurrentWIndow );
end if;
end if;
if Table.Control( CurrentControl ).mine then
AdjustMyScrollBars;
end if;
end if;
if HearInCB /= null then
HearInCB.all( DialogTask );
end if;
--
-- Treat alt keypresses as a request for hot key scan
--
if character'pos( DialogTask.InputRec.Key ) >= 128 then
-- strip high bit leaving the key that was alt'ed
DialogTask.InputRec.Key := character'val(
character'pos( DialogTask.InputRec.Key ) - 128 );
-- do a hot key scan
DialogTask.Action := ScanNext;
else
--
-- Pass Other Input Keys to the Active Control
--
cp := Table.control( CurrentControl ).ptr;
Hear( cp.all, DialogTask.InputRec, DialogTask.Action );
if HearOutCB /= null then
HearOutCB.all( DialogTask );
end if;
end if;
if DialogTask.Action = FixFamily then
FixRadioFamily( CurrentControl );
DialogTask.Action := None; -- do before drawing
end if;
Draw( Table.control( CurrentControl ).ptr.all );
--HilightControl( Table.Control( CurrentControl));
RevealNow;
if DoStandardActions then
exit; -- exit if necessary
end if;
end case;
elsif DialogTask.InputRec.InputType = ButtonDownInput then
null; -- not supported
elsif DialogTask.InputRec.InputType = MoveInput then
-- apparently not yet working on ncurses
if FindClickedControl( DialogTask ) then
if GetStatus( Table.Control( CurrentControl).ptr.all ) /= off
and HasInfo( Table.Control( CurrentControl).ptr.all ) then
SetInfoText(
GetInfo( Table.Control( CurrentControl).ptr.all ) );
end if;
end if;
elsif DialogTask.InputRec.InputType = ButtonUpInput then
if FindClickedControl( DialogTask ) then
cp := Table.control( CurrentControl ).ptr;
if HearInCB /= null then
HearInCB.all( DialogTask );
end if;
Hear( cp.all, DialogTask.InputRec, DialogTask.Action );
if HearOutCB /= null then
HearOutCB.all( DialogTask );
end if;
if DialogTask.Action = FixFamily then
FixRadioFamily( CurrentControl );
DialogTask.Action := None; -- do before drawing
end if;
Draw( Table.control( CurrentControl ).ptr.all );
--HilightControl( Table.Control( CurrentControl));
RevealNow;
if DoStandardActions then
exit; -- exit if necessary
end if;
else
if HearInCB /= null then
HearInCB.all( DialogTask );
end if;
-- No HearOut since nothing actually clicked on
SessionLog( "DoDialog: clicked in window background" );
end if; -- clicked in an active control
end if; -- Key Input
end loop;
exception when others => DrawErrLn;
DrawErr( "DoDialog RT exception" );
raise;
end DoDialog;
--- Windows
procedure EraseWindow is
-- Erase a window
w : AWindow renames Window( CurrentWindow );
begin
NoError;
WaitToReveal;
EraseRect( w.Content );
MoveToGlobal( w.Content.Left, w.Content.Top );
Reveal;
exception when others =>
DrawErrLn;
DrawErr( "EraseWindow RT exception" );
raise;
end EraseWindow;
procedure EraseWindow( id : AWindowNumber ) is
-- Erase a window
w : AWindow renames Window( id );
begin
NoError;
WaitToReveal;
EraseRect( w.Content );
MoveToGlobal( w.Content.Left, w.Content.Top );
Reveal;
exception when others =>
DrawErrLn;
DrawErr( "EraseWindow RT exception" );
raise;
end EraseWindow;
procedure DrawWindow( id : AWindowNumber;
Redraw : RedrawingAmounts := none ) is
-- Draw a window
First : integer; -- x coordinate of title
Width : integer; -- width of the title
Frame : ARect renames Window( id ).frame;
OldColour : APenColourName;
OldStyle : ATextStyle;
begin
NoError;
WaitToReveal;
OldColour := GetPenColour;
OldStyle := GetTextStyle;
SetPenColour( outline );
SetTextStyle( Normal );
if Redraw = Whole then
EraseWindow( id );
InvalidateControls( id );
end if;
if Window( id ).style = Frameless then
CDesktop( DisplayInfo.H_Res-1, DisplayInfo.V_Res-1);
elsif Window( id ).HasFrame then
if DisplayInfo.C_Res > 0 then
if Window( id ).Style = Status then
if IsBlueBackground then
SetPenColour( White );
else
SetPenColour( Green ); -- green hard to see on blue
end if;
elsif Window( id ).Style = Warning then
SetPenColour( yellow );
elsif Window( id ).Style = Danger then
SetPenColour( red );
elsif Window( id ).FrameColour = outline then
if IsBlueBackground then
SetPenColour( White );
else
SetPenColour( Green ); -- green hard to see on blue
end if;
else
SetPenColour( Window( id ).FrameColour );
end if;
end if;
if Redraw /= none then -- redraw frame/whole then...
FrameRect3D( Frame );
SetPenColour( outline );
width := Length (Window( id ).title);
first := Frame.left + ( (Frame.right - Frame.left - width) / 2 );
if first <= Frame.left then
first := Frame.left + 1;
end if;
if width > Frame.right - Frame.left - 2 then
width := Frame.right - Frame.left - 2;
end if;
MoveToGlobal( first, Frame.top );
Draw( To_String (Window( id ).Title), width, true );
MoveToGlobal( Window(id).content.left, Window(id).content.top );
end if; -- redraw frame/whole
end if;
DrawControls( id );
DrawInfo( id );
SetPenColour( OldColour );
SetTextStyle( OldStyle );
if Window( id ).DrawCB /= null then
Window( id ).DrawCB.all; -- execute call back (if any)
end if;
Reveal;
exception when others => DrawErrLn;
DrawErr("DrawWindow(2) RT error");
raise;
end DrawWindow;
procedure DrawWindow( Redraw : RedrawingAmounts := none ) is
begin
DrawWindow( CurrentWindow, Redraw );
exception when others => DrawErrLn;
DrawErr("DrawWindow(1) RT error");
raise;
end DrawWindow;
-- Reset Window
procedure ResetWindow( id : AWindowNumber ) is
begin
MoveToGlobal( Window(id).frame.left, Window(id).frame.top );
SetTextStyle( Normal );
SetPenColour( Black );
SetTextColour( Black );
exception when others =>
DrawErrLn;
DrawErr( "ResetWindow RT exception" );
raise;
end ResetWindow;
procedure ResetWindow is
begin
ResetWindow( CurrentWindow );
end ResetWindow;
procedure RefreshDesktop is
Amount : array( 1..AWindowNumber'last ) of RedrawingAmounts;
First2Redo : AWindowNumber;
begin
NoError;
-- Identify windows to be redrawn
First2Redo := NextWindow - 1; -- start at top window
Amount( First2Redo ) := whole; -- always redraw top window
for ThisWindow in reverse 1..NextWindow-2 loop
Amount( ThisWindow ) := none;
-- redraw window if not buried under other windows
for OverWindow in ThisWindow+1..NextWindow-1 loop
-- if overwindow doesn't completely obscure this window
-- then some drawing will need to be done
if not InsideRect( Inner => Window( ThisWindow ).frame,
Outer => Window( OverWindow ).frame ) then
if InsideRect( Inner => Window( ThisWindow ).content,
Outer => Window( OverWindow ).frame ) then
-- contents inside covering window? no need to redraw
-- any more than the exposed frame
Amount( ThisWindow ) := frame;
else
-- contents not entirely inside the covering window?
-- more than frame obscured->redraw whole window
Amount( ThisWindow ) := whole;
end if;
First2Redo := ThisWindow;
end if;
end loop;
end loop;
Amount( CurrentWindow ) := whole;
-- always (actually, this is always the top window in the current
-- version of this package and we've already set the top window
-- to redraw)
-- Redraw visible windows
WaitToReveal;
ResetUserIO;
for ThisWindow in First2Redo..NextWindow-1 loop
if Amount( ThisWindow ) /= none then
DrawWindow( id => ThisWindow, Redraw => Amount( ThisWindow ) );
end if;
end loop;
Reveal;
RevealNow; -- just in case application called WaitToReveal too many
-- times
exception when others =>
DrawErrLn;
DrawErr( "RefreshDesktop RT exception" );
raise;
end RefreshDesktop;
procedure MoveWindow( id : AWindowNumber; dx, dy : integer ) is
pragma Unreferenced (Id);
-- Move (as if it was dragged by a mouse) to a new location. No part
-- of the window may be moved off the screen. Does not erase or redraw
-- the window.
ct : AControlTable renames Window( CurrentWindow ).table;
begin
NoError;
if Window( CurrentWindow ).HasFrame then
if not insideRect( OffsetRect( Window( CurrentWindow ).Frame, dx, dy ), Window( 1 ).Content ) then
Error( TT_ParamError );
return;
end if;
elsif not insideRect( OffsetRect( Window( CurrentWindow ).Content, dx, dy ), Window( 1 ).Content ) then
Error( TT_ParamError );
return;
end if;
for i in 1..ct.size loop
Move( ct.control(i).ptr.all, dx, dy );
end loop;
if Window( CurrentWindow ).HasFrame then
OffsetRect( Window( CurrentWindow ).frame, dx, dy );
end if;
OffsetRect( Window( CurrentWindow ).content, dx , dy );
if Window( CurrentWindow ).HasInfoBar then
OffsetRect( Window( CurrentWindow ).InfoBar, dx, dy );
end if;
exception when others =>
DrawErrLn;
DrawErr( "MoveWindow RT exception" );
raise;
end MoveWindow;
procedure MoveWindow( dx, dy : integer ) is
begin
MoveWindow( CurrentWindow, dx, dy );
end MoveWindow;
procedure ScrollWindow( id : AWindowNumber; dx, dy : integer ) is
-- Scroll (move all the controls) in a window. Fixed controls are
-- not moved. Does not erase or redraw the window.
ct : AControlTable renames Window( CurrentWindow ).table;
begin
NoError;
for i in 1..ct.size loop
if CanScroll( ct.control(i).ptr.all ) then
Move( ct.control(i).ptr.all, dx, dy );
end if;
end loop;
window( id ).xscroll := window( id ).xscroll + dx;
window( id ).yscroll := window( id ).yscroll + dy;
exception when others =>
DrawErrLn;
DrawErr( "ScrollWindow RT exception" );
raise;
end ScrollWindow;
procedure ScrollWindow( dx, dy : integer ) is
begin
ScrollWindow( CurrentWindow, dx, dy );
end ScrollWindow;
function OpenWindow( title : in string ; l, t, r, b : integer;
Style : AWindowStyle := Normal;
HasInfoBar : boolean := false;
CallBack : AWindowDrawingCallBack := null )
return AWindowNumber is
-- Create a new, empty window and draws it. Returns an ID
-- number for the window.
id : AWindowNumber;
begin
NoError;
id := 1;
if NextWindow > 0 then
GetPenPos( Window( CurrentWindow ).SaveX,
Window( CurrentWindow ).SaveY ); -- remember cursor position
id := NextWindow;
CurrentWindow := id;
if NextWindow = AWindowNumber'Last then
NextWindow := 0;
else
NextWindow := NextWindow + 1;
end if;
SetRect( Window( id ).Frame, l, t, r, b );
SetRect( Window( id ).Content, l+1, t+1, r-1, b-1 );
Window( id ).Relative := false;
Window( id ).HasFrame := true;
Window( id ).FrameColour := Outline;
Window( id ).title := To_Unbounded_String (Title);
Window( id ).HasInfoBar := HasInfoBar;
Window( id ).InfoText := Null_Unbounded_String;
Window( id ).Style := Style;
Window( id ).Timeout := -1.0;
Window( id ).Loaded := false;
Window( id ).XScroll := 0;
Window( id ).YScroll := 0;
if HasInfoBar then
SetRect( Window( id ).InfoBar, l+1, b-1, r-1, b-1 );
SetRect( Window( id ).Content, l+1, t+1, r-1, b-2 );
end if;
Window( id ).ParentFile := null_unbounded_string;
InitControlTable( Window( id ).table );
Window( id ).DrawCB := CallBack;
DrawWindow( id, Redraw => whole );
else
Error( TT_WindowExistance );
end if;
return id;
exception when others =>
DrawErr( "OpenWindow RT exception" );
DrawErrLn;
raise;
end OpenWindow;
procedure OpenWindow( title : in string ; l, t, r, b : integer;
Style : AWindowStyle := Normal;
HasInfoBar : boolean := false;
CallBack : AWindowDrawingCallBack := null ) is
DiscardedId : AWindowNumber;
pragma Unreferenced (Discardedid);
begin
DiscardedId := OpenWindow( title, l, t, r, b, Style, HasInfoBar,
CallBack );
end OpenWindow;
procedure SaveWindow( path : string; arch : APathName := "") is
-- save a window to a text file so that it can be loaded later by
-- LoadWindow
-- NOTE: BROKEN RIGHT NOW
f : file_type; -- text file for saving window
cw : AWindow renames Window( CurrentWindow );
estr : EncodedString; -- for writing to text file
procedure SaveWindowDetails is
-- save window info
begin
estr := Null_Unbounded_String;
Encode( estr, To_String (Cw.Title) );
Put_Line( f, To_String( estr ) );
estr := Null_Unbounded_String;
--Encode( estr, cw.HasFrame ); -- this is calculated by window type
Encode( estr, cw.Relative );
Put_Line( f, To_String( estr ) );
estr := Null_Unbounded_String;
Encode( estr, cw.Frame );
Encode( estr, cw.Content );
Encode( estr, cw.HasInfoBar );
if cw.HasInfoBar then
Encode( estr, cw.InfoBar );
end if;
Encode( estr, Integer( AWindowStyle'pos( cw.Style ) ) );
Encode( estr, Integer( cw.Table.size ) );
Put_Line( f, To_String( estr ) );
estr := Null_Unbounded_String;
Encode( estr, To_String (Cw.SoundPath) );
Put_Line( f, To_String( estr ) );
estr := Null_Unbounded_String;
Encode( estr, To_String (Cw.SongPath) );
Put_Line( f, To_String( estr ) );
estr := Null_Unbounded_String;
--Encode( estr, cw.Timeout );
--Encode( estr, Integer( cw.TimeoutControl ) );
Put_Line( f, To_String( estr ) );
estr := Null_Unbounded_String;
Encode( estr, To_String (Cw.ParentFile) );
Put_Line( f, To_String( estr ) );
-- ignore info text
end SaveWindowDetails;
procedure SaveWindowControls is
-- save individual controls in the current window
ctr : AControlTableRecord;
ec : EncodedString;
begin
for i in 1..cw.Table.Size loop
ctr := cw.table.control(i);
estr := Null_Unbounded_String;
estr := Encode( ctr.ptr.all );
Put_line( f, To_String( ec ) );
end loop;
end SaveWindowControls;
begin
NoError;
Open( f, out_file, Expandpath (Path));
SaveWindowDetails;
SaveWindowControls;
if Arch'length > 0 then
Archive (Arch, Path);
Delete (F);
else
Close (F);
end if;
exception
when others =>
if Is_Open (F) then
Close (F);
end if;
DrawErr( "SaveWindow RT exception" );
DrawErrLn;
raise;
end SaveWindow;
procedure LoadWindow( path : string; arch : APathName := "") is
-- Load a window previously saved with SaveWindow.
f : file_type; -- for reading text file
estr : EncodedString; -- encoded information
procedure SetupWindow is
-- read title & frame & open the window
NewTitle : Unbounded_String;
NewFrame : ARect;
Relative : boolean;
begin
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
Decode( estr, NewTitle );
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
Decode( estr, Relative );
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
Decode( estr, NewFrame );
OpenWindow( To_String (NewTitle),
NewFrame.left, NewFrame.top, NewFrame.right, NewFrame.bottom );
Window( CurrentWindow ).Loaded := true;
Window( CurrentWindow ).Relative := Relative;
end SetupWindow;
procedure FillInWindow is
-- fill in window details after the window has been opened
cw : AWindow renames Window( CurrentWindow );
TempInt : integer;
begin
Decode( estr, cw.Content );
Decode( estr, cw.HasInfoBar );
if cw.HasInfoBar then
Decode( estr, cw.InfoBar );
end if;
Decode( estr, Tempint );
cw.Style := AWindowStyle'val( TempInt );
Decode( estr, TempInt );
cw.Table.Size := AControlNumber( TempInt );
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
Decode( estr, cw.SoundPath );
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
Decode( estr, cw.SongPath );
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
--Decode( estr, cw.Timeout );
--Decode( estr, TempInt );
cw.TimeoutControl := AControlNumber( TempInt );
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
Decode( estr, cw.ParentFile );
-- ignore info text
end FillInWindow;
procedure FillInControls is
-- allocate, initialize and setup the window's controls
ct : AControlTable renames Window( CurrentWindow ).Table;
--TempInt : integer;
begin
for i in 1..ct.Size loop
Estr := Ada.Text_IO.Unbounded_IO.Get_Line (f);
--Decode( estr, ct.control(i).ptr ); -- this is wrong
raise program_error; -- so don't do it
end loop;
end FillInControls;
begin
NoError;
if Arch'Length > 0 then
Extract( path, arch );
end if;
if LastError = TT_OK then
Open( f, in_file, path );
SetupWindow;
FillInWindow;
FillInControls;
DrawWindow( CurrentWindow, Redraw => Whole );
Close( f );
end if;
exception when others =>
DrawErr( "LoadWindow RT exception" );
DrawErrLn;
raise;
end LoadWindow;
procedure CloseWindow is
-- Delete a window and its controls. Entire desktop is redrawn.
procedure ClearControls is
ct : AControlTable renames Window( CurrentWindow ).table;
begin
for i in 1..ct.size loop
--Finalize will do this: was Clear( ct.control(i).ptr.all );
if Window( CurrentWindow ).Loaded then
Free( ct.control(i).ptr );
end if;
end loop;
end ClearControls;
begin
NoError;
if NextWindow > 2 then -- never close main window
ClearControls;
--EraseRect( Window( CurrentWindow ).Frame ); -- necessary?
if NextWindow = 0 then
NextWindow := AWindowNumber'last;
else
NextWindow := NextWindow - 1;
end if;
if CurrentWindow = NextWindow then -- if top window
CurrentWindow := CurrentWindow - 1;
end if;
RefreshDesktop;
MoveToGlobal( Window( CurrentWindow).SaveX,
Window( CurrentWindow).SaveY );
else
Error( TT_WindowExistance );
end if;
exception when others =>
DrawErr( "CloseWindow RT exception" );
DrawErrLn;
raise;
end CloseWindow;
---> Standard Alerts
procedure NoteAlert( message : string ) is
-- Show an informational message in a window with an OK button.
DT : ADialogTaskRecord;
OK : aliased ASimpleButton;
text : aliased AStaticLine;
pragma Unreferenced (Ok, Text);
CenterX : integer;
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( s_Note, CenterX-30, 10, CenterX+30, 16, Status );
SharedButton( Shared.Button1, 27, 4, 32, 4, 'o', s_OK );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
Beep( Status );
DoDialog( DT );
pragma Unreferenced (Dt);
CloseWindow;
exception when others =>
DrawErr( "NoteAlert NT exception" );
DrawErrLn;
raise;
end NoteAlert;
procedure CautionAlert( message : string ) is
-- Show a warning message in a window with an OK button.
DT : ADialogTaskRecord;
CenterX : integer;
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( s_Caution, CenterX-30, 10, CenterX+30, 16, Warning );
SharedButton( Shared.Button1, 27, 4, 32, 4, 'o', s_OK );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
SetStyle( AStaticLine( Shared.Text.all ), Status );
SessionLog( s_Caution & ": " & message );
Beep( Warning );
DoDialog( DT );
pragma Unreferenced (Dt);
CloseWindow;
exception when others =>
DrawErrLn;
DrawErr( "CautionAlert RT exception" );
raise;
end CautionAlert;
procedure StopAlert( message : string ) is
-- Show an error message in a window with an OK button.
DT : ADialogTaskRecord;
CenterX : integer;
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( s_Warning, CenterX-30, 10, CenterX+30, 16, Danger );
SharedButton( Shared.Button1, 27, 4, 32, 4, 'o', s_OK );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
SetStyle( AStaticLine( Shared.text.all ), Failure );
SessionLog( s_Warning & ": " & message );
Beep( Warning );
DoDialog( DT );
pragma Unreferenced (Dt);
CloseWindow;
exception when others =>
DrawErrLn;
DrawErr( "StopAlert RT exception" );
raise;
end StopAlert;
function YesAlert( message : string; kind : BeepStyles ) return boolean is
DT : ADialogTaskRecord;
CenterX : integer;
-- Ask the user a yes/no question, default "yes", in a caution window.
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( "", CenterX-30, 10 , CenterX+30, 16 );
SharedButton( Shared.Button1, 22, 4, 28, 4, 'y', s_yes );
SharedButton( Shared.Button2, 32, 4, 37, 4, 'n', s_no );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
if kind = Failure then
SetStyle( AStaticLine( Shared.Text.all ), Failure );
elsif kind = Warning then
SetStyle( AStaticLine( Shared.Text.all ), Warning );
end if;
Beep( kind );
DoDialog( DT );
CloseWindow;
return DT.control = 1;
exception when others =>
DrawErrLn;
DrawErr( "YesAlert RT exception" );
raise;
end YesAlert;
function NoAlert( message : string; kind : BeepStyles ) return boolean is
DT : ADialogTaskRecord;
CenterX : integer;
-- Ask the user a yes/no question, default "no", in a caution window.
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( "", CenterX-30, 10, CenterX+30, 16, Warning );
SharedButton( Shared.Button1, 22, 4, 27, 4, 'n', s_no );
SharedButton( Shared.Button2, 32, 4, 38, 4, 'y', s_yes );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
if kind = Failure then
SetStyle( AStaticLine( Shared.Text.all ), Failure );
elsif kind = Warning then
SetStyle( AStaticLine( Shared.Text.all ), Warning );
end if;
Beep( kind );
DoDialog( DT );
CloseWindow;
return DT.control = 1;
exception when others =>
DrawErrLn;
DrawErr( "NoAlert RT exception" );
raise;
end NoAlert;
function CancelAlert( message, OKCaption : string; kind : BeepStyles )
return boolean is
DT : ADialogTaskRecord;
CenterX : integer;
-- Ask the user a yes/cancel question, default "cancel", in the kind
-- of window indicated by "kind".
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( "", CenterX-30, 10, CenterX+30, 16 );
SharedButton( Shared.Button1, 19, 4, 27, 4, 'o', OKCaption);
SharedButton( Shared.Button2, 32, 4, 41, 4, 'c', s_cancel );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
if kind = Failure then
SetStyle( AStaticLine( Shared.Text.all ), Failure );
elsif kind = Warning then
SetStyle( AStaticLine( Shared.Text.all ), Warning );
end if;
Beep( kind );
DoDialog( DT );
CloseWindow;
return DT.control = 1;
exception when others =>
DrawErrLn;
DrawErr( "CancelAlert RT exception" );
raise;
end CancelAlert;
function YesCancelAlert( message : string; kind : BeepStyles )
return AControlNumber is
DT : ADialogTaskRecord;
CenterX : integer;
-- Ask the user a yes/no/cancel question, default "cancel", in the kind
-- of window indicated by "kind".
begin
NoError;
CenterX := Window( 1 ).content.right / 2;
OpenWindow( "", CenterX-30, 10, CenterX+30, 16 );
SharedButton( Shared.Button1, 15, 4, 21, 4, 'y', s_yes );
SharedButton( Shared.Button2, 27, 4, 32, 4, 'n', s_no );
SharedButton( Shared.Button3, 37, 4, 47, 4, 'c', s_cancel );
SharedLine( Shared.Text, 1, 2, 58, 2, message );
if kind = Failure then
SetStyle( AStaticLine( Shared.Text.all ), Failure );
elsif kind = Warning then
SetStyle( AStaticLine( Shared.Text.all ), Warning );
end if;
Beep( kind );
DoDialog( DT );
CloseWindow;
return DT.control;
exception when others =>
DrawErrLn;
DrawErr( "YesCancelAlert RT exception" );
raise;
end YesCancelAlert;
procedure ValidateFilename( desc : in out AValidateFilenameRec ) is
-- Check and correct a filename
OriginalFilename : constant String := To_String (desc.Filename); -- filename originally to be validated
ValidFilename : Unbounded_String; -- corrected filename from os.ValidateFilename
ErrMsg : unbounded_string; -- error message returned from os.VF
begin
loop
ValidateFilename (UNIXFS, To_String (Desc.Filename), ValidFilename, ErrMsg );
exit when length( ErrMsg ) = 0;
if YesAlert( "Bad filename since " & To_String( ErrMsg ) &
"; fix it?", warning ) then
desc.filename := ValidFilename;
else
desc.replied := false;
exit;
end if;
end loop;
if not desc.replied then
desc.filename := To_Unbounded_String (OriginalFilename);
end if;
end ValidateFilename;
procedure SelectOpenFile( sofrec : in out ASelectOpenFileRec ) is
FileList: StrList.vector; -- list of files in current directory
BoolList: BooleanList.Vector; -- for selection
ListBox : AControlPtr; --aliased ARadioList; -- for lists
OpenButton : AControlPtr; --aliased ASimpleButton;
CloseButton : AControlPtr; --aliased ASimpleButton;
CancelButton : AControlPtr; --aliased ASimpleButton;
AcceptButton : AControlPtr; --aliased ASimpleButton;
HomesButton : AControlPtr; --aliased ASimpleButton;
PathLine : AControlPtr; --aliased AStaticLine;
PromptLine : AControlPtr; --aliased AStaticLine;
--ListBar : aliased AScrollBar;
Hit : AControlNumber; -- window control hit (DoDialog)
DT : ADialogTaskRecord;
Item : Natural; -- file/home selected by user
ShowingHomes : boolean; -- true if showing homes, not files
OriginalPath : constant String := Ada.Directories.Current_Directory;
procedure GetDirectoryCheckList is
begin
Filelist.Clear;
Boollist.Clear;
GetDirectory (FileList, Ada.Directories.Current_Directory);
for i in 1 .. FileList.Length loop
BoolList.Append (false );
end loop;
SetList( ARadioList( ListBox.all ), FileList );
SetChecks( ARadioList( ListBox.all ), BoolList );
end GetDirectoryCheckList;
procedure GetHomes is
-- get list of drives/homes/etc & install in ListBox
-- FileList and BoolList should be emptied first
File : File_Type;
begin
-- Should be modified with LANG=C
-- And tested.
Boollist.Clear;
Create (File, In_File, ""); -- temp file
UNIX( "df | cut -c57-80 > " & Name (File));
Loadlist (File, Filelist);
Delete (File);
FileList.Delete_Last;
FileList.Append ("Home");
for i in 1 .. Filelist.Length loop
BoolList.Append (false );
end loop;
SetList( ARadioList( ListBox.all ), FileList );
SetChecks( ARadioList( ListBox.all ), BoolList );
exception
when others =>
if Is_Open (File) then
Delete (File);
end if;
end GetHomes;
procedure HandleSetPathErrors is
begin
if LastError = TT_SystemError then
StopAlert( "You can't access that folder" );
elsif LastError /= 0 then
StopAlert( "Can't move to that folder" );
end if;
end HandleSetPathErrors;
begin
NoError;
OpenWindow ("", 5, 4, 60, 17 );
ListBox := new ARadioList;
Init( ARadioList( ListBox.all ), 1, 4, 40, 12 );
AddControl( ListBox, IsGlobal => false );
OpenButton := new ASimpleButton;
Init( ASimpleButton( OpenButton.all ), 42, 4, 51, 4, 'o' ); -- 2 = open
SetText( ASimpleButton( OpenButton.all ), "Open");
AddControl( OpenButton, IsGlobal => false );
AcceptButton := new ASimpleButton;
Init( ASimpleButton( AcceptButton.all ), 42, 5, 51, 5, 'a' );
SetText( ASimpleButton( AcceptButton.all ), "Accept"); -- 3 = accept
AddControl( AcceptButton, IsGlobal => false );
if not sofrec.Direct then
SetStatus( AcceptButton.all, Off );
end if;
CloseButton := new ASimpleButton;
Init( ASimpleButton( CloseButton.all ), 42, 6, 51, 6, 'c' ); -- 4 = close
SetText( ASimpleButton( CloseButton.all ), "Close");
AddControl( CloseButton, IsGlobal => false );
HomesButton := new ASimpleButton;
Init( ASimpleButton( HomesButton.all ), 42, 7, 51, 7, 'h' ); -- 5 = homes
SetText( ASimpleButton( HomesButton.all ), "Homes");
AddControl( HomesButton, IsGlobal => false );
CancelButton := new ASimpleButton;
Init( ASimpleButton( CancelButton.all ), 42, 9, 51, 9, 'l' );
SetText( ASimpleButton( CancelButton.all ), s_cancel );
AddControl( CancelButton, IsGlobal => false );
PromptLine := new AStaticLine;
Init( AStaticLine( PromptLine.all ), 1, 1, 51, 1 );
SetText( AStaticLine( PromptLine.all ), To_String (Sofrec.Prompt));
SetStyle( AStaticLine( PromptLine.all ), Heading );
AddControl( PromptLine, IsGlobal => false );
PathLine := new AStaticLine;
Init( AStaticLine( PathLine.all ), 1, 3, 51, 3 );
SetText( AStaticLine( PathLine.all ), "Path?");
AddControl( PathLine, IsGlobal => false );
--Init( ListBar, 26, 4, 26, 10 );
--AddControl( ScrollBar, ListBar'access, IsGlobal => false );
-- setup
ShowingHomes := false;
GetDirectoryCheckList;
--SetMax( ListBar, filelist.length);
--SetThumb( ListBar, 1 );
loop
if ShowingHomes then
SetText( AStaticLine( PathLine.all ), "Homes:");
else
SetText( AStaticLine( PathLine.all ), Ada.Directories.Current_Directory);
end if;
DoDialog( DT );
hit := DT.control; -- do dialog
item := GetCheck( ARadioList( ListBox.all ) ); -- get list item
sofrec.Fname := To_Unbounded_String (FileList.Element (Item)); -- extract it
Filelist.Clear; -- blow away lists
BooleanList.Clear( BoolList );
case hit is
when 2 => -- open
if ShowingHomes then
ShowingHomes := false;
SetStatus( CloseButton.all, Standby );
if item = 1 then -- home directory
sofrec.fname := To_Unbounded_String (ExpandPath ("$HOME"));
end if;
end if;
if IsDirectory (To_String (Sofrec.Fname)) then
SetPath (To_String (Sofrec.Fname));
HandleSetPathErrors;
GetDirectoryCheckList;
else
sofrec.path := To_Unbounded_String (Ada.Directories.Current_Directory);
sofrec.replied := true;
exit;
end if;
when 3 => -- accept
sofrec.path := To_Unbounded_String (Ada.Directories.Current_Directory);
sofrec.replied := true;
exit;
when 4 => -- close
Ada.Directories.Set_Directory ("..");
HandleSetPathErrors;
GetDirectoryCheckList;
when 5 => -- homes
GetHomes;
ShowingHomes := true;
SetStatus( CloseButton.all, Off );
when 6 => -- cancel
sofrec.replied := false;
Ada.Directories.Set_Directory (OriginalPath);
exit;
when others =>
StopAlert( "SelectOpenFile: Unknown Window Control" );
end case;
end loop;
CloseWindow;
exception when others =>
DrawErrLn;
DrawErr( "SelectOpenFile RT exception" );
raise;
end SelectOpenFile;
procedure SelectSaveFile( ssfrec : in out ASelectSaveFileRec ) is
FileList: StrList.Vector; -- list of files in current directory
BoolList: BooleanList.Vector; -- for selection
ListBox : AControlPtr; --aliased ARadioList; -- for lists
NameLine : AControlPtr; --aliased AnEditLine; -- file name
SaveButton : AControlPtr; --aliased ASimpleButton;
OpenButton : AControlPtr; --aliased ASimpleButton;
CloseButton : AControlPtr; --aliased ASimpleButton;
CancelButton : AControlPtr; --aliased ASimpleButton;
HomesButton : AControlPtr; --aliased ASimpleButton;
PathLine : AControlPtr; --aliased AStaticLine;
PromptLine : AControlPtr; --aliased AStaticLine;
--ListBar : aliased AScrollBar;
Hit : AControlNumber; -- window control hit (DoDialog)
DT : ADialogTaskRecord;
Item : Natural; -- file/home selected by user
ShowingHomes : boolean; -- true if showing homes, not files
OriginalPath : constant String := Ada.Directories.Current_Directory;
procedure GetDirectoryCheckList is
begin
Filelist.Clear;
BoolList.Clear;
GetDirectory (FileList, Ada.Directories.Current_Directory);
for i in 1 .. filelist.length loop
BoolList.Append (false );
end loop;
SetList( ARadioList( ListBox.all ), FileList );
SetChecks( ARadioList( ListBox.all ), BoolList );
end GetDirectoryCheckList;
procedure GetHomes is
-- get list of drives/homes/etc & install in ListBox
-- FileList and BoolList should be emptied first
File : File_Type;
begin
-- Should be modified with LANG=C
-- And tested.
Boollist.Clear;
Create (File, In_File, ""); -- temp file
UNIX( "df | cut -c57-80 > " & Name (File));
Loadlist (File, Filelist);
Delete (File);
FileList.Delete_Last;
FileList.Append ("Home");
for i in 1 .. Filelist.Length loop
BoolList.Append (false );
end loop;
SetList( ARadioList( ListBox.all ), FileList );
SetChecks( ARadioList( ListBox.all ), BoolList );
exception
when others =>
if Is_Open (File) then
Delete (File);
end if;
end GetHomes;
begin
NoError;
OpenWindow ("", 5, 4, 60, 18 );
ListBox := new ARadioList;
Init( ARadioList( ListBox.all ), 1, 4, 40, 12 );
AddControl( ListBox, IsGlobal => false );
NameLine := new AnEditLine;
Init( AnEditLine( NameLine.all ), 1, 13, 51, 13 );
SetText( AnEditLine(NameLine.all), To_String (Ssfrec.Default));
AddControl( NameLine, IsGlobal => false );
OpenButton := new ASimpleButton;
Init( ASimpleButton( OpenButton.all ), 42, 4, 51, 4, 'o' ); -- 3 = open
SetText( ASimpleButton( OpenButton.all ), "Open");
AddControl( OpenButton, IsGlobal => false );
SaveButton := new ASimpleButton;
Init( ASimpleButton( SaveButton.all ), 42, 5, 51, 5, 's' ); -- 4 = save
SetText( ASimpleButton( SaveButton.all ), "Save");
AddControl( SaveButton, IsGlobal => false );
CloseButton := new ASimpleButton;
Init( ASimpleButton( CloseButton.all ), 42, 6, 51, 6, 'c' ); -- 5 = close
SetText( ASimpleButton( CloseButton.all ), "Close");
AddControl( CloseButton, IsGlobal => false );
HomesButton := new ASimpleButton;
Init( ASimpleButton( HomesButton.all ), 42, 7, 51, 7, 'h' ); -- 6 = homes
SetText( ASimpleButton( HomesButton.all ), "Homes");
AddControl( HomesButton, IsGlobal => false );
CancelButton := new ASimpleButton;
Init( ASimpleButton( CancelButton.all ), 42, 9, 51, 9, s_cancel_Hot );
SetText( ASimpleButton( CancelButton.all ), s_cancel );
AddControl( CancelButton, IsGlobal => false );
PromptLine := new AStaticLine;
Init( AStaticLine( PromptLine.all ), 1, 1, 51, 1 );
SetText( AStaticLine( PromptLine.all ), To_String (Ssfrec.Prompt));
SetStyle( AStaticLine( PromptLine.all ), Heading );
AddControl( PromptLine, IsGlobal => false );
PathLine := new AStaticLine;
Init( AStaticLine( PathLine.all ), 1, 3, 51, 3 );
SetText( AStaticLine( PathLine.all ), "Path?");
AddControl( PathLine, IsGlobal => false );
--Init( ListBar, 26, 4, 26, 10 );
--AddControl( ScrollBar, ListBar, IsGlobal => false );
-- setup
ShowingHomes := false;
GetDirectoryCheckList;
--SetMax( ListBar, filelist.length);
--SetThumb( ListBar, 1 );
loop
if ShowingHomes then
SetText( AStaticLine( PathLine.all ), "Homes:");
else
SetText( AStaticLIne( PathLine.all ), Ada.Directories.Current_Directory);
end if;
DoDialog( DT );
hit := DT.control; -- do dialog
item := GetCheck( ARadioList( ListBox.all ) ); -- get list item
ssfrec.Fname := To_Unbounded_String (FileList.Element (Item)); -- extract it
Filelist.Clear; -- blow away lists
BooleanList.Clear( BoolList );
case hit is
when 3 => -- open
if ShowingHomes then
ShowingHomes := false;
SetStatus( CloseButton.all, Standby );
SetStatus( SaveButton.all, Standby );
DrawControls;
if item = 1 then -- home directory
ssfrec.fname := To_Unbounded_String (ExpandPath ("$HOME"));
end if;
end if;
--TmpStr := Append( To255("test -d "), To_String( ssfrec.fname ));
--if UNIX( TmpStr ) then --directory?
if Isdirectory (To_String (Ssfrec.Fname)) then
begin
SetPath (ExpandPath (To_String (Ssfrec.Fname)));
exception
when Ada.IO_Exceptions.Name_Error | Ada.IO_Exceptions.Use_Error =>
StopAlert( "You can't access that folder" );
end;
GetDirectoryCheckList;
else
StopAlert( "This isn't a folder" );
end if;
when 4 => -- save
ssfrec.path := To_Unbounded_String (Ada.Directories.Current_Directory);
ssfrec.fname := To_Unbounded_String (GetText( AnEditLine( NameLine.all ) ));
if ssfrec.fname = Null_Unbounded_String then
CautionAlert( "What's the file name?" );
else
if NotEmpty (To_String (Ssfrec.Fname)) then
if not NoAlert( "Overwrite this file? ", Warning ) then
ssfrec.replied := true;
exit;
end if;
else
ssfrec.replied := true;
exit;
end if;
end if;
GetDirectoryCheckList;
when 5 => -- close
begin
Ada.Directories.Set_Directory ("..");
exception
when Ada.IO_Exceptions.Name_Error | Ada.IO_Exceptions.Use_Error =>
StopAlert( "You can't access that folder" );
end;
GetDirectoryCheckList;
when 6 => -- homes
GetHomes;
ShowingHomes := true;
SetStatus( ASimpleButton( CloseButton.all ), Off );
SetStatus( ASimpleButton( SaveButton.all ), Off );
when 7 => -- cancel
ssfrec.replied := false;
Ada.Directories.Set_Directory (OriginalPath);
exit;
when others =>
StopAlert( "SelectSaveFile: Unknown Window Control" );
end case;
end loop;
CloseWindow;
exception when others =>
DrawErrLn;
DrawErr( "SelectSaveFile RT exception" );
raise;
end SelectSaveFile;
procedure ShowListInfo( title : string;
t : integer;
lst : in out Strlist.Vector;
last : boolean := false;
longLines : LongLineHandling := none ) is
-- display a list for the user to view; list isn't cleared. List is full-
-- screen except with the top of the window at t.
begin
ShowListInfo( title, 0, t, DisplayInfo.H_Res-1, DisplayInfo.V_Res-1, lst, last, none );
end ShowListInfo;
procedure ShowListInfo( title : string;
l, t, r, b : integer;
lst : in out Strlist.Vector;
last : boolean := false;
longLines : LongLineHandling := none ) is
-- display a list for the user to view; list isn't cleared
TheList : aliased AStaticList;
TheScrollBar : aliased AScrollBar;
OKButton : aliased ASimpleButton;
DT : ADialogTaskRecord;
CenterX : integer;
begin
OpenWindow( title, l, t, r, b, Normal, false );
CenterX := Window( currentWindow ).content.right / 2;
Init( TheList, 1, 1, r-3, b-3 );
SetList( TheList, lst );
AddControl( TheList'unchecked_access, IsGlobal => False );
if longLines = wrap then
WrapText( TheList );
elsif longLines = justify then
JustifyText( TheList, r-3-1 );
end if;
Init( TheScrollBar, r-2, 1, r-2, b-3 );
AddControl( TheScrollBar'unchecked_access, IsGlobal => False );
Init( OKButton, CenterX-3, b-2, CenterX+3, b-2, 'o' );
SetText( OKButton, s_OK );
AddControl( OKButton'unchecked_access, IsGlobal => False );
SetScrollBar( TheList, 2 );
SetMax( TheScrollBar, Natural (lst.length) );
SetOwner( TheScrollBar, 1 );
if last then
SetThumb( TheScrollBar, Natural (Lst.Length));
MoveCursor( TheList, 0, Natural (Lst.Length) - 1);
end if;
DoDialog( DT );
pragma Unreferenced (Dt);
CloseWindow;
end ShowListInfo;
procedure EditListInfo( title : string;
t : integer;
lst : in out Strlist.Vector;
result : out boolean;
last : boolean := false ) is
begin
EditListInfo( title, 0, t, DisplayInfo.H_Res-1, DisplayInfo.V_Res-1, lst,
result, last );
end EditListInfo;
procedure EditListInfo( title : string;
l, t, r, b : integer;
lst : in out Strlist.vector;
result : out boolean;
last : boolean := false) is
-- display a list for the user to view; list isn't cleared
ssf : ASelectSaveFileRec;
ListHeader : Strlist.Vector;
TheList : aliased AnEditList;
TheScrollBar : aliased AScrollBar;
OKButton : aliased ASimpleButton;
CancelButton : aliased ASimpleButton;
SaveButton : aliased ASimpleButton;
EmailButton : aliased ASimpleButton;
PrintButton : aliased ASimpleButton;
DT : ADialogTaskRecord;
procedure EmailText is
PipeID : AStdioFileID;
Result : Integer;
WhoLabel : aliased AStaticLine;
WhoLine : aliased AnEditLine;
SubjectLabel : aliased AStaticLine;
SubjectLine : aliased AnEditLine;
OKButton : aliased ASimpleButton;
DT : ADialogTaskRecord;
procedure Process (Position : in Strlist.Cursor);
procedure Process (Position : in Strlist.Cursor) is
begin
Result := fputs( Strlist.Element (Position) & ASCII.CR & ASCII.LF & ASCII.NUL,
PipeID );
pragma Assert (Result >= 0);
end Process;
begin
OpenWindow( "Person & Subject", 2, 2, 30, 8, normal, false );
Init( WhoLabel, 1, 2, 3, 2 );
SetText( WhoLabel, "To:" );
AddControl( WhoLabel'unchecked_access, IsGlobal => false );
Init( WhoLine, 4, 2, 26, 2 );
AddControl( WhoLine'unchecked_access, IsGlobal => false );
Init( SubjectLabel, 1, 3, 3, 3 );
SetText( SubjectLabel, "Re:" );
AddControl( SubjectLabel'unchecked_access, IsGlobal => false );
Init( SubjectLine, 4, 3, 26, 3 );
AddControl( SubjectLine'unchecked_access, IsGlobal => false );
Init( OKButton, 12, 5, 18, 5, s_OK_Hot );
SetText( OKButton, s_OK );
AddControl( OKButton'unchecked_access, IsGlobal => false );
DoDialog( DT );
declare
Who2Mail : constant String := GetText (WhoLine);
Subject : Unbounded_String := To_Unbounded_String (GetText (SubjectLine));
begin
CloseWindow;
if Who2Mail'Length = 0 then
SessionLog( "EmailText: no recipient specified" );
return;
end if;
if Length (Subject) = 0 then
Subject := To_Unbounded_String ("No Subject");
end if;
PipeID := popen( "mail -s " &
"'" & To_String (Subject) & "' " & Who2Mail & ASCII.NUL,
"w" & ASCII.NUL);
end;
ListHeader := GetList( TheList ); -- get list header (so don't clear)
Listheader.Iterate (Process'Access);
pclose( Result, PipeID );
pragma Assert (Result = 0);
SessionLog( "EmailText: Email sent" );
end EmailText;
procedure PrintText is
PipeID : AStdioFileID;
Result : integer;
procedure Process (Position : in Strlist.Cursor);
procedure Process (Position : in Strlist.Cursor) is
begin
Result := fputs( Strlist.Element (Position) & ASCII.CR & ASCII.LF & ASCII.NUL,
PipeID );
pragma Assert (Result >= 0);
end Process;
begin
PipeID := popen( "lpr" & ASCII.NUL, "w" & ASCII.NUL);
ListHeader := GetList( TheList ); -- get list header (so don't clear)
Listheader.Iterate (Process'Access);
Result := fputc( character'pos( ASCII.FF ), PipeID );
pragma Assert (Result >= 0);
pclose( Result, PipeID );
pragma Assert (Result /= -1);
SessionLog( "PrintText: Printing spooled" );
end PrintText;
begin
OpenWindow( Title, l, t, r, b, normal, true );
Init( TheList, 1, 1, r-4, b-4 );
SetList( TheList, lst );
AddControl( TheList'unchecked_access, IsGlobal => false );
Init( TheScrollBar, r-3, 1, r-3, b-4 );
AddControl( TheScrollBar'unchecked_access, IsGlobal => false );
Init( OKButton, 2, b-3, 15, b-3, 'o' );
SetText( OKButton, s_OK );
SetInfo( OKButton, "Accept with any changes");
AddControl( OKButton'unchecked_access, IsGlobal => false );
Init( CancelButton, 16, b-3, 30, b-3, 'l' );
SetText( CancelButton, s_Cancel );
SetInfo( CancelButton, "Discard any changes");
AddControl( CancelButton'unchecked_access, IsGlobal => false );
Init( SaveButton, 31, b-3, 45, b-3, s_Save_Hot );
SetText( SaveButton, s_Save );
SetInfo( SaveButton, "Save to a file and continue making changes");
AddControl( SaveButton'unchecked_access, IsGlobal => false );
Init( EmailButton, 46, b-3, 60, b-3, 'e' );
SetText( EmailButton, "Email" );
SetInfo( EmailButton, "Email this to someone");
AddControl( EmailButton'unchecked_access, IsGlobal => false );
Init( PrintButton, 61, b-3, 75, b-3, 'p' );
SetText( PrintButton, "Print" );
SetInfo( PrintButton, "Print this");
AddControl( PrintButton'unchecked_access, IsGlobal => false );
SetScrollBar( TheList, 2 );
SetMax( TheScrollBar, Natural (lst.Length));
SetOwner( TheScrollBar, 1 );
if last then
SetThumb( TheScrollBar, Natural (Lst.Length));
SetCursor( TheList, 1, Natural (lst.length));
end if;
-- doesn't work for X Windows
--if not IsLocal then
-- SetStatus( SaveButton, Off );
--end if;
loop
DoDialog( DT );
if DT.control = 3 then
ListHeader := GetList( TheList ); -- get list header (so don't clear)
Lst.Clear; -- erase old list
Lst := ListHeader;
exit;
elsif DT.control = 5 then
ssf.prompt := To_Unbounded_String ("Save as ...");
ssf.default := To_Unbounded_String ("untitled.txt");
SelectSaveFile( ssf );
if ssf.replied then
ListHeader := GetList( TheList );
SaveList (To_String (Ssf.Path) & "/" & To_String (Ssf.Fname), ListHeader );
end if;
elsif DT.control = 6 then
EmailText;
elsif DT.control = 7 then
PrintText;
else
exit;
end if;
end loop;
CloseWindow;
result := DT.control = 3;
end EditListInfo;
--- Housekeeping
procedure StartupWindows is
procedure InitializeSharedControls is
-- allocate the controls to be shared by dialogs/alerts in this package
begin
Shared.Button1 := new ASimpleButton;
Shared.Button2 := new ASimpleButton;
Shared.Button3 := new ASimpleButton;
Shared.Text := new AStaticLine;
if Shared.Text = Null then
SessionLog( "StartupWindows: Error allocating shared controls" );
end if;
end InitializeSharedControls;
begin
NoError;
if PackageRunning then
SessionLog( "StartupWindows: Windows package is already running" );
return;
end if;
GetDisplayInfo( DisplayInfo ); -- NoError implied
SessionLog( "StartupWindows: DisplayInfo.H_Res = " & DisplayInfo.H_Res'img );
SessionLog( "StartupWindows: DisplayInfo.V_Res = " & DisplayInfo.V_Res'img );
NextWindow := 2;
CurrentWindow := 1;
SessionLog( "StartupWindows: Setting up global window" );
Window( CurrentWindow ).HasFrame := false;
Window( CurrentWindow ).Relative := false;
Window( CurrentWindow ).Title := Null_Unbounded_String;
Window( CurrentWindow ).ParentFile := Null_Unbounded_String;
Window( CurrentWindow ).Style := Frameless;
SetRect( Window( CurrentWindow ).Frame, 0, 0, DisplayInfo.H_Res-1,
DisplayInfo.V_Res-1 );
SetRect( Window( CurrentWindow ).Content, 0, 0, DisplayInfo.H_Res-1,
DisplayInfo.V_Res-1 );
SessionLog( "StartupWindows: Setting up global window control table" );
InitControlTable( Window( CurrentWindow ).table );
Clipboard := null;
SessionLog( "StartupWindows: Drawing global window" );
DrawWindow;
SessionLog( "StartupWindows: Initialing Shared Controls" );
InitializeSharedControls;
SessionLog( "StartupWindows: Done Window Startup" );
end StartupWindows;
procedure IdleWindows( IdlePeriod : in Duration ) is
pragma Unreferenced (Idleperiod);
begin
NoError;
end IdleWindows;
procedure ShutdownWindows is
procedure ClearSharedControls is
begin
Finalize( Shared.Button1.all );
Finalize( Shared.Button2.all );
Finalize( Shared.Button3.all );
Finalize( Shared.Text.all );
end ClearSharedControls;
begin
NoError;
if PackageRunning then
ClearSharedControls;
PackageRunning := false;
end if;
notepaddata.Clear;
end ShutdownWindows;
procedure ShellOut( cmd : string) is
BackgroundSave : boolean;
begin
NoError;
BackgroundSave := IsBlueBackground;
Sessionlog( "ShellOut: - " & cmd );
ShutdownUserIO;
UNIX( cmd );
StartupUserIO;
if IsBlueBackground /= BackgroundSave then
BlueBackground( BackgroundSave );
end if;
RefreshDesktop;
end ShellOut;
end windows;
texttools/src/os.ads 0000664 0000764 0000764 00000025723 11774715706 013202 0 ustar ken ken ------------------------------------------------------------------------------
-- OS --
-- --
-- Part of TextTools --
-- Designed and Programmed by Ken O. Burtch --
-- --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 Ken O. Burtch --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with common; use common;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO;
pragma Elaborate( common ); -- remind Ada that common elaborates first
package os is
---> Housekeeping
procedure StartupOS;
pragma export( CPP, StartupOS, "startup_os" );
-- StartupOS initializes the OS package. This must be the first subprogram
-- executed in the OS package.
-- Errors: none
procedure IdleOS( IdlePeriod : in Duration );
-- IdleOS executes idle time tasks when the user's computer is idle.
-- Errors: none
procedure ShutDownOS;
pragma export( CPP, ShutdownOS, "shutdown_os" );
-- ShutDownOS shuts down the OS package. This must be the final subprogram
-- executed in the OS package.
-- Errors: none
---> File Systems
--
-- This is a list of the file systems recognized (or someday recognized)
-- by the OS package.
--
-- UNIX - 255 character UNIX
-- UNIX 14 - 14 character UNIX
-- DOSFS - 8.3 character DOS
-- OS/2 - 255 character OS2
-- NONE - no file system
type AFileSystem is (UNIXFS, UNIX14FS, DOSFS, OS2FS, NONE);
pragma convention( C, AFileSystem );
---> Pathnames
--
-- A pathname is just a string.
--
-- Path aliases are shortforms. Predefined are
-- $tmp = Temporary Directory (eg. /tmp/ )
-- $sys = User's System Directory ( eg /home/bob/appname )
-- $home = User's Home Directory ( eg /home/bob )
subtype APathName is string;
---> O/S Shell Interface
--
-- These invoke system() with the specified command. Except for the
-- boolean function, all others return CoreSystemError if the command
-- failed (ie. returned a bad status). All return CoreParamError if
-- the string is can't be converted to a C String for the call.
function UNIX( s : String ) return boolean; -- shell string, return status
procedure UNIX( s : String ); -- shell string
function UNIX( s : string ) return String; -- shell string, return output
-- UNIX executes a UNIX shell command. The boolean function version returns
-- true if there were no errors. The String version returns the (first)
-- string that results from executing the command.
-- Errors: TT_SystemError - the shell command errored
-- TT_ParamError - the command string was too long to handle
procedure RunIt( cmd : string;
parm1, parm2, parm3 : string := "";
Results : out StrList.Vector );
-- Execute command, return results in "results" and exit status in
-- status.
---> File System Calls
procedure ValidateFilename
(Fs : in AFileSystem;
Oldfn : in APathname;
Newfn : out Unbounded_String;
Errmsg : out Unbounded_String);
-- ValidateFilename verifies that a pathname is syntactically correct
-- for the specified file system. If the filename is unacceptable,
-- the reason is outlined in errmsg and a legal filename with the
-- problem characters removed is returned. (The new filename typically
-- has underscores in place of illegal characters.) If the filename is
-- acceptable, errmsg is empty.
-- Errors: none
procedure ValidatePathname( fs : in AFileSystem;
oldfn : in APathname;
newfn : out unbounded_string;
errmsg : out unbounded_string);
-- Like ValidateFilename, but validates a path
-- GetEnvironment( TheList : Str255List.List );
-- GetEnvironmentVariable( Variable : str255 ) return str255;
---> File Utility Calls
type AFileUsage is (None, ReadOnly, Normal, Run);
pragma Convention( C, AFileUsage );
function NotEmpty( s : APathName ) return boolean;
-- NotEmpty is true if the specified file has a length greater than zero.
-- Errors: CoreParamError - the path is too long to be handled
-- KB: should return other disk errors
function IsDirectory( s : APathName ) return boolean;
-- IsDirectory is true if the pathname specifies a directory.
-- Errors: none
function IsFile( s : APathName ) return boolean;
-- IsFile is true if the pathname specifies a readable, existing file.
-- Errors: none
function Lock( file : APathName ) return boolean;
-- NOT YET WRITTEN
-- Locks a file for your private use.
-- Errors: none
procedure Unlock( file : APathName ); --unlocks a file
procedure Erase (File : in String); --deletes a file with path expansion.
procedure Trash( file : APathname ); --file to trash can
procedure EmptyTrash; --empties the trash can
procedure Move( file1, file2 : APathName ); --moves a file
function Shrink( file : APathName ) return APathName; --compress a file
function Expand( file : APathName ) return APathName; --uncompress a file
procedure Archive( arch, file : APathName ); --add a file to an archive
procedure Extract( arch, file : APathName ); --remove a file from archive
procedure Usage( file : APathName; me : AFileUsage := Normal;
us : AFileUsage := ReadOnly;
everyone : AFileUsage := ReadOnly );
---> Caching Control
procedure BeginSession;
procedure EndSession;
---> Basic Directory Utilities
function SpaceUsed( dir : APathName ) return integer;
-- bytes in and under dir, as with `du -sf` * blocksize
---> Device Utilities
-- None of these functions is implemented.
-- function SpaceFree( dev : APathName ) return long_integer;
-- -- bytes free in device
-- function TotalSpace( dev : APathName ) return long_integer;
-- -- total bytes on device
-- function EntriesFree( dev : APathName ) return long_integer;
-- -- inodes free on device
-- function TotalEntries( dev : APathName ) return long_integer;
-- -- total inodes on device
-- function OnDevice( path : APathName ) return APathName;
---> Host Utilities
function GetFreeClusterHost return string;
-- GetFreeClusterHost returns the name of a free (ie. low activity)
-- machine from the current computer cluster network. If there is no
-- cluster, the name of the current computer is returned.
-- Security considerations: what does this mean for remote windows?
-- Errors: none
---> StrList files
procedure LoadList( Path : in APathName; StringList : out StrList.Vector);
procedure SaveList( Path : in APathName; StringList : in StrList.Vector);
procedure savelist (File : in Ada.Text_IO.File_Type;
StringList : in Strlist.Vector);
procedure loadlist (File : in Ada.Text_IO.File_Type;
StringList : out Strlist.Vector);
---> Processes
function IsLocal return boolean;
-- true if user is local to server
---> Paths
--
-- A path can't be an object because it's used multiple times in
-- parameter lists; gnat to balk on dispatching even when there is
-- no dispatching.
type APathType is (unknown, file, http, ftp, window, Run);
pragma Convention( C, APathType );
-- How about a variant record?
procedure SetPath( s : APathName );
-- change current path
-- Same than Ada.Directories.Set_Directory, except that it calls ExpandPath
procedure PathAlias( alias : string; path : APathName );
-- PathAlias defines an alias for TextTools pathnames. There are no checks
-- to see if the alias is a legitimate path.
-- Errors: storage exception if out of memory
procedure DecomposePath( path : APathname; PathType : out APathType;
Host : out Unbounded_String; filepath : out Unbounded_String);
-- DecomposePath takes a path or URL and separates it into it's three
-- components: the type of access, the computer address, and the path.
-- Unknown URL's are returned as type "unknown". There are no checks
-- to see if the Lintel URL is accessible. The path is expanded before
-- it's decomposed.
-- Note: ftp login not supported yet--can we?
-- Errors: none
function ExpandPath( path : in APathName ) return APathName;
-- ExpandPath returns the path with any path aliases replaced with
-- the prefix they represent. There are no checks to see if the
-- resulting path is legitimate.
-- For example, if the alias "$TMP" is defined as "/usr/tmp", then
-- ExpandPath would return "/usr/tmp/file" if the path is "$TMP/file".
-- Errors: none
procedure SplitPath( path : in String;
dir : out unbounded_string; file : out unbounded_string );
-- SplitPath splits off the trailing file in a path, the one after
-- the last slash. This routine has not been updated for aliases
-- or URL's (yet).
-- Errors: none
---> Calander Functions
--
-- ATimeStamp is defined in common.
type ATime is record
seconds : long_integer;
microseconds : long_integer;
end record;
type ATimeZone is record
minutes : integer; -- minutes west of Greenwich
savings : integer; -- additional daylight savings minutes
end record;
---> Text File
procedure AddFile( file, text : in string );
---> Logging
procedure SessionLog( Message : in string );
procedure SessionLog( Message : in string;
ErrorCode : in AnErrorCode );
end os;
texttools/src/controls.ads 0000664 0000764 0000764 00000120600 11774715706 014412 0 ustar ken ken ------------------------------------------------------------------------------
-- CONTROLS - Texttools control (widget) definitions --
-- --
-- Developed by Ken O. Burtch --
------------------------------------------------------------------------------
-- --
-- Copyright (C) 1999-2007 PegaSoft Canada --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with this; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- This is maintained at http://www.pegasoft.ca/tt.html --
-- --
------------------------------------------------------------------------------
with common; use common;
pragma Elaborate( common ); -- remind Ada that Common elaborates first
with strings; use strings;
with userio; use userio;
with Ada.Finalization;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package controls is
-- For Source Edit Lists
type aSourceLanguage is ( unknownLanguage, Ada_Language, C, CPP, Java, Bush,
Perl, PHP, HTML, Shell );
pragma convention(C, aSourceLanguage);
-- LANGUAGE DATA
--
-- This record contains all the information for a language, such as lists
-- of keywords and functions as used by TIA.
--
-- The data is stored in linked lists sorted by language and alphabetic bins
--
-- Some of the data is compressed to save memory.
------------------------------------------------------------------------------
type stringPtr is access all string;
type packedStringPtr is access all packed_string;
type ACommentStyle is (None, AdaStyle, ShellStyle, CStyle, HTMLStyle, PHPStyle);
pragma convention( C, ACommentStyle );
subtype aBinIndex is character range '@'..'Z';
type functionData;
type functionDataPtr is access functionData;
type functionData is record
functionName : stringPtr;
functionInfo : packedStringPtr;
functionProto: packedstringPtr;
next : functionDataPtr;
end record;
type functionArray is array( aBinIndex'range ) of functionDataptr;
type keywordData;
type keywordDataPtr is access keywordData;
type keywordData is record
keywordName : stringPtr;
keywordInfo : packedStringPtr;
keywordProto : packedstringPtr;
next : keywordDataPtr;
end record;
type keywordArray is array( aBinIndex'range ) of keywordDataptr;
type languageDataRecord is record
caseSensitive : boolean := false;
commentStyle : aCommentStyle;
functionCount : natural := 0;
functionBin : functionArray;
keywordCount : natural := 0;
keywordBin : keywordArray;
end record;
type languageDataArray is array( aSourcelanguage'range ) of
languageDataRecord;
type languageDataPtr is access all languageDataArray;
procedure init( languageData : in out languageDataArray );
function in_bin( s : string ) return aBinIndex;
function findFunctionData( languageData : languageDataArray; funcLang : aSourceLanguage; s : string ) return functionDataPtr;
function findKeywordData( languageData : languageDataArray; funcLang : aSourceLanguage; s : string ) return keywordDataPtr;
---> Housekeeping
procedure StartupControls;
procedure IdleControls( IdlePeriod : in Duration );
procedure ShutdownControls;
---> Window Control Definitions
--
-- A control is an object in a window that performs input/output.
-- RootControl is the elementary pseudo-control. All controls
-- inherit a frame, internal cursor location, a hot key, and a status.
-- There is also a NeedsRedrawing flag which indicates if the control
-- dirty.
--
-- Controls must support the following subprograms:
-- 1. a Hear procedure which handles input and determines how
-- the dialog manager should respond (go to next control, etc.).
-- 2. a Draw procedure to draw the control. (Draw should take into
-- account the NeedsRedrawing flag, need not save colour/styles.)
-- 3. an Init procedure to setup the frame, hot key (if any) and to
-- initialize any defaults. (the constructor)
-- 4. Encode/Decode to save control info to a file.
-- 5. SetStatus for activating the control, etc.
-- 6. a Clear procedure to shutdown the control (and deallocate any
-- memory). (the destructor)
--
-- All controls inherit:
-- 1. an Invalid procedure to force a control to be redrawn (usually
-- when obscured by an overlapping window).
-- 2. GetStatus to return the control's status.
-- 3. a NeedsRedrawing function to reutnr the NeedsRedrawing flag.
-- 4. Free, the unchecked deallocation procedure.
-- ...and a few others. See RootControl below.
--
-- Dialog Actions:
-- None - Remain on this control
-- Next - Go to next control
-- Back - Go to control before this one
-- ScanNext - Forward to next control with key as hotkey
-- (the usual result for a key with no meaning for control)
-- Up - move up to next control
-- Down - move down to next control
-- Left - move left to next control
-- Right - move right to next control
-- Complete - this control completes a dialog (simple buttons)
-- FollowLink - follow the link; open a new subwindow
-- Fix Family - turn off/redraw the radio button's family members
type ADialogAction is (None, Next, Back, ScanNext, Up, Down, Left, Right,
Complete, FollowLink, FixFamily);
pragma convention( C, ADialogAction );
-- Control Status:
-- Off - control will never be selected
-- Standby - control not currently selected
-- On - control selected and is accepting input
type AControlStatus is (Off, Standby, On);
---> Control Numbers
--
-- Maximum number of controls is AControlNumber'Last; 0 = no control #
type AControlNumber is new short_integer range 0..63;
---> Control Definitions
--
-- RootControl, the elementary pseudo-control
--
-- GetHotKey - return hot key for this control (or NullKey)
-- SetInfo - set info bar text for this control
-- GetInfo - return same
-- HasInfo - true if info bar text was assigned
type RootControl is abstract tagged private;
type AControlPtr is access all RootControl'class;
procedure Init( c : in out RootControl; left,top,right,bottom : integer;
HotKey : character );
procedure Finalize( c : in out RootControl );
procedure Hear( c : in out RootControl; i : AnInputRecord; d : in out
ADialogAction );
procedure Move( c : in out RootControl'class; dx, dy : integer );
procedure Resize( c : in out RootControl; dleft, dtop, dright, dbottom : integer);
procedure Draw( c : in out RootControl );
procedure SetStatus( c : in out RootControl; status : AControlStatus);
function GetStatus( c : in RootControl'class ) return AControlStatus;
function Encode( c : in RootControl ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out RootControl );
procedure Invalid( c : in out RootControl'class );
function NeedsRedrawing( c : RootControl'class ) return boolean;
pragma Inline( NeedsRedrawing );
function GetHotKey( c : in RootControl'class ) return character;
pragma Inline( GetHotKey );
procedure SetInfo( c : in out RootControl'class; text : in string );
function GetInfo( c : in RootControl'class ) return String;
function HasInfo( c : in RootControl'class ) return boolean;
procedure GetStickyness( c : in RootControl'class; left, top, right, bottom
: in out boolean );
procedure SetStickyness( c : in out RootControl'class; left, top, right, bottom
: boolean );
function InControl( c : in RootControl'class; x, y : integer ) return boolean;
function GetFrame( c : in RootControl'class ) return ARect;
procedure Scrollable( c : in out RootControl'class; b : boolean );
function CanScroll( c : in RootControl'class ) return boolean;
procedure Free( cp : in out AControlPtr );
---> General Classes
--
-- All controls fall into one of two classes:
--
-- Iconic Controls: controls that represent information or another
-- (auto) window (if a link is provided)
-- (eg. a picture, a static line)
--
-- Gnat 2.03 bug: Compiler overlaps link with first variable in
-- derived class, so links don't work!
--
-- Window Controls: controls that change the environment of the current
-- window; controls whose value can be edited/changed
-- (eg. a checkbox, an edit list )
--
Type ANullControl is new RootControl with private;
type AnIconicControl is new RootControl with private;
type AnIconicControlPtr is access all AnIconicControl'class;
procedure Init( c : in out AnIconicControl; left, top,
right, bottom : integer; HotKey : character );
procedure Finalize( c : in out AnIconicControl );
procedure Draw( c : in out AnIconicControl );
-- Hear is inherited.
procedure SetStatus( c : in out AnIconicControl; status : AControlStatus );
procedure Resize( c : in out AnIconicControl; dleft, dtop, dright,
dbottom : integer );
function Encode( c : in AnIconicControl ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AnIconicControl );
procedure SetLink( c : in out AnIconicControl'class; link : in String );
function GetLink( c : in AnIconicControl'class ) return String;
procedure SetCloseBeforeFollow( c : in out AnIconicControl'class;
close : boolean := true );
function GetCloseBeforeFollow( c : in AnIconicControl'class ) return boolean;
type AWindowControl is new RootControl with private;
type AWindowControlPtr is access all AWindowControl'class;
procedure Init( c : in out AWindowControl; left, top,
right, bottom : integer; HotKey : character );
procedure Finalize( c : in out AWindowControl );
procedure Draw( c : in out AWindowControl );
-- Hear is inherited.
procedure SetStatus( c : in out AWindowControl; status : AControlStatus );
procedure Resize( c : in out AWindowControl; dleft, dtop, dright, dbottom
: integer );
function Encode( c : in AWindowControl ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AWindowControl );
---> Thermometers
--
-- SetMax - indicated the value associated with 100%
-- GetMax - return same
-- SetValue - set the thermometer value (0..Max)
-- GetValue - return same
type AThermometer is new AWindowControl with private;
procedure Init( c : in out AThermometer; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out AThermometer );
procedure Hear( c : in out AThermometer; i : AnInputRecord; d : in out ADialogAction);
procedure Draw( c : in out AThermometer );
procedure Resize( c : in out AThermometer; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out AThermometer; status : AControlStatus);
function Encode( c : in AThermometer ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AThermometer );
function GetMax( c : in AThermometer ) return integer;
function GetValue( c : in AThermometer ) return integer;
procedure SetMax( c : in out AThermometer; max : in integer );
procedure SetValue( c : in out AThermometer; value : in Integer );
---> Scroll Bars
--
-- SetMax - set the value associated with the end of the bar
-- GetMax - return same
-- SetThumb - set the position of the thumb (0...Max)
-- GetThumb - return same
-- SetOwner - indicate the list control associated with this bar
-- GetOwner - return same
type AScrollBar is new AWindowControl with private;
procedure Init( c : in out AScrollBar; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out AScrollBar );
procedure Hear( c : in out AScrollBar; i:AnInputRecord; d : in out ADialogAction);
procedure Draw( c : in out AScrollBar );
procedure Resize( c : in out AScrollBar; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out AScrollBar; status : AControlStatus);
function Encode( c : in AScrollBar ) return EncodedString;
procedure Decode( estr : in out EncodedString ; c : in out AScrollBar );
function GetMax( c : in AScrollBar ) return integer;
function GetThumb( c : in AScrollBar ) return integer;
procedure SetMax( c : in out AScrollBar; max : in integer );
procedure SetThumb( c : in out AScrollBar; thumb : in integer );
procedure SetOwner( c : in out AScrollBar; owner : AControlNumber );
function GetOwner( c : in AScrollBar ) return AControlNumber;
---> Static Lines
--
-- SetText - set the text of the line
-- GetText - return the text of the line
-- SetStyle - set the print text of the line
-- GetStyle - return the print text of the line
type AStaticLine is new AnIconicControl with private;
procedure Init( c : in out AStaticLine; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out AStaticLine );
procedure Hear( c : in out AStaticLine; i:AnInputRecord; d:in out ADialogAction );
procedure Draw( c : in out AStaticLine );
procedure Resize( c : in out AStaticLine; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out AStaticLine; status : AControlStatus);
function Encode( c : in AStaticLine ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AStaticLine );
function GetText( c : in AStaticLine ) return String;
procedure SetText( c : in out AStaticLine; text : in string );
function GetStyle( c : in AStaticLine ) return ATextStyle;
procedure SetStyle( c : in out AStaticLine; style : ATextStyle );
function GetColour( c : in AStaticLine ) return APenColourName;
procedure SetColour( c : in out AStaticLine; colour : APenColourName );
---> Edit Lines, elementary edit line
--
-- SetText - set the text of the edit line
-- GetText - return the text of the edit line
-- SetAdvanceMode - enable/disable auto advance when line is full
-- GetAdvanceMode - return auto advance setting
type AnEditLine is new AWindowControl with private; -- should be a class
type SomeEditLine is access all AnEditLine'class;
procedure Finalize( c : in out AnEditLine'class );
procedure Init( c : in out AnEditLine; left,top,right,bottom : integer;
Max : natural := 0; HotKey : character := NullKey );
procedure Hear( c : in out AnEditLine; i : AnInputRecord; d : in out ADialogAction );
procedure Draw( c : in out AnEditLine );
procedure Resize( c : in out AnEditLine'class; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out AnEditLine; status : AControlStatus);
function Encode( c : in AnEditLine ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AnEditLine );
function GetText( c : in AnEditLine'class ) return String;
procedure SetText( c : in out AnEditLine'class; text : in String);
function GetAdvanceMode( c : in AnEditLine'class ) return boolean;
procedure SetAdvanceMode( c : in out AnEditLine'class; mode : boolean );
function GetBlindMode( c : in AnEditLine'class ) return boolean;
procedure SetBlindMode( c : in out AnEditLine'class; mode : boolean );
function GetMaxLength( c : in AnEditLine'class ) return integer;
procedure SetMaxLength( c : in out AnEditLine'class; MaxLength : integer );
---> Integer Edit Lines
--
type AnIntegerEditLine is new AnEditLine with private;
procedure Init( c : in out AnIntegerEditLine; left,top,right,bottom : integer;
Max : natural := 0; HotKey : character := NullKey );
procedure Hear( c : in out AnIntegerEditLine; i : AnInputRecord;
d : in out ADialogAction );
procedure Draw( c : in out AnIntegerEditLine );
procedure SetStatus( c : in out AnIntegerEditLine; status : AControlStatus);
function Encode( c : in AnIntegerEditLine ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AnIntegerEditLine );
procedure SetValue( c : in out AnIntegerEditLine; value : integer );
function GetValue( c : in AnIntegerEditLine ) return integer;
---> Long Integer Edit Lines
--
type ALongIntEditLine is new AnEditLine with private;
procedure Init( c : in out ALongIntEditLine;
left,top,right,bottom : integer; Max : natural := 0;
HotKey : character := NullKey );
procedure Hear( c : in out ALongIntEditLine; i : AnInputRecord;
d : in out ADialogAction );
procedure Draw( c : in out ALongIntEditLine );
procedure SetStatus( c : in out ALongIntEditLine; status : AControlStatus);
function Encode( c : in ALongIntEditLine ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out ALongIntEditLine );
procedure SetValue( c : in out ALongIntEditLine; value : in long_integer );
function GetValue( c : in ALongIntEditLine ) return long_integer;
---> Float Edit Lines
--
type AFloatEditLine is new AnEditLine with private;
procedure Init( c : in out AFloatEditLine; left,top,right,bottom : integer;
Max : natural := 0; HotKey : character := NullKey );
procedure Hear( c : in out AFloatEditLine; i : AnInputRecord;
d : in out ADialogAction );
procedure Draw( c : in out AFloatEditLine );
procedure SetStatus( c : in out AFloatEditLine; status : AControlStatus);
-- function Encode( c : in AFloatEditLine ) return EncodedString;
-- procedure Decode( estr : in out EncodedString; c : in out AFloatEditLine );
procedure SetValue( c : in out AFloatEditLine; value : float );
function GetValue( c : in AFloatEditLine ) return float;
---> Check Boxes
--
-- SetText - set the button's message
-- GetText - return the button's message
-- SetCheck - check/uncheck the button
-- GetCheck - return the button's check
type ACheckBox is new AWindowControl with private;
procedure Init( c : in out ACheckBox; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ACheckBox );
procedure Hear( c : in out ACheckBox; i : AnInputRecord; d : in out ADialogAction );
procedure Draw( c : in out ACheckBox );
procedure Resize( c : in out ACheckBox; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out ACheckBox; status : AControlStatus);
function Encode( c : in ACheckBox ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out ACheckBox );
function GetText( c : in ACheckBox ) return String;
function GetCheck( c : in ACheckBox ) return boolean;
procedure SetText( c : in out ACheckBox; text : in String);
procedure SetCheck( c : in out ACheckBox; checked : boolean );
---> Radio Buttons
--
-- GetText - return the button's message
-- SetText - set the button's message
-- SetCheck - check/uncheck the radio button
-- GetCheck - return the button's check
-- GetFamily - the the family number of the radio button
type ARadioButton is new AWindowControl with private;
procedure Init( c : in out ARadioButton; left,top,right,bottom : integer;
family : integer := 0; HotKey : character := NullKey );
procedure Finalize( c : in out ARadioButton );
procedure Hear( c : in out ARadioButton; i : AnInputRecord; d : in out ADialogAction );
procedure Draw( c : in out ARadioButton );
procedure Resize( c : in out ARadioButton; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out ARadioButton; status : AControlStatus);
function Encode( c : in ARadioButton ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out ARadioButton );
function GetText( c : in ARadioButton ) return String;
function GetCheck( c : in ARadioButton ) return boolean;
function GetFamily( c : in ARadioButton ) return integer;
procedure SetText( c : in out ARadioButton; text : in String );
procedure SetCheck( c : in out ARadioButton; checked : boolean );
---> Simple Buttons
--
-- SetText - set the button's message
-- GetText - return the button's message
type ASimpleButton is new AWindowControl with private;
procedure Init( c : in out ASimpleButton; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ASimpleButton );
procedure Hear( c : in out ASimpleButton; i : AnInputRecord; d : in out ADialogAction );
procedure Draw( c : in out ASimpleButton );
procedure Resize( c : in out ASimpleButton; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out ASimpleButton; status : AControlStatus);
function Encode( c : in ASimpleButton ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out ASimpleButton );
function GetText( c : in ASimpleButton ) return String;
procedure SetText( c : in out ASimpleButton; text : in String );
function GetInstant( c : in ASimpleButton ) return boolean;
procedure SetInstant( c : in out ASimpleButton; instant : boolean := true );
function GetColour( c : in ASimpleButton ) return APenColourName;
procedure SetColour( c : in out ASimpleButton; colour : APenColourName );
---> Window Buttons
--
-- SetText - set the button's message
-- GetText - return the button's message
-- SetLink - set the path to the window associated with this button
-- GetLink - return the window path
type AWindowButton is new AnIconicControl with private;
procedure Init( c : in out AWindowButton; left, top, right, bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out AWindowButton );
procedure Hear( c : in out AWindowButton; i : AnInputRecord; d : in out
ADialogAction );
procedure Draw( c : in out AWindowButton );
procedure Resize( c : in out AWindowButton; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out AWindowButton; status : AControlStatus);
function Encode( c : in AWindowButton ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AWindowButton );
procedure SetText( c : in out AWindowButton; text : in String );
function GetText( c : in AWindowButton ) return String;
function GetInstant( c : in AWindowButton ) return boolean;
procedure SetInstant( c : in out AWindowButton; instant : boolean := true );
procedure SetControlHit( c : in out AWindowButton; chit : AControlNumber );
function GetControlHit( c : in AWindowButton ) return AControlNumber;
---> Rectangles
--
-- SetColours - set the foreground and background colours
-- GetColours - return the foreground and background colours
type ARectangle is new AnIconicControl with private;
procedure Init( c : in out ARectangle; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ARectangle );
procedure Hear( c : in out ARectangle; i : AnInputRecord; d : in out
ADialogAction );
procedure Draw( c : in out ARectangle );
procedure Resize( c : in out ARectangle; dleft, dtop, dright, dbottom :
integer );
procedure SetStatus( c : in out ARectangle; status : AControlStatus);
function Encode( c : in ARectangle ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out ARectangle );
procedure SetColours( c : in out ARectangle;
FrameColour, BackColour : APenColourName );
procedure GetColours( c : in ARectangle;
FrameColour, BackColour : in out APenColourName );
procedure SetText (C : in out ARectangle; Text : in String );
function GetText (C : in ARectangle) return String;
---> Lines
--
-- SetColour - select the colour of the line
-- GetColour - return the colour of the line
-- SetDrawDir - DownRight => line is drawn from top-left to bottom-right
-- of the control frame, else bottom-left to top-right.
-- GetDrawDir - return the drawing direction
type ALine is new AnIconicControl with private;
procedure Init( c : in out ALine'class; left, top, right, bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ALine'class );
procedure Hear( c : in out ALine'class; i : AnInputRecord; d : in out ADialogAction);
procedure Draw( c : in out ALine );
procedure Resize( c : in out ALine'class; dleft, dtop, dright, dbottom : integer );
procedure SetStatus( c : in out ALine'class; status : AControlStatus);
function Encode( c : in ALine'class ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out ALine'class );
procedure SetColour( c : in out ALine'class; Colour : APenColourName );
function GetColour( c : in ALine'class ) return APenColourName;
procedure SetDrawDir( c : in out ALine; DownRight : boolean );
function GetDrawDir( c : in ALine ) return boolean;
-- Section Separators
--
-- On Graphics Displays, centered in drawing grid appropriately
type AnHorizontalSep is new ALine with private;
procedure Draw( c : in out AnHorizontalSep );
type AVerticalSep is new ALine with private;
procedure Draw( c : in out AVerticalSep );
---> Static Lists, the elementary static list
--
-- Is the list the belongs to the control a pointer to a list, or
-- a copy of a list supplied by the programmer? A pointer makes it
-- handy to read the list, but offers no protection against failure
-- to inform the control to update. I'll compromise here: SetList
-- COPIES and GetList returns a pointer.
--
-- that it can't be copied by assignment.
-- SetList - install the text to display in the box
-- SetOrigin - change top line being displayed
-- GetList - return the list of text
-- GetOrigin - return the origin
-- GetCurrent - return line the cursor is on
-- GetPosition - return the position on the line
-- SetCursor - move the cursor to a specific place
-- GetLength - return number of lines
-- JustifyText - format text to fit within specified width
-- WrapText - wrap long lines
-- SetScrollBar - set the scroll bar (or thermometer) to be associated
-- with this list control
-- GetScrollBar - return the associated scroll bar (or 0)
type AStaticList is new AWindowControl with private;
type SomeListControl is access all AStaticList'class;
procedure Init( c : in out AStaticList; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out AStaticList );
procedure Hear( c : in out AStaticList; i : AnInputRecord; d : in out ADialogAction);
procedure Draw( c : in out AStaticList );
procedure Resize( c : in out AStaticList'class; dleft, dtop, dright, dbottom : integer );
procedure SetStatus( c : in out AStaticList'class; status : AControlStatus);
function Encode( c : in AStaticList'class ) return EncodedString;
procedure Decode( estr : in out EncodedString; c : in out AStaticList'class );
procedure SetList( c : in out AStaticList'class; list : in out StrList.Vector );
procedure SetOrigin( c : in out AStaticList'class; origin : Natural);
function GetList( c : in AStaticList'class ) return StrList.Vector;
function GetOrigin( c : in AStaticList'class ) return Natural;
function GetCurrent( c : in AStaticList'class ) return Natural ;
function GetLength( c : in AStaticList'class ) return Natural;
function GetPositionY( c : in AStaticList'class ) return integer;
procedure JustifyText( c : in out AStaticList;
width : integer;
startingAt : Natural := 0 );
procedure WrapText( c : in out AStaticList );
procedure MoveCursor( c : in out AStaticList'class; dx : integer;
dy : integer );
procedure SetScrollBar( c : in out AStaticList'class; bar : AControlNumber );
function GetScrollBar( c : in AStaticList'class ) return AControlNumber;
function CopyLine (c : in AStaticList'Class) return String;
-- copy line at current position
procedure PasteLine( c : in out AStaticList'class; text : in string );
procedure ReplaceLine( c : in out AStaticList'class; text : in string );
procedure FindText( c : in out AStaticList'class; str2find : in String;
Backwards, IsRegExp : boolean := false );
-- IsRegexp is actually ignored.
procedure ReplaceText( c : in out AStaticList'class; str2find,
str2repl : in String; Backwards, IsRegExp : boolean := false );
-- IsRegExp is assumed false, since no regexp support is implemented.
procedure SetFindPhrase( c : in out AStaticList'class; phrase : in string );
procedure SetMark( c : in out AStaticList'class; mark : integer );
function GetMark( c : in AStaticList'class ) return integer;
-- mark position. Use -1 to denote no mark set.
procedure CopyLines( c : in out AStaticList'class; mark2 : integer;
Lines : in out StrList.Vector );
-- copy lines between mark2 and mark set with SetMark
procedure PasteLines( c : in out AStaticList'class; Lines :
in out StrList.Vector );
---> Check Lists
--
-- SetChecks - install list of check boxes
-- GetChecks - return pointer to list of checks
type ACheckList is new AStaticList with private;
procedure Init( c : in out ACheckList; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ACheckList );
procedure Hear( c : in out ACheckList; i : AnInputRecord; d : in out ADialogAction);
procedure Draw( c : in out ACheckList );
procedure SetChecks( c : in out ACheckList; checks : in out BooleanList.Vector );
function GetChecks( c : in ACheckList ) return BooleanList.Vector;
---> Radio Lists
--
-- SetChecks - install list of radio button checks + first to check
-- GetChecks - return a pointer to the list of checks
-- GetCheck - return the number of the item checked
type ARadioList is new AStaticList with private;
procedure Init( c : in out ARadioList; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ARadioList );
procedure Hear( c : in out ARadioList; i : AnInputRecord; d : in out ADialogAction);
procedure Draw( c : in out ARadioList );
procedure SetChecks( c : in out ARadioList; checks : in out BooleanList.Vector;
Default : Natural := 1 );
function GetChecks( c : in ARadioList ) return BooleanList.Vector;
function GetCheck( c : in ARadioList ) return Natural;
---> Edit Lists
--
-- GetPosition - get horizontal position of cursor (left side = 1)
-- SetCursor - move the cursor to a specific position in the text
type AnEditList is new AStaticList with private;
procedure Init( c : in out AnEditList; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out AnEditList );
procedure Hear( c : in out AnEditList; i : AnInputRecord;
d : in out ADialogAction);
procedure Draw( c : in out AnEditList );
function GetPosition( c : in AnEditList'class ) return integer;
procedure SetCursor( c : in out AnEditList'class; x : integer;
y : Natural);
procedure JustifyText( c : in out AnEditList;
width : integer;
startingAt : Natural := 0 );
procedure Touch( c : in out AnEditList'class );
-- set touch flag to true
procedure ClearTouch( c : in out AnEditList'class );
-- set touch flag to false
function WasTouched( c : AnEditList'class ) return boolean;
-- true if Touch or received input. Used for saving
---> SOURCE EDIT LIST
--
-- For displaying source code with hilighted keywords. Provided for TIA.
type ASourceEditList is new AnEditList with private;
procedure Init( c : in out ASourceEditList; left,top,right,bottom : integer;
HotKey : character := NullKey );
procedure Finalize( c : in out ASourceEditList );
procedure Hear( c : in out ASourceEditList; i : AnInputRecord;
d : in out ADialogAction);
procedure Draw( c : in out ASourceEditList );
procedure JustifyText( c : in out ASourceEditList;
width : integer;
startingAt : Natural := 0 );
procedure SetHTMLTagsStyle( c : in out ASourceEditList; hilight : boolean );
-- choose to hilight html tags or not
procedure SetLanguageData( c : in out ASourceEditList; p : languageDataPtr );
procedure SetKeywordHilight( c : in out ASourceEditList; pcn : aPenColourName );
procedure SetFunctionHilight( c : in out ASourceEditList; pcn : aPenColourName );
procedure SetSourceLanguage( c : in out ASourceEditList; l : ASourceLanguage );
----> UNFINISHED CONTROLS
type AnHTMLBox is new AStaticList with private;
---> Pictures
--
-- Bit-mapped pictures. They can double as traditional icons using the
-- text description as the icon caption. APicture is a collection of
-- simple pictures optimized at different resolutions.
type ASimplePicture is new AnIconicControl with private;
type APicture is new ASimplePicture with private;
---> Scalable pictures
--
-- Traditional "draw" object composed of scalable geometric objects, like
-- lines, circles, rectangles, etc.
type ASketch is new AnIconicControl with private;
---> Animations
--
-- A collection of objects to be displayed through a sequence of states.
-- The objects can't be edited, hence an animation is iconic.
type AnAnimation is new AnIconicControl with private;
type ATreeList is new AStaticList with private; --dummy
PRIVATE
type RootControl is new Ada.Finalization.Controlled with record
Frame : ARect; -- frame surrounding control
Status : AControlStatus; -- Off / Standby / On
Name : unbounded_string; -- name of the control
StickLeft : boolean; -- frame.left should adhere to window's left
StickTop : boolean; -- frame.top should adhere to window's top
StickRight : boolean; -- frame.right should adhere to w's right
StickBottom : boolean; -- frame.top should adhere to w's bottom
CursorX : integer; -- cursor location
CursorY : integer;
Scrollable : boolean; -- true if ScrollWindow should ignore
NeedsRedrawing : boolean; -- true if needs redrawing
HotKey : character; -- key to jump to this item (else NullKey)
HasInfo : boolean; -- true if text is valid for info bar
InfoText : Unbounded_String; -- string to show in info bar if hilighted
end record;
type ANullControl is new RootControl with null record;
type AnIconicControl is new RootControl with record
link : Unbounded_String; -- link to another system-controlled window
CloseBeforeFollow : boolean; -- close before following link
end record;
type AWindowControl is new RootControl with null record;
type AThermometer is new AWindowControl with record
Max : integer; -- ranges 0..max
Value : integer; -- current value
end record;
type AScrollBar is new AWindowControl with record
Max : integer; -- ranges 0..Max
thumb : integer; -- current position
Owner : AControlNumber; -- related control (for window manager)
-- optimizations for text screen
DirtyThumb : boolean; -- true if only thumb needs redrawing
OldThumb : integer; -- old drawing position for thumb
end record;
type AStaticLine is new AnIconicControl with record
Text : Unbounded_String; -- text in the static line
Style : ATextStyle; -- the style of text (default normal)
Colour : APenColourName; -- colour of text
end record;
type AnEditLine is new AWindowControl with record -- should be a class
Text : Unbounded_String; -- text in the edit line
Max : natural; -- maximum number of characters (not impl. yet)
Origin : natural; -- offset for display if text is wider than box
AdvanceMode : boolean; -- auto-advance with last character?
BlindMode : boolean; -- true for blind text (eg. password entry)
MaxLength : integer; -- maximum number of characters
-- optimzations for text screen
DirtyText : boolean; -- if only text right of cursor needs drawing
end record;
type AnIntegerEditLine is new AnEditLine with record
value : integer;
end record;
type ALongIntEditLine is new AnEditLine with record
value : long_integer;
end record;
type AFloatEditLine is new AnEditLine with record
value : float;
end record;
type ACheckBox is new AWindowControl with record
Text : Unbounded_String; -- message of the button
Checked : boolean; -- true if button's checked
HotPos : natural;
end record;
type ARadioButton is new AWindowControl with record
Text : Unbounded_String; -- title
Checked : boolean; -- true if button is "on"
Family : integer; -- a number to associate families
HotPos : natural;
end record;
type ASimpleButton is new AWindowControl with record
Text : Unbounded_String; -- message of the button
Instant: boolean; -- true if an instant selection on ScanNext
HotPos : natural; -- position of hot key character
Colour : APenColourName;
end record;
type AWindowButton is new AnIconicControl with record
Text : Unbounded_String; -- message of the button
Instant: boolean; -- true if an instant selection on ScanNext
HotPos : natural; -- position of hot key character
chit : AControlNumber; -- what was hit
end record;
type ARectangle is new AnIconicControl with record
FrameColour : APenColourName; -- colour of the frame
BackColour : APenColourName; -- colour of the background
Text : unbounded_string;
end record;
type ALine is new AnIconicControl with record
Colour : APenColourName; -- colour of the line
DownRight : boolean; -- true if line goes from top-left to b-r
end record;
type AnHorizontalSep is new ALine with null record;
type AVerticalSep is new ALine with null record;
type AStaticList is new AWindowControl with record
List : aliased StrList.Vector; -- list of text
Origin : Natural; -- line # at top of box
ScrollBar : AControlNumber; -- reference value for window manager
Mark : integer; -- as set by set mark
FindPhrase : Unbounded_String := Null_Unbounded_String; -- for hilighting purposes
end record;
type ACheckList is new AStaticList with record
Checks : BooleanList.Vector; -- list of selections (if any)
end record;
type ARadioList is new AStaticList with record
Checks : BooleanList.Vector; -- list of selections (if any)
LastCheck : integer; -- last selection (else 0)
end record;
type AnEditList is new AStaticList with record
DirtyLine : boolean; -- if current line is dirty
Touched : boolean := false; -- true if received input
ForwardCharSearchMode : boolean := false; -- true if in mode
end record;
type ASourceEditList is new AnEditList with record
KeywordList : StrList.Vector;
HTMLTagStyle : boolean := false; -- true if hilighted
InsertedLines : integer; -- active insert block
InsertedFirst : Natural; -- start of active insert block
-- (if insertedLines /= 0)
sourceLanguage : aSourceLanguage := unknownLanguage;
keywordHilight : aPenColourName := yellow;
functionHilight : aPenColourName := purple;
languageData : languageDataPtr := null;
end record;
----> UNFINISHED CONTROLS
type AnHTMLBox is new AStaticList with record
null;
end record;
type ASimplePicture is new AnIconicControl with record
pic : APictureID; -- ID of the picture
path : unbounded_string; -- path of the picture
text : unbounded_string; -- description (if can't be displayed)
end record;
type APicture is new ASimplePicture with record
null; -- to be defined
end record;
type ASketch is new AnIconicControl with record
null;
end Record;
type AnAnimation is new AnIconicControl with record
X, Y : integer; -- actually, redundant with control pos'n
XVector, YVector : integer; -- motion offset information
Enabled : boolean; -- actually, redundant with status
Visible : boolean; -- actually, redundant with status
Index : short_integer; -- frame index
AniStatus : short_integer; -- grammer status
--Stack : AnAnimationStack; -- the animation grammar
end record;
type ATreeList is new AStaticList with null record; --dummy
end controls;
texttools/build-obj-static/ 0000775 0000764 0000764 00000000000 11774716122 014415 5 ustar ken ken texttools/Makefile 0000664 0000764 0000764 00000012474 11774715706 012740 0 ustar ken ken # Build script for Texttools.
# Copyright (c) 2003-2009 Ludovic Brenta
# Copyright (c) 2009-2012 Nicolas Boulenguez
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
########################
# Global configuration #
########################
LIB_NAME := texttools
SOVERSION := 1
################################
# Build and test configuration #
################################
# Use environment variables if available, this is common practice for
# CPPFLAGS, CFLAGS and LDFLAGS.
CFLAGS ?= -O2
ADAFLAGS ?= -O2
.NOTPARALLEL:
GNATMAKE_OPTIONS := -j$(shell getconf _NPROCESSORS_ONLN)
ifdef ALL_CHECKS
CFLAGS += -Wall -Wextra -Wformat -Wformat-security -g
ADAFLAGS += -Wall -Wextra -g -gnatE -gnatQ -gnatVa -gnata -gnatf \
-gnato -gnatq -gnatySdx -gnaty0 -gnatyM159 -gnatw.e -gnatwH
GNATMAKE_OPTIONS += -s -we
endif
# We want the same compiler for C and Ada sources.
CC := gnatgcc
LDLIBS := $(shell ncurses5-config --libs)
##############################
# Installation configuration #
##############################
# Each of the following path should be prefixed with
DESTDIR :=
# The sources files are installed into a LIB_NAME subdirectory of
SRC_DIR := usr/share/ada/adainclude
# A LIB_NAME.gpr project convenient for library usage is installed into
GPR_DIR := usr/share/ada/adainclude
# The content of this file ignores DESTDIR.
# The GNAT ALI files are installed into a LIB_NAME subdirectory of
ALI_DIR := usr/lib/ada/adalib
# The static and dynamic library are installed into
LIB_DIR := usr/lib
#########
# Rules #
#########
build: build-dynamic build-static
build-dynamic build-static: build-%: $(LIB_NAME).gpr
gnatmake -P$< $(GNATMAKE_OPTIONS) -XKIND=$*
clean::
rm -f $(foreach dir,obj lib,$(foreach kind,dynamic static,build-$(dir)-$(kind)/*))
clean::
find -name "*~" -delete
test: examples/examples.gpr build-static
gnatmake -P$< $(GNATMAKE_OPTIONS) -XKIND=static
# Texttools.gpr is found in the current directory when executing this
# recipe, and will be found in the default system location after
# installation.
clean:: examples/examples.gpr texttools.gpr
gnatclean -P$< -XKIND=static
rm -f $^
# We need to create them for gnatclean, then suppress it as the last action.
install: build
install --directory $(DESTDIR)/$(SRC_DIR)/$(LIB_NAME)
install --mode=644 src/*.ad[sb] src/*.[ch] $(DESTDIR)/$(SRC_DIR)/$(LIB_NAME)
install --directory $(DESTDIR)/$(GPR_DIR)
sed template_for_installed_project \
$(foreach var,LIB_NAME SRC_DIR ALI_DIR LDLIBS LIB_DIR, \
-e 's/$$($(var))/$(subst $(space),"$(comma) ",$($(var)))/g') \
> $(DESTDIR)/$(GPR_DIR)/$(LIB_NAME).gpr
chmod 644 $(DESTDIR)/$(GPR_DIR)/$(LIB_NAME).gpr
install --directory $(DESTDIR)/$(ALI_DIR)/$(LIB_NAME)
install --mode=444 build-lib-dynamic/*.ali $(DESTDIR)/$(ALI_DIR)/$(LIB_NAME)
install --directory $(DESTDIR)/$(LIB_DIR)
install --mode=644 build-lib-static/lib$(LIB_NAME).a $(DESTDIR)/$(LIB_DIR)
install --mode=644 build-lib-dynamic/lib$(LIB_NAME).so.$(SOVERSION) $(DESTDIR)/$(LIB_DIR)
cd $(DESTDIR)/$(LIB_DIR) && ln --force --symbolic lib$(LIB_NAME).so.$(SOVERSION) lib$(LIB_NAME).so
uninstall:
rm -rf $(DESTDIR)/$(SRC_DIR)/$(LIB_NAME)
rm -f $(DESTDIR)/$(GPR_DIR)/$(LIB_NAME).gpr
rm -rf $(DESTDIR)/$(ALI_DIR)/$(LIB_NAME)
rm -f $(DESTDIR)/$(LIB_DIR)/lib$(LIB_NAME).a
rm -f $(DESTDIR)/$(LIB_DIR)/lib$(LIB_NAME).so.$(SOVERSION)
rm -f $(DESTDIR)/$(LIB_DIR)/lib$(LIB_NAME).so
############################################################
# All that C stuff will be unnecessary with gprbuild’s mixed C/Ada
# project files. For the moment, gnatmake will embed all .o files,
# we only have to compile them and store them in the object dir.
C_SRC := $(wildcard src/*.c)
C_OBJ_DYNAMIC := $(patsubst src/%.c,build-obj-dynamic/%.o,$(C_SRC))
build-dynamic: $(C_OBJ_DYNAMIC)
$(C_OBJ_DYNAMIC): build-obj-dynamic/%.o: src/%.c
$(CC) -c $(CPPFLAGS) $(CFLAGS) $< -o $@ -fPIC
C_OBJ_STATIC := $(patsubst src/%.c,build-obj-static/%.o, $(C_SRC))
build-static: $(C_OBJ_STATIC)
$(C_OBJ_STATIC): build-obj-static/%.o: src/%.c
$(CC) -c $(CPPFLAGS) $(CFLAGS) $< -o $@
C_OBJ_TEST := $(patsubst src/%.c,examples/%.o, $(C_SRC))
test: $(C_OBJ_TEST)
$(C_OBJ_TEST): CFLAGS += -g -Wall -Wextra
$(C_OBJ_TEST): examples/%.o: src/%.c
$(CC) -c $(CPPFLAGS) $(CFLAGS) $< -o $@
clean::
rm -f $(C_OBJ_TEST)
# gnatmake 4.4 does not handle External_As_List, so we emulate it with
# a template instead of passing the options with -X.
comma := ,
empty :=
space := $(empty) $(empty)
texttools.gpr examples/examples.gpr: %.gpr: %.gpr.sed
sed $< \
$(foreach var,ADAFLAGS CFLAGS LDFLAGS LDLIBS SOVERSION, \
-e 's/$(var)/$(subst $(space),"$(comma) ",$($(var)))/') \
> $@
.PHONY: build build-dynamic build-static clean install test uninstall