--- /dev/null
+
+ Announcing ncurses 4.1
+
+ The ncurses (new curses) library is a freeware emulation of System V
+ Release 4.0 curses. It uses terminfo format, supports pads and color
+ and multiple highlights and forms characters and function-key mapping,
+ and has all the other SYSV-curses enhancements over BSD curses.
+
+ In mid-June 1995, the maintainer of 4.4BSD curses declared that he
+ considered 4.4BSD curses obsolete, and is encouraging the keepers of
+ Unix releases such as BSD/OS, freeBSD and netBSD to switch over to
+ ncurses.
+
+ The ncurses code was developed under Linux. It should port easily to
+ any ANSI/POSIX-conforming UNIX. It has even been ported to OS/2 Warp!
+
+ The distribution includes the library and support utilities, including
+ a terminfo compiler tic(1), a decompiler infocmp(1), clear(1),
+ tput(1), tset(1), and a termcap conversion tool captoinfo(1). Full
+ manual pages are provided for the library and tools.
+
+ The ncurses distribution is available via anonymous FTP at:
+ [1]ftp://ftp.clark.net/pub/dickey/ncurses. and
+ [2]ftp://ftp.netcom.com/pub/zm/zmbenhal/ncurses. It is also carried on
+ the GNU distribution site at [3]ftp://prep.ai.mit.edu/pub/gnu.
+
+ Features of ncurses
+
+ The ncurses package is fully compatible with SVr4 curses:
+
+ * All 257 of the SVr4 calls have been implemented (and are
+ documented).
+ * Full support for SVr4 curses features including keyboard mapping,
+ color, forms-drawing with ACS characters, and automatic
+ recognition of keypad and function keys.
+ * An emulation of the System V Release 4 panels library, supporting
+ a stack of windows with backing store, is included.
+ * An emulation of the System V Release 4 menus library, supporting a
+ uniform but flexible interface for menu programming, is included.
+ * An emulation of the System V Release 4 form library, supporting
+ data collection through on-screen forms, is included.
+ * Binary terminfo entries generated by the ncurses tic(1)
+ implementation are bit-for-bit-compatible with the entry format
+ SVr4 curses uses.
+ * The utilities have options to allow you to filter terminfo entries
+ for use with less capable curses/terminfo versions such as the
+ HP/UX and AIX ports.
+
+ The ncurses package also has many useful extensions over SVr4:
+
+ * The API is 8-bit clean and base-level conformant with the X/OPEN
+ curses specification, XSI Curses (that is, it implements all BASE
+ level features, but not all EXTENDED features). Most
+ EXTENDED-level features not directly concerned with wide-character
+ support are implemented, including many function calls not
+ supported under SVr4 curses (but portability of all calls is
+ documented so you can use the SVr4 subset only).
+ * Unlike SVr4 curses, ncurses can write to the rightmost-bottommost
+ corner of the screen if your terminal has an insert-character
+ capability.
+ * (PC-clone boxes only) Support for access to the IBM PC ROM
+ characters 0-32 through the highlight A_ALTCHARSET.
+ * Support for mouse event reporting under xterm.
+ * The function wresize() allows you to resize windows, preserving
+ their data.
+ * Better cursor-movement optimization. The package now features a
+ cursor-local-movement computation more efficient than either BSD's
+ or System V's.
+ * Super hardware scrolling support. The screen-update code
+ incorporates a novel, simple, and cheap algorithm that enables it
+ to make optimal use of hardware scrolling, line-insertion, and
+ line-deletion for screen-line movements. This algorithm is more
+ powerful than the 4.4BSD curses quickch() routine.
+ * Real support for terminals with the magic-cookie glitch. The
+ screen-update code will refrain from drawing a highlight if the
+ magic- cookie unattributed spaces required just before the
+ beginning and after the end would step on a non-space character.
+ It will automatically shift highlight boundaries when doing so
+ would make it possible to draw the highlight without changing the
+ visual appearance of the screen.
+ * It is possible to generate the library with a list of pre-loaded
+ fallback entries linked to it so that it can serve those terminal
+ types even when no terminfo tree or termcap file is accessible
+ (this may be useful for support of screen-oriented programs that
+ must run in single-user mode).
+ * The tic(1)/captoinfo utility provided with ncurses has the ability
+ to translate many termcaps from the XENIX, IBM and AT&T extension
+ sets.
+ * A BSD-like tset(1) utility is provided.
+ * The ncurses library and utilities will automatically read terminfo
+ entries from $HOME/.terminfo if it exists, and compile to that
+ directory if it exists and the user has no write access to the
+ system directory. This feature makes it easier for users to have
+ personal terminfo entries without giving up access to the system
+ terminfo directory.
+ * You may specify a path of directories to search for compiled
+ descriptions with the environment variable TERMINFO_DIRS (this
+ generalizes the feature provided by TERMINFO under stock System
+ V.)
+ * In terminfo source files, use capabilities may refer not just to
+ other entries in the same source file (as in System V) but also to
+ compiled entries in either the system terminfo directory or the
+ user's $HOME/.terminfo directory.
+ * A script (capconvert) is provided to help BSD users transition
+ from termcap to terminfo. It gathers the information in a TERMCAP
+ environment variable and/or a ~/.termcap local entries file and
+ converts it to an equivalent local terminfo tree under
+ $HOME/.terminfo.
+ * Automatic fallback to the /etc/termcap file can be compiled in
+ when it is not possible to build a terminfo tree. This feature is
+ neither fast nor cheap, you don't want to use it unless you have
+ to, but it's there.
+ * The table-of-entries utility toe makes it easy for users to see
+ exactly what terminal types are available on the system.
+ * The library meets the XSI requirement that every macro entry point
+ have a corresponding function which may be linked (and will be
+ prototype-checked) if the macro definition is disabled with
+ #undef.
+ * An HTML "Introduction to Programming with NCURSES" document
+ provides a narrative introduction to the curses programming
+ interface.
+
+ State of the Package
+
+ Numerous bugs present in earlier versions have been fixed; the library
+ is far more reliable than it used to be. Bounds checking in many
+ `dangerous' entry points has been improved. The code is now type-safe
+ according to gcc -Wall. The library has been checked for malloc leaks
+ and arena corruption by the Purify memory-allocation tester.
+
+ The ncurses code has been tested with a wide variety of applications
+ including:
+
+ ded
+ directory-editor [4]ftp://ftp.clark.net/pub/dickey/ded.
+
+ dialog
+ the underlying application used in Slackware's setup, and the
+ basis for similar applications on Linux.
+
+ lynx-2.7
+ the character-screen WWW browser
+
+ ncftp 2.0
+ file-transfer utility
+
+ nvi
+ New vi versions 1.50 are able to use ncurses versions 1.9.7 and
+ later.
+
+ taper
+ tape archive utility
+
+ vh-1.6
+ Volks-Hypertext browser for the Jargon File
+
+ as well as some that use ncurses for the terminfo support alone:
+
+ minicom-1.75
+ terminal emulator
+
+ tin-unoff
+ tin (unofficial) newsreader, supporting color, MIME
+ [5]ftp://ftp.akk.uni-karlsruhe.de/pub/news/clients/tin-unoff.
+
+ vile
+ vi-like-emacs [6]ftp://ftp.clark.net/pub/dickey/vile.
+
+ The ncurses distribution includes a selection of test programs
+ (including a few games).
+
+Who's Who and What's What
+
+ The original maintainer of ncurses is [7]Zeyd Ben-Halim.
+ Unfortunately, he can only work on the package part time. As a result,
+ since 1.8.1, much of the enhancement work and documentation has been
+ done by [8]Eric S. Raymond. The current primary maintainers are
+ [9]Thomas Dickey and [10]Juergen Pfeifer.
+
+ There is an ncurses mailing list. It is a majordomo list; to join,
+ write to ncurses-request@mailgate.bsdi.com with a message containing
+ the line:
+
+ subscribe <name>@<host.domain>
+
+ This list is open to anyone interested in helping with the development
+ and testing of this package.
+
+ Beta versions of ncurses and patches to the current release are made
+ available at [11]ftp://ftp.clark.net/pub/dickey/ncurses.
+
+Future Plans
+
+ * Extended mouse support via Alessandro Rubini's gpm package.
+ * Extended-level XPG4 conformance, with internationalization
+ support.
+ * Ports to more systems, including DOS and Windows.
+
+ We need people to help with these projects. If you are interested in
+ working on them, please join the ncurses list.
+
+The terminfo/termcap Database
+
+ The distribution includes and uses a copy of the terminfo-format
+ terminal description file maintained by Eric Raymond. You can download
+ either the [12]termcap or [13]terminfo versions of the terminal-type
+ database from Eric's ncurses page,
+ [14]http://www.ccil.org/~esr/ncurses.html.
+
+Other Related Resources
+
+ You can find lots of information on terminal-related topics not
+ covered in the terminfo file at [15]Richard Shuford's archive.
+
+References
+
+ 1. ftp://ftp.clark.net/pub/dickey/ncurses
+ 2. ftp://ftp.netcom.com/pub/zm/zmbenhal/ncurses
+ 3. ftp://prep.ai.mit.edu/pub/gnu
+ 4. ftp://ftp.clark.net/pub/dickey/ded
+ 5. ftp://ftp.akk.uni-karlsruhe.de/pub/news/clients/tin-unoff
+ 6. ftp://ftp.clark.net/pub/dickey/vile
+ 7. mailto:zmbenhal@netcom.com
+ 8. http://www.ccil.org/~esr/home.html
+ 9. mailto:dickey@clark.net
+ 10. mailto:Juergen.Pfeifer@T-Online.de
+ 11. ftp://ftp.clark.net/pub/dickey/ncurses
+ 12. http://www.ccil.org/~esr/terminfo/termtypes.tc.gz
+ 13. http://www.ccil.org/~esr/terminfo/termtypes.ti.gz
+ 14. http://www.ccil.org/~esr/ncurses.html
+ 15. http://www.cs.utk.edu/~shuford/terminal_index.html
--- /dev/null
+#----------------------------------------------------------------------------
+# --
+# GNAT ncurses Binding --
+# Makefile --
+# --
+# Version 00.92 --
+# --
+# The ncurses Ada95 binding is copyrighted 1996 by --
+# Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+# --
+# Permission is hereby granted to reproduce and distribute this --
+# binding by any means and for any fee, whether alone or as part --
+# of a larger distribution, in source or in binary form, PROVIDED --
+# this notice is included with any such distribution, and is not --
+# removed from any of its header files. Mention of ncurses and the --
+# author of this binding in any applications linked with it is --
+# highly appreciated. --
+# --
+# This binding comes AS IS with no warranty, implied or expressed. --
+#----------------------------------------------------------------------------
+# Version Control
+# $Revision: 1.3 $
+#
+SHELL = /bin/sh
+THIS = Makefile
+
+SUBDIRS = @ADA_SUBDIRS@
+
+all ::
+ for d in $(SUBDIRS); do \
+ (cd $$d ; $(MAKE) $@) ;\
+ done
+
+clean ::
+ for d in $(SUBDIRS); do \
+ (cd $$d ; $(MAKE) $@) ;\
+ done
+
+distclean ::
+ for d in $(SUBDIRS); do \
+ (cd $$d ; $(MAKE) $@) ;\
+ done
+ rm -f Makefile
+
+realclean ::
+ for d in $(SUBDIRS); do \
+ (cd $$d ; $(MAKE) $@) ;\
+ done
+ rm -f Makefile
+
+mostlyclean ::
+ for d in $(SUBDIRS); do \
+ (cd $$d ; $(MAKE) $@) ;\
+ done
+
+install ::
--- /dev/null
+The ncurses Ada95 binding is copyrighted 1996 by Juergen Pfeifer
+Email: Juergen.Pfeifer@T-Online.de
+
+Permission is hereby granted to reproduce and distribute this
+binding by any means and for any fee, whether alone or as part
+of a larger distribution, in source or in binary form, PROVIDED
+this notice is included with any such distribution, and is not
+removed from any of its header files. Mention of ncurses and the
+author of this binding in any applications linked with it is
+highly appreciated.
+
+This binding comes AS IS with no warranty, implied or expressed.
+----------------------------------------------------------------------
+Caveats:
+
+ This is the first delivery of this binding. It has not been
+ extensively tested. So I declare this as BETA level software,
+ although it is delivered with an official release of ncurses.
+
+ You should install the ncurses distribution around this binding
+ first before you try to run the sample.
+
+ This Binding is currently strictly for the GNAT compiler, because
+ in one place I use a GNAT specfic runtime module (see doc.)
+
+
+The documentation is provided in HTML format in the ./html
+subdirectory. The main document is named index.html
+
--- /dev/null
+-- Intensive testing
+ Perhaps the delivery of the Beta will help a bit.
+
+-- Documentation
+ Like most WEB pages: under continous construction
+
+-- Style cleanup
+
+-- Alternate functions for procedures with out params
+ Comfort purpose
+
+-- Sample program
+ Under continous construction (and it's not a WEB page!!!)
+
+-- Make the binding objects a shared libray
+ They are rather large, so it would make sense, otherwise Ada95
+ would look too large, although the generated code is as compact
+ as C or C++. I'll wait a bit until the GNAT people provide some
+ better support to construct shared libraries.
+
+-- Think about more inlining
+
+-- Check for memory leaks.
+ Oh I would like it so much if the GNAT guys would put an optional
+ GC into their system.
--- /dev/null
+#----------------------------------------------------------------------------
+# --
+# GNAT ncurses Binding --
+# src/Makefile --
+# --
+# Version 00.92 --
+# --
+# The ncurses Ada95 binding is copyrighted 1996 by --
+# Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+# --
+# Permission is hereby granted to reproduce and distribute this --
+# binding by any means and for any fee, whether alone or as part --
+# of a larger distribution, in source or in binary form, PROVIDED --
+# this notice is included with any such distribution, and is not --
+# removed from any of its header files. Mention of ncurses and the --
+# author of this binding in any applications linked with it is --
+# highly appreciated. --
+# --
+# This binding comes AS IS with no warranty, implied or expressed. --
+#----------------------------------------------------------------------------
+# Version Control
+# $Revision: 1.6 $
+#
+.SUFFIXES:
+
+SHELL = /bin/sh
+THIS = Makefile
+
+MODEL = ../../@DFT_OBJ_SUBDIR@
+srcdir = @srcdir@
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+libdir = @libdir@
+includedir = @includedir@
+datadir = @datadir@
+ticdir = $(datadir)/terminfo
+
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+
+AWK = @AWK@
+LN_S = @LN_S@
+
+CC = @CC@
+CFLAGS = @CFLAGS@
+
+CPPFLAGS = @ACPPFLAGS@ \
+ -DHAVE_CONFIG_H -I$(srcdir)
+
+CCFLAGS = $(CPPFLAGS) $(CFLAGS)
+
+CFLAGS_NORMAL = $(CCFLAGS)
+CFLAGS_DEBUG = $(CCFLAGS) @CC_G_OPT@ -DTRACE
+CFLAGS_PROFILE = $(CCFLAGS) -pg
+CFLAGS_SHARED = $(CCFLAGS) @CC_SHARED_OPTS@
+
+CFLAGS_DEFAULT = $(CFLAGS_@DFT_UPR_MODEL@)
+
+LINK = $(CC)
+LDFLAGS = @LDFLAGS@ @LD_MODEL@ @LIBS@
+
+RANLIB = @RANLIB@
+################################################################################
+ADA = @nc_ada_compiler@
+ADAFLAGS = @ADAFLAGS@ -I. -I$(srcdir)
+
+ADAMAKE = @nc_ada_make@
+ADAMAKEFLAGS =
+
+CARGS = -cargs $(ADAFLAGS)
+LARGS =
+
+ALIB = @nc_ada_package@
+ABASE = $(ALIB)-curses
+
+ADA_OBJDIR = ../ada_objects
+OBJDIR = ../objects
+
+LIBALIS=$(ADA_OBJDIR)/$(ALIB).ali \
+ $(ADA_OBJDIR)/$(ABASE)-aux.ali \
+ $(ADA_OBJDIR)/$(ABASE).ali \
+ $(ADA_OBJDIR)/$(ABASE)-mouse.ali \
+ $(ADA_OBJDIR)/$(ABASE)-panels.ali \
+ $(ADA_OBJDIR)/$(ABASE)-menus.ali \
+ $(ADA_OBJDIR)/$(ABASE)-forms.ali \
+ $(ADA_OBJDIR)/$(ABASE)-text_io.ali \
+ $(ADA_OBJDIR)/$(ABASE)-text_io-aux.ali
+
+LIBOBJS=$(ADA_OBJDIR)/$(ALIB).o \
+ $(ADA_OBJDIR)/$(ABASE)-aux.o \
+ $(ADA_OBJDIR)/$(ABASE).o \
+ $(ADA_OBJDIR)/$(ABASE)-mouse.o \
+ $(ADA_OBJDIR)/$(ABASE)-panels.o \
+ $(ADA_OBJDIR)/$(ABASE)-menus.o \
+ $(ADA_OBJDIR)/$(ABASE)-forms.o \
+ $(ADA_OBJDIR)/$(ABASE)-text_io.o \
+ $(ADA_OBJDIR)/$(ABASE)-text_io-aux.o
+
+
+all :: $(LIBALIS)
+ @echo done
+
+clean ::
+ rm -f *.o *.ali b_t*.* *.s $(PROGS) a.out core b_*_test.c *.xr[bs] *.a
+
+mostlyclean :: clean
+ rm -f $(LIBALIS) $(LIBOBJS)
+
+distclean :: mostlyclean
+ rm -f Makefile
+
+realclean :: distclean
+
+BASEDEPS=$(ABASE).ads $(srcdir)/$(ABASE)-aux.ads
+
+$(ADA_OBJDIR)/$(ALIB).o: $(srcdir)/$(ALIB).ads
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ALIB).ads
+
+$(ADA_OBJDIR)/$(ALIB).ali: $(ADA_OBJDIR)/$(ALIB).o
+ if [ -f $(ALIB).ali ]; then \
+ ln -f $(ALIB).ali $@ ;\
+ rm -f $(ALIB).ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-aux.o: $(srcdir)/$(ABASE)-aux.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-aux.adb
+
+$(ADA_OBJDIR)/$(ABASE)-aux.ali: $(ADA_OBJDIR)/$(ABASE)-aux.o
+ if [ -f $(ABASE)-aux.ali ]; then \
+ ln -f $(ABASE)-aux.ali $@ ;\
+ rm -f $(ABASE)-aux.ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE).o: $(srcdir)/$(ABASE).adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE).adb
+
+$(ADA_OBJDIR)/$(ABASE).ali: $(ADA_OBJDIR)/$(ABASE).o
+ if [ -f $(ABASE).ali ]; then \
+ ln -f $(ABASE).ali $@ ;\
+ rm -f $(ABASE).ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-mouse.o: \
+ $(ABASE)-mouse.ads \
+ $(srcdir)/$(ABASE)-mouse.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-mouse.adb
+
+$(ADA_OBJDIR)/$(ABASE)-mouse.ali: $(ADA_OBJDIR)/$(ABASE)-mouse.o
+ if [ -f $(ABASE)-mouse.ali ]; then \
+ ln -f $(ABASE)-mouse.ali $@ ;\
+ rm -f $(ABASE)-mouse.ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-panels.o: \
+ $(ABASE)-panels.ads \
+ $(srcdir)/$(ABASE)-panels.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-panels.adb
+
+$(ADA_OBJDIR)/$(ABASE)-panels.ali: $(ADA_OBJDIR)/$(ABASE)-panels.o
+ if [ -f $(ABASE)-panels.ali ]; then \
+ ln -f $(ABASE)-panels.ali $@ ;\
+ rm -f $(ABASE)-panels.ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-menus.o: \
+ $(ABASE)-menus.ads \
+ $(srcdir)/$(ABASE)-menus.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-menus.adb
+
+$(ADA_OBJDIR)/$(ABASE)-menus.ali: $(ADA_OBJDIR)/$(ABASE)-menus.o
+ if [ -f $(ABASE)-menus.ali ]; then \
+ ln -f $(ABASE)-menus.ali $@ ;\
+ rm -f $(ABASE)-menus.ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-forms.o: \
+ $(ABASE)-forms.ads \
+ $(srcdir)/$(ABASE)-forms.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-forms.adb
+
+$(ADA_OBJDIR)/$(ABASE)-forms.ali: $(ADA_OBJDIR)/$(ABASE)-forms.o
+ if [ -f $(ABASE)-forms.ali ]; then \
+ ln -f $(ABASE)-forms.ali $@ ;\
+ rm -f $(ABASE)-forms.ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-text_io.o: \
+ $(srcdir)/$(ABASE)-text_io.ads \
+ $(srcdir)/$(ABASE)-text_io.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-text_io.adb
+
+$(ADA_OBJDIR)/$(ABASE)-text_io.ali: $(ADA_OBJDIR)/$(ABASE)-text_io.o
+ if [ -f $(ABASE)-text_io.ali ]; then \
+ ln -f $(ABASE)-text_io.ali $@ ;\
+ rm -f $(ABASE)-text_io.ali ;\
+ fi
+
+$(ADA_OBJDIR)/$(ABASE)-text_io-aux.o: \
+ $(srcdir)/$(ABASE)-text_io-aux.ads \
+ $(srcdir)/$(ABASE)-text_io-aux.adb $(BASEDEPS)
+ $(ADA) $(ADAFLAGS) -c -o $@ $(srcdir)/$(ABASE)-text_io-aux.adb
+
+$(ADA_OBJDIR)/$(ABASE)-text_io-aux.ali: $(ADA_OBJDIR)/$(ABASE)-text_io-aux.o
+ if [ -f $(ABASE)-text_io-aux.ali ]; then \
+ ln -f $(ABASE)-text_io-aux.ali $@ ;\
+ rm -f $(ABASE)-text_io-aux.ali ;\
+ fi
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Aux --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+package body Terminal_Interface.Curses.Aux is
+ --
+ -- Some helpers
+ procedure Fill_String (Cp : in chars_ptr;
+ Str : out String)
+ is
+ -- Fill the string with the characters referenced by the
+ -- chars_ptr.
+ --
+ Len : Natural;
+ begin
+ if Cp /= Null_Ptr then
+ Len := Natural (Strlen (Cp));
+ if Str'Length < Len then
+ raise Constraint_Error;
+ end if;
+ declare
+ S : String (1 .. Len);
+ begin
+ S := Value (Cp);
+ Str (Str'First .. (Str'First + Len - 1)) := S (S'Range);
+ end;
+ else
+ Len := 0;
+ end if;
+
+ if Len < Str'Length then
+ Str ((Str'First + Len) .. Str'Last) := (others => ' ');
+ end if;
+
+ end Fill_String;
+
+ procedure Eti_Exception (Code : Eti_Error)
+ is
+ begin
+ case Code is
+ when E_Ok => null;
+ when E_System_Error => raise Eti_System_Error;
+ when E_Bad_Argument => raise Eti_Bad_Argument;
+ when E_Posted => raise Eti_Posted;
+ when E_Connected => raise Eti_Connected;
+ when E_Bad_State => raise Eti_Bad_State;
+ when E_No_Room => raise Eti_No_Room;
+ when E_Not_Posted => raise Eti_Not_Posted;
+ when E_Unknown_Command => raise Eti_Unknown_Command;
+ when E_No_Match => raise Eti_No_Match;
+ when E_Not_Selectable => raise Eti_Not_Selectable;
+ when E_Not_Connected => raise Eti_Not_Connected;
+ when E_Request_Denied => raise Eti_Request_Denied;
+ when E_Invalid_Field => raise Eti_Invalid_Field;
+ when E_Current => raise Eti_Current;
+ end case;
+ end Eti_Exception;
+
+end Terminal_Interface.Curses.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Aux --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.4 $
+------------------------------------------------------------------------------
+with System;
+with Interfaces.C;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+with Unchecked_Conversion;
+
+package Terminal_Interface.Curses.Aux is
+
+ use type Interfaces.C.Int;
+
+ subtype C_Int is Interfaces.C.Int;
+ subtype C_Short is Interfaces.C.Short;
+ subtype C_Long_Int is Interfaces.C.Long;
+ subtype C_Size_T is Interfaces.C.Size_T;
+ subtype C_Char_Ptr is Interfaces.C.Strings.Chars_Ptr;
+ type C_Void_Ptr is new System.Address;
+
+ -- This is how those constants are defined in ncurses. I see them also
+ -- exactly like this in all ETI implementations I ever tested. So it
+ -- could be that this is quite general, but please check with your curses.
+ -- This is critical, because curses sometime mixes boolean returns with
+ -- returning an error status.
+ Curses_Ok : constant C_Int := 0;
+ Curses_Err : constant C_Int := -1;
+
+ Curses_True : constant C_Int := 1;
+ Curses_False : constant C_Int := 0;
+
+ subtype Eti_Error is C_Int range -14 .. 0;
+ -- Type for error codes returned by the menu and forms subsystem
+
+ E_Ok : constant Eti_Error := 0;
+ E_System_Error : constant Eti_Error := -1;
+ E_Bad_Argument : constant Eti_Error := -2;
+ E_Posted : constant Eti_Error := -3;
+ E_Connected : constant Eti_Error := -4;
+ E_Bad_State : constant Eti_Error := -5;
+ E_No_Room : constant Eti_Error := -6;
+ E_Not_Posted : constant Eti_Error := -7;
+ E_Unknown_Command : constant Eti_Error := -8;
+ E_No_Match : constant Eti_Error := -9;
+ E_Not_Selectable : constant Eti_Error := -10;
+ E_Not_Connected : constant Eti_Error := -11;
+ E_Request_Denied : constant Eti_Error := -12;
+ E_Invalid_Field : constant Eti_Error := -13;
+ E_Current : constant Eti_Error := -14;
+
+ procedure Eti_Exception (Code : Eti_Error);
+ -- Dispatch the error code and raise the appropriate exception
+ --
+ --
+ -- Some helpers
+ function CInt_To_Chtype is new
+ Unchecked_Conversion (Source => C_Int,
+ Target => Attributed_Character);
+ function Chtype_To_CInt is new
+ Unchecked_Conversion (Source => Attributed_Character,
+ Target => C_Int);
+
+ procedure Fill_String (Cp : in chars_ptr;
+ Str : out String);
+ -- Fill the Str parameter with the string denoted by the chars_ptr
+ -- C-Style string.
+
+end Terminal_Interface.Curses.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms.Choice_Field_Types --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.5 $
+------------------------------------------------------------------------------
+with Interfaces.C;
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with Terminal_Interface.Curses.Forms.Field_Types;
+
+-- |
+-- |=====================================================================
+-- | man page form_fieldtype.3x
+-- |=====================================================================
+-- |
+package body Terminal_Interface.Curses.Forms.Choice_Field_Types is
+
+ use type Interfaces.C.int;
+
+ package Ft is new Terminal_Interface.Curses.Forms.Field_Types
+ (User, User_Access, Field_Check, Character_Check);
+
+ type N_Check is access
+ function (Fld : Field; Info : User_Access) return Boolean;
+ pragma Convention (C, N_Check);
+
+ type P_Check is access
+ function (Fld : Field; Info : User_Access) return Boolean;
+ pragma Convention (C, P_Check);
+
+ function Nc (Fld : Field; Info : User_Access) return Boolean;
+ pragma Convention (C, Nc);
+
+ function Pc (Fld : Field; Info : User_Access) return Boolean;
+ pragma Convention (C, Pc);
+
+ function Nc (Fld : Field; Info : User_Access) return Boolean
+ is
+ begin
+ return Next_Choice (Fld, Info);
+ end Nc;
+
+ function Pc (Fld : Field; Info : User_Access) return Boolean
+ is
+ begin
+ return Prev_Choice (Fld, Info);
+ end Pc;
+ -- |
+ -- |
+ -- |
+ function Set_Choice (Ft : C_Field_Type;
+ Nc : N_Check;
+ Pc : P_Check) return C_Int;
+ pragma Import (C, Set_Choice, "set_fieldtype_choice");
+
+ procedure Define_Choices
+ is
+ R : Eti_Error;
+ begin
+ R := Set_Choice (Search_Type (User'Tag), Nc'Access, Pc'Access);
+ if (R /= E_OK) then
+ Eti_Exception (R);
+ end if;
+ end Define_Choices;
+
+begin
+ Define_Choices;
+end Terminal_Interface.Curses.Forms.Choice_Field_Types;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms.Choice_Field_Types --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.6 $
+------------------------------------------------------------------------------
+-- You must instantiate this package for any user defined field type
+-- to make it visible to the runtime.
+--
+generic
+ type User is new Ada_Defined_Field_Type with private;
+ type User_Access is access User;
+ with function Field_Check (Fld : Field;
+ Info : User_Access) return Boolean;
+ with function Character_Check (Ch : Character;
+ Info : User_Access) return Boolean;
+ with function Next_Choice (Fld : Field;
+ Info : User_Access) return Boolean;
+ with function Prev_Choice (Fld : Field;
+ Info : User_Access) return Boolean;
+package Terminal_Interface.Curses.Forms.Choice_Field_Types is
+--
+-- Nothing public.
+-- But we need the body.
+ pragma Elaborate_Body;
+end Terminal_Interface.Curses.Forms.Choice_Field_Types;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms.Field_Types --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.4 $
+------------------------------------------------------------------------------
+with Interfaces.C;
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with Unchecked_Deallocation;
+
+-- |
+-- |=====================================================================
+-- | man page form_fieldtype.3x
+-- |=====================================================================
+-- |
+package body Terminal_Interface.Curses.Forms.Field_Types is
+
+ use type Interfaces.C.int;
+
+ type F_Check is access
+ function (Fld : Field; Info : User_Access) return C_Int;
+ pragma Convention (C, F_Check);
+
+ type C_Check is access
+ function (Ch : Character; Info : User_Access) return C_Int;
+ pragma Convention (C, C_Check);
+
+ procedure Free is new
+ Unchecked_Deallocation (User, User_Access);
+
+ -- Forward decls.
+ procedure Register_Field_Type;
+ procedure Unregister_Field_Type;
+
+ procedure Initialize (Obj : in out Tracker)
+ is
+ begin
+ Register_Field_Type;
+ end Initialize;
+
+ procedure Finalize (Obj : in out Tracker)
+ is
+ begin
+ Unregister_Field_Type;
+ end Finalize;
+
+ function Fc (Fld : Field; Info : User_Access) return C_Int;
+ pragma Convention (C, Fc);
+
+ function Cc (Ch : Character; Info : User_Access) return C_Int;
+ pragma Convention (C, Cc);
+
+ function Make_Arg (U : User_Access) return User_Access;
+ pragma Convention (C, Make_Arg);
+
+ function Copy_Arg (U : User_Access) return User_Access;
+ pragma Convention (C, Copy_Arg);
+
+ procedure Free_Arg (U : User_Access);
+ pragma Convention (C, Free_Arg);
+
+ function New_Fieldtype (Fc : F_Check;
+ Cc : C_Check) return C_Field_Type;
+ pragma Import (C, New_Fieldtype, "new_fieldtype");
+
+ function Fc (Fld : Field; Info : User_Access) return C_Int
+ is
+ begin
+ return C_Int (Boolean'Pos (Field_Check (Fld, Info)));
+ end Fc;
+
+ function Cc (Ch : Character; Info : User_Access) return C_Int
+ is
+ begin
+ return C_Int (Boolean'Pos (Character_Check (Ch, Info)));
+ end Cc;
+
+ function Make_Arg (U : User_Access) return User_Access
+ is
+ function Fixme (U : User_Access) return User_Access;
+ pragma Import (C, Fixme, "_nc_ada_getvarg");
+ V : constant User_Access := Fixme (U);
+ I : constant User_Access := new User'(V.all);
+ begin
+ return I;
+ end Make_Arg;
+
+ function Copy_Arg (U : User_Access) return User_Access
+ is
+ I : constant User_Access := new User'(U.all);
+ begin
+ return I;
+ end Copy_Arg;
+
+ procedure Free_Arg (U : User_Access)
+ is
+ begin
+ null;
+ end Free_Arg;
+
+ type M_Arg is access function (U : User_Access) return User_Access;
+ pragma Convention (C, M_Arg);
+
+ type C_Arg is access function (U : User_Access) return User_Access;
+ pragma Convention (C, C_Arg);
+
+ type F_Arg is access procedure (U : User_Access);
+ pragma Convention (C, F_Arg);
+
+ function Set_Fieldtype_Arg (Typ : C_Field_Type;
+ Ma : M_Arg;
+ Ca : C_Arg;
+ Fa : F_Arg) return C_Int;
+ pragma Import (C, Set_Fieldtype_Arg, "set_fieldtype_arg");
+ -- |
+ -- |
+ -- |
+
+ procedure Register_Field_Type
+ is
+ Res : Eti_Error;
+ Cft : C_Field_Type;
+ P : User_Access := new User;
+ -- we need an instance to call
+ -- the Register_Type procedure
+ begin
+ Cft := New_Fieldtype (Fc'Access,
+ Cc'Access);
+ if Cft = Null_Field_Type then
+ raise Form_Exception;
+ end if;
+ Res := Set_Fieldtype_Arg (Cft,
+ Make_Arg'Access,
+ Copy_Arg'Access,
+ Free_Arg'Access);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+
+ Register_Type (P.all, Cft);
+ Free (P);
+ end Register_Field_Type;
+ -- |
+ -- |
+ -- |
+ procedure Unregister_Field_Type
+ is
+ P : User_Access := new User;
+ -- we need an instance to call
+ -- the Unregister_Type procedure
+ begin
+ Unregister_Type (P.all);
+ Free (P);
+ end Unregister_Field_Type;
+
+ Hook : Tracker;
+end Terminal_Interface.Curses.Forms.Field_Types;
+
+
+
+
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms.Field_Types --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Ada.Finalization; use Ada.Finalization;
+
+-- You must instantiate this package for any user defined field type
+-- to make it visible to the runtime.
+--
+generic
+ type User is new Ada_Defined_Field_Type with private;
+ type User_Access is access User;
+ with function Field_Check (Fld : Field;
+ Info : User_Access) return Boolean;
+ with function Character_Check (Ch : Character;
+ Info : User_Access) return Boolean;
+package Terminal_Interface.Curses.Forms.Field_Types is
+--
+-- Nothing public. All happens magically.
+--
+private
+ type Tracker is new Limited_Controlled with null record;
+
+ procedure Initialize (Obj : in out Tracker);
+ procedure Finalize (Obj : in out Tracker);
+
+end Terminal_Interface.Curses.Forms.Field_Types;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms.Field_User_Data --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Unchecked_Conversion;
+with Terminal_Interface.Curses.Aux;
+use Terminal_Interface.Curses.Aux;
+
+-- |
+-- |=====================================================================
+-- | man page form_field_userptr.3x
+-- |=====================================================================
+-- |
+package body Terminal_Interface.Curses.Forms.Field_User_Data is
+
+ function To_Address is new Unchecked_Conversion (User_Access,
+ System.Address);
+ function To_Pointer is new Unchecked_Conversion (System.Address,
+ User_Access);
+ -- |
+ -- |
+ -- |
+ procedure Set_User_Data (Fld : in Field;
+ Data : in User_Access)
+ is
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ B : Field_User_Wrapper_Access;
+ R : C_Int;
+ begin
+ if A = null then
+ raise Form_Exception;
+ else
+ if A.N > 1 then
+ B := new Field_User_Wrapper'(T => A.T,
+ N => 1,
+ U => To_Address (Data));
+ R := Set_Field_Userptr (Fld, B);
+ A.N := A.N - 1;
+ else
+ A.U := To_Address (Data);
+ end if;
+ end if;
+ end Set_User_Data;
+ -- |
+ -- |
+ -- |
+ procedure Get_User_Data (Fld : in Field;
+ Data : out User_Access)
+ is
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ begin
+ if A = null then
+ raise Form_Exception;
+ else
+ Data := To_Pointer (A.U);
+ end if;
+ end Get_User_Data;
+
+end Terminal_Interface.Curses.Forms.Field_User_Data;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms.Form_User_Data --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Unchecked_Conversion;
+-- |
+-- |=====================================================================
+-- | man page form__userptr.3x
+-- |=====================================================================
+-- |
+package body Terminal_Interface.Curses.Forms.Form_User_Data is
+
+ function To_Address is new Unchecked_Conversion (User_Access,
+ System.Address);
+ function To_Pointer is new Unchecked_Conversion (System.Address,
+ User_Access);
+ -- |
+ -- |
+ -- |
+ procedure Set_User_Data (Frm : in Form;
+ Data : in User_Access)
+ is
+ A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
+ begin
+ if A = null then
+ raise Form_Exception;
+ else
+ A.U := To_Address (Data);
+ end if;
+ end Set_User_Data;
+ -- |
+ -- |
+ -- |
+ procedure Get_User_Data (Frm : in Form;
+ Data : out User_Access)
+ is
+ A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
+ begin
+ if A = null then
+ raise Form_Exception;
+ else
+ Data := To_Pointer (A.U);
+ end if;
+ end Get_User_Data;
+
+end Terminal_Interface.Curses.Forms.Form_User_Data;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Forms --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.9 $
+------------------------------------------------------------------------------
+with Ada.Tags; use Ada.Tags;
+with Ada.Unchecked_Deallocation;
+with Unchecked_Conversion;
+
+with Interfaces.C; use Interfaces.C;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with GNAT.Htable;
+
+package body Terminal_Interface.Curses.Forms is
+
+------------------------------------------------------------------------------
+ -- |
+ -- |
+ -- |
+ -- subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
+
+ function FOS_2_CInt is new
+ Unchecked_Conversion (Field_Option_Set,
+ C_Int);
+
+ function CInt_2_FOS is new
+ Unchecked_Conversion (C_Int,
+ Field_Option_Set);
+
+ function FrmOS_2_CInt is new
+ Unchecked_Conversion (Form_Option_Set,
+ C_Int);
+
+ function CInt_2_FrmOS is new
+ Unchecked_Conversion (C_Int,
+ Form_Option_Set);
+
+ procedure Request_Name (Key : in Form_Request_Code;
+ Name : out String)
+ is
+ function Form_Request_Name (Key : C_Int) return chars_ptr;
+ pragma Import (C, Form_Request_Name, "form_request_name");
+ begin
+ Fill_String (Form_Request_Name (C_Int (Key)), Name);
+ end Request_Name;
+------------------------------------------------------------------------------
+ procedure Free_Field_User_Wrapper is
+ new Ada.Unchecked_Deallocation (Field_User_Wrapper,
+ Field_User_Wrapper_Access);
+
+ procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access);
+ procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access);
+
+ procedure Release_User_Wrapper (A : in out Field_User_Wrapper_Access)
+ is
+ begin
+ A.N := A.N - 1;
+ if A.N = 0 then
+ Free_Field_User_Wrapper (A);
+ end if;
+ end Release_User_Wrapper;
+ pragma Inline (Release_User_Wrapper);
+
+ procedure Dup_User_Wrapper (A : in out Field_User_Wrapper_Access)
+ is
+ begin
+ A.N := A.N + 1;
+ end Dup_User_Wrapper;
+ pragma Inline (Dup_User_Wrapper);
+------------------------------------------------------------------------------
+ procedure Free_Form_User_Wrapper is
+ new Ada.Unchecked_Deallocation (Form_User_Wrapper,
+ Form_User_Wrapper_Access);
+ -- |
+ -- |
+ -- |
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_new.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Create (Height : Line_Count;
+ Width : Column_Count;
+ Top : Line_Position;
+ Left : Column_Position;
+ Off_Screen : Natural := 0;
+ More_Buffers : Buffer_Number := Buffer_Number'First)
+ return Field
+ is
+ function Newfield (H, W, T, L, O, M : C_Int) return Field;
+ pragma Import (C, Newfield, "new_field");
+ Fld : constant Field := Newfield (C_Int (Height), C_Int (Width),
+ C_Int (Top), C_Int (Left),
+ C_Int (Off_Screen),
+ C_Int (More_Buffers));
+
+ A : Field_User_Wrapper_Access;
+ Res : Eti_Error;
+ begin
+ if Fld = Null_Field then
+ raise Form_Exception;
+ else
+ A := new Field_User_Wrapper'(U => System.Null_Address,
+ T => null,
+ N => 1);
+ Res := Set_Field_Userptr (Fld, A);
+ if Res /= E_Ok then
+ Free_Field_User_Wrapper (A);
+ Eti_Exception (Res);
+ end if;
+ end if;
+ return Fld;
+ end Create;
+-- |
+-- |
+-- |
+ procedure Delete (Fld : in out Field)
+ is
+ function Free_Field (Fld : Field) return C_Int;
+ pragma Import (C, Free_Field, "free_field");
+ procedure Free_Field_Type is
+ new Ada.Unchecked_Deallocation (Field_Type'Class,
+ Field_Type_Access);
+
+ A : Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ if A /= null then
+ if A.T /= null then
+ Free_Field_Type (A.T);
+ end if;
+ Release_User_Wrapper (A);
+ end if;
+ Res := Free_Field (Fld);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ Fld := Null_Field;
+ end Delete;
+ -- |
+ -- |
+ -- |
+ function Duplicate (Fld : Field;
+ Top : Line_Position;
+ Left : Column_Position) return Field
+ is
+ function Dup_Field (Fld : Field;
+ Top : C_Int;
+ Left : C_Int) return Field;
+ pragma Import (C, Dup_Field, "dup_field");
+
+ A : Field_User_Wrapper_Access := Field_Userptr (Fld);
+ F : constant Field := Dup_Field (Fld,
+ C_Int (Top),
+ C_Int (Left));
+ begin
+ if F = Null_Field then
+ raise Form_Exception;
+ else
+ Dup_User_Wrapper (A);
+ end if;
+ return F;
+ end Duplicate;
+ -- |
+ -- |
+ -- |
+ function Link (Fld : Field;
+ Top : Line_Position;
+ Left : Column_Position) return Field
+ is
+ function Lnk_Field (Fld : Field;
+ Top : C_Int;
+ Left : C_Int) return Field;
+ pragma Import (C, Lnk_Field, "link_field");
+
+ A : Field_User_Wrapper_Access := Field_Userptr (Fld);
+ F : constant Field := Lnk_Field (Fld,
+ C_Int (Top),
+ C_Int (Left));
+ begin
+ if F = Null_Field then
+ raise Form_Exception;
+ else
+ Dup_User_Wrapper (A);
+ end if;
+ return F;
+ end Link;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_just.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Justification (Fld : in Field;
+ Just : in Field_Justification := None)
+ is
+ function Set_Field_Just (Fld : Field;
+ Just : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Just, "set_field_just");
+
+ Res : constant Eti_Error :=
+ Set_Field_Just (Fld,
+ C_Int (Field_Justification'Pos (Just)));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Justification;
+ -- |
+ -- |
+ -- |
+ function Get_Justification (Fld : Field) return Field_Justification
+ is
+ function Field_Just (Fld : Field) return C_Int;
+ pragma Import (C, Field_Just, "field_just");
+ begin
+ return Field_Justification'Val (Field_Just (Fld));
+ end Get_Justification;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_buffer.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Buffer
+ (Fld : in Field;
+ Buffer : in Buffer_Number := Buffer_Number'First;
+ Str : in String)
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Set_Fld_Buffer (Fld : Field;
+ Bufnum : C_Int;
+ S : Char_Ptr)
+ return C_Int;
+ pragma Import (C, Set_Fld_Buffer, "set_field_buffer");
+
+ Txt : char_array (0 .. Str'Length);
+ Len : size_t;
+ Res : Eti_Error;
+ begin
+ To_C (Str, Txt, Len);
+ Res := Set_Fld_Buffer (Fld, C_Int (Buffer), Txt (Txt'First)'Access);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Buffer;
+ -- |
+ -- |
+ -- |
+ procedure Get_Buffer
+ (Fld : in Field;
+ Buffer : in Buffer_Number := Buffer_Number'First;
+ Str : out String)
+ is
+ function Field_Buffer (Fld : Field;
+ B : C_Int) return chars_ptr;
+ pragma Import (C, Field_Buffer, "field_buffer");
+ begin
+ Fill_String (Field_Buffer (Fld, C_Int (Buffer)), Str);
+ end Get_Buffer;
+ -- |
+ -- |
+ -- |
+ procedure Set_Status (Fld : in Field;
+ Status : in Boolean := True)
+ is
+ function Set_Fld_Status (Fld : Field;
+ St : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Status, "set_field_status");
+
+ Res : constant Eti_Error := Set_Fld_Status (Fld, Boolean'Pos (Status));
+ begin
+ if Res /= E_Ok then
+ raise Form_Exception;
+ end if;
+ end Set_Status;
+ -- |
+ -- |
+ -- |
+ function Changed (Fld : Field) return Boolean
+ is
+ function Field_Status (Fld : Field) return C_Int;
+ pragma Import (C, Field_Status, "field_status");
+
+ Res : constant C_Int := Field_Status (Fld);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Changed;
+ -- |
+ -- |
+ -- |
+ procedure Set_Maximum_Size (Fld : in Field;
+ Max : in Natural := 0)
+ is
+ function Set_Field_Max (Fld : Field;
+ M : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Max, "set_max_field");
+
+ Res : constant Eti_Error := Set_Field_Max (Fld, C_Int (Max));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Maximum_Size;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_opts.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Normalize_Field_Options (Options : in out C_Int);
+ pragma Import (C, Normalize_Field_Options, "_nc_ada_normalize_field_opts");
+
+ procedure Set_Options (Fld : in Field;
+ Options : in Field_Option_Set)
+ is
+ function Set_Field_Opts (Fld : Field;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Opts, "set_field_opts");
+
+ Opt : C_Int := FOS_2_CInt (Options);
+ Res : Eti_Error;
+ begin
+ Normalize_Field_Options (Opt);
+ Res := Set_Field_Opts (Fld, Opt);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Options;
+ -- |
+ -- |
+ -- |
+ procedure Switch_Options (Fld : in Field;
+ Options : in Field_Option_Set;
+ On : Boolean := True)
+ is
+ function Field_Opts_On (Fld : Field;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Field_Opts_On, "field_opts_on");
+ function Field_Opts_Off (Fld : Field;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Field_Opts_Off, "field_opts_off");
+
+ Err : Eti_Error;
+ Opt : C_Int := FOS_2_CInt (Options);
+ begin
+ Normalize_Field_Options (Opt);
+ if On then
+ Err := Field_Opts_On (Fld, Opt);
+ else
+ Err := Field_Opts_Off (Fld, Opt);
+ end if;
+ if Err /= E_Ok then
+ Eti_Exception (Err);
+ end if;
+ end Switch_Options;
+ -- |
+ -- |
+ -- |
+ procedure Get_Options (Fld : in Field;
+ Options : out Field_Option_Set)
+ is
+ function Field_Opts (Fld : Field) return C_Int;
+ pragma Import (C, Field_Opts, "field_opts");
+
+ Res : C_Int := Field_Opts (Fld);
+ begin
+ Normalize_Field_Options (Res);
+ Options := CInt_2_FOS (Res);
+ end Get_Options;
+ -- |
+ -- |
+ -- |
+ function Get_Options (Fld : Field := Null_Field)
+ return Field_Option_Set
+ is
+ Fos : Field_Option_Set;
+ begin
+ Get_Options (Fld, Fos);
+ return Fos;
+ end Get_Options;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_attributes.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Foreground
+ (Fld : in Field;
+ Fore : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Field_Fore (Fld : Field;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Fore, "set_field_fore");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Fore);
+ Res : constant Eti_Error := Set_Field_Fore (Fld, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Foreground;
+ -- |
+ -- |
+ -- |
+ procedure Foreground (Fld : in Field;
+ Fore : out Character_Attribute_Set)
+ is
+ function Field_Fore (Fld : Field) return C_Int;
+ pragma Import (C, Field_Fore, "field_fore");
+ begin
+ Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
+ end Foreground;
+
+ procedure Foreground (Fld : in Field;
+ Fore : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Field_Fore (Fld : Field) return C_Int;
+ pragma Import (C, Field_Fore, "field_fore");
+ begin
+ Fore := CInt_To_Chtype (Field_Fore (Fld)).Attr;
+ Color := CInt_To_Chtype (Field_Fore (Fld)).Color;
+ end Foreground;
+ -- |
+ -- |
+ -- |
+ procedure Set_Background
+ (Fld : in Field;
+ Back : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Field_Back (Fld : Field;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Back, "set_field_back");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Back);
+ Res : constant Eti_Error := Set_Field_Back (Fld, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Background;
+ -- |
+ -- |
+ -- |
+ procedure Background (Fld : in Field;
+ Back : out Character_Attribute_Set)
+ is
+ function Field_Back (Fld : Field) return C_Int;
+ pragma Import (C, Field_Back, "field_back");
+ begin
+ Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
+ end Background;
+
+ procedure Background (Fld : in Field;
+ Back : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Field_Back (Fld : Field) return C_Int;
+ pragma Import (C, Field_Back, "field_back");
+ begin
+ Back := CInt_To_Chtype (Field_Back (Fld)).Attr;
+ Color := CInt_To_Chtype (Field_Back (Fld)).Color;
+ end Background;
+ -- |
+ -- |
+ -- |
+ procedure Set_Pad_Character (Fld : in Field;
+ Pad : in Character := Space)
+ is
+ function Set_Field_Pad (Fld : Field;
+ Ch : C_Int) return C_Int;
+ pragma Import (C, Set_Field_Pad, "set_field_pad");
+
+ Res : constant Eti_Error := Set_Field_Pad (Fld,
+ C_Int (Character'Pos (Pad)));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Pad_Character;
+ -- |
+ -- |
+ -- |
+ procedure Pad_Character (Fld : in Field;
+ Pad : out Character)
+ is
+ function Field_Pad (Fld : Field) return C_Int;
+ pragma Import (C, Field_Pad, "field_pad");
+ begin
+ Pad := Character'Val (Field_Pad (Fld));
+ end Pad_Character;
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_info.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Info (Fld : in Field;
+ Lines : out Line_Count;
+ Columns : out Column_Count;
+ First_Row : out Line_Position;
+ First_Column : out Column_Position;
+ Off_Screen : out Natural;
+ Additional_Buffers : out Buffer_Number)
+ is
+ type C_Int_Access is access all C_Int;
+ function Fld_Info (Fld : Field;
+ L, C, Fr, Fc, Os, Ab : C_Int_Access)
+ return C_Int;
+ pragma Import (C, Fld_Info, "field_info");
+
+ L, C, Fr, Fc, Os, Ab : aliased C_Int;
+ Res : constant Eti_Error := Fld_Info (Fld,
+ L'Access, C'Access,
+ Fr'Access, Fc'Access,
+ Os'Access, Ab'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ Lines := Line_Count (L);
+ Columns := Column_Count (C);
+ First_Row := Line_Position (Fr);
+ First_Column := Column_Position (Fc);
+ Off_Screen := Natural (Os);
+ Additional_Buffers := Buffer_Number (Ab);
+ end if;
+ end Info;
+-- |
+-- |
+-- |
+ procedure Dynamic_Info (Fld : in Field;
+ Lines : out Line_Count;
+ Columns : out Column_Count;
+ Max : out Natural)
+ is
+ type C_Int_Access is access all C_Int;
+ function Dyn_Info (Fld : Field; L, C, M : C_Int_Access) return C_Int;
+ pragma Import (C, Dyn_Info, "dynamic_field_info");
+
+ L, C, M : aliased C_Int;
+ Res : constant Eti_Error := Dyn_Info (Fld,
+ L'Access, C'Access,
+ M'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ Lines := Line_Count (L);
+ Columns := Column_Count (C);
+ Max := Natural (M);
+ end if;
+ end Dynamic_Info;
+ -- |
+ -- |=====================================================================
+ -- | man page form_win.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Window (Frm : in Form;
+ Win : in Window)
+ is
+ function Set_Form_Win (Frm : Form;
+ Win : Window) return C_Int;
+ pragma Import (C, Set_Form_Win, "set_form_win");
+
+ Res : constant Eti_Error := Set_Form_Win (Frm, Win);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Window;
+ -- |
+ -- |
+ -- |
+ function Get_Window (Frm : Form) return Window
+ is
+ function Form_Win (Frm : Form) return Window;
+ pragma Import (C, Form_Win, "form_win");
+
+ W : constant Window := Form_Win (Frm);
+ begin
+ return W;
+ end Get_Window;
+ -- |
+ -- |
+ -- |
+ procedure Set_Sub_Window (Frm : in Form;
+ Win : in Window)
+ is
+ function Set_Form_Sub (Frm : Form;
+ Win : Window) return C_Int;
+ pragma Import (C, Set_Form_Sub, "set_form_sub");
+
+ Res : constant Eti_Error := Set_Form_Sub (Frm, Win);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Sub_Window;
+ -- |
+ -- |
+ -- |
+ function Get_Sub_Window (Frm : Form) return Window
+ is
+ function Form_Sub (Frm : Form) return Window;
+ pragma Import (C, Form_Sub, "form_sub");
+
+ W : constant Window := Form_Sub (Frm);
+ begin
+ return W;
+ end Get_Sub_Window;
+ -- |
+ -- |
+ -- |
+ procedure Scale (Frm : in Form;
+ Lines : out Line_Count;
+ Columns : out Column_Count)
+ is
+ type C_Int_Access is access all C_Int;
+ function M_Scale (Frm : Form; Yp, Xp : C_Int_Access) return C_Int;
+ pragma Import (C, M_Scale, "scale_form");
+
+ X, Y : aliased C_Int;
+ Res : constant Eti_Error := M_Scale (Frm, Y'Access, X'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ Lines := Line_Count (Y);
+ Columns := Column_Count (X);
+ end Scale;
+ -- |
+ -- |=====================================================================
+ -- | man page menu_hook.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Field_Init_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Field_Init (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Field_Init, "set_field_init");
+
+ Res : constant Eti_Error := Set_Field_Init (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Field_Init_Hook;
+ -- |
+ -- |
+ -- |
+ procedure Set_Field_Term_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Field_Term (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Field_Term, "set_field_term");
+
+ Res : constant Eti_Error := Set_Field_Term (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Field_Term_Hook;
+ -- |
+ -- |
+ -- |
+ procedure Set_Form_Init_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Form_Init (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Form_Init, "set_form_init");
+
+ Res : constant Eti_Error := Set_Form_Init (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Form_Init_Hook;
+ -- |
+ -- |
+ -- |
+ procedure Set_Form_Term_Hook (Frm : in Form;
+ Proc : in Form_Hook_Function)
+ is
+ function Set_Form_Term (Frm : Form;
+ Proc : Form_Hook_Function) return C_Int;
+ pragma Import (C, Set_Form_Term, "set_form_term");
+
+ Res : constant Eti_Error := Set_Form_Term (Frm, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Form_Term_Hook;
+ -- |
+ -- |=====================================================================
+ -- | man page form_fields.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Free_Allocated_Fields is
+ new Ada.Unchecked_Deallocation (Field_Array, Field_Array_Access);
+ -- |
+ -- |
+ -- |
+ -- This is a bit delicate if we want to manipulate an Ada created form
+ -- from C routines or vice versa.
+ -- In Ada created forms we use the low level user pointer to maintain
+ -- binding internal additional informations about the form. This
+ -- internal information contains a hook for the Ada provided user pointer.
+ -- Unless you understand this implementation, the safest way in mixed
+ -- language programs to deal with user pointers is, that only the language
+ -- that created the form should also manipulate the user pointer for that
+ -- form.
+ procedure Redefine (Frm : in Form;
+ Flds : in Field_Array)
+ is
+ function Set_Frm_Fields (Frm : Form;
+ Items : Field_Array) return C_Int;
+ pragma Import (C, Set_Frm_Fields, "set_form_fields");
+
+ A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
+ I : Field_Array_Access;
+ Res : Eti_Error;
+ begin
+ if A = null or else A.I = null then raise Form_Exception;
+ else
+ I := new Field_Array (1 .. (Flds'Length + 1));
+ I.all (1 .. Flds'Length) := Flds (Flds'First .. Flds'Last);
+ I.all (Flds'Length + 1) := Null_Field;
+ Res := Set_Frm_Fields (Frm, I.all);
+ if Res /= E_Ok then
+ Free_Allocated_Fields (I);
+ Eti_Exception (Res);
+ else
+ Free_Allocated_Fields (A.I);
+ A.I := I;
+ end if;
+ end if;
+ end Redefine;
+ -- |
+ -- |
+ -- |
+ function Fields (Frm : Form) return Field_Array_Access
+ is
+ A : constant Form_User_Wrapper_Access := Form_Userptr (Frm);
+ begin
+ if A = null or else A.I = null then
+ raise Form_Exception;
+ else
+ return A.I;
+ end if;
+ end Fields;
+ -- |
+ -- |
+ -- |
+ function Field_Count (Frm : Form) return Natural
+ is
+ function Count (Frm : Form) return C_Int;
+ pragma Import (C, Count, "field_count");
+ begin
+ return Natural (Count (Frm));
+ end Field_Count;
+ -- |
+ -- |
+ -- |
+ procedure Move (Fld : in Field;
+ Line : in Line_Position;
+ Column : in Column_Position)
+ is
+ function Move (Fld : Field; L, C : C_Int) return C_Int;
+ pragma Import (C, Move, "move_field");
+
+ Res : constant Eti_Error := Move (Fld, C_Int (Line), C_Int (Column));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Move;
+ -- |
+ -- |=====================================================================
+ -- | man page form_new.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Create (Fields : Field_Array) return Form
+ is
+ function NewForm (Fields : Field_Array) return Form;
+ pragma Import (C, NewForm, "new_form");
+
+ M : Form;
+ I : Field_Array_Access;
+ U : Form_User_Wrapper_Access;
+ Res : Eti_Error;
+ begin
+ I := new Field_Array (1 .. (Fields'Length + 1));
+ I.all (1 .. Fields'Length) := Fields (Fields'First .. Fields'Last);
+ I.all (Fields'Length + 1) := Null_Field;
+ M := NewForm (I.all);
+ if M = Null_Form then
+ Free_Allocated_Fields (I);
+ raise Form_Exception;
+ end if;
+ U := new Form_User_Wrapper'(U => System.Null_Address, I => I);
+ Res := Set_Form_Userptr (M, U);
+ if Res /= E_Ok then
+ Free_Allocated_Fields (I);
+ Free_Form_User_Wrapper (U);
+ Eti_Exception (Res);
+ end if;
+ return M;
+ end Create;
+ -- |
+ -- |
+ -- |
+ procedure Delete (Frm : in out Form)
+ is
+ function Free (Frm : Form) return C_Int;
+ pragma Import (C, Free, "free_form");
+
+ U : Form_User_Wrapper_Access := Form_Userptr (Frm);
+ Res : constant Eti_Error := Free (Frm);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ if U = null or else U.I = null then
+ raise Form_Exception;
+ end if;
+ Free_Allocated_Fields (U.I);
+ Free_Form_User_Wrapper (U);
+ Frm := Null_Form;
+ end Delete;
+ -- |
+ -- |=====================================================================
+ -- | man page form_opts.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Normalize_Form_Options (Options : in out C_Int);
+ pragma Import (C, Normalize_Form_Options, "_nc_ada_normalize_form_opts");
+
+ procedure Set_Options (Frm : in Form;
+ Options : in Form_Option_Set)
+ is
+ function Set_Form_Opts (Frm : Form;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Set_Form_Opts, "set_form_opts");
+
+ Opt : C_Int := FrmOS_2_CInt (Options);
+ Res : Eti_Error;
+ begin
+ Normalize_Form_Options (Opt);
+ Res := Set_Form_Opts (Frm, Opt);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Options;
+ -- |
+ -- |
+ -- |
+ procedure Switch_Options (Frm : in Form;
+ Options : in Form_Option_Set;
+ On : Boolean := True)
+ is
+ function Form_Opts_On (Frm : Form;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Form_Opts_On, "form_opts_on");
+ function Form_Opts_Off (Frm : Form;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Form_Opts_Off, "form_opts_off");
+
+ Err : Eti_Error;
+ Opt : C_Int := FrmOS_2_CInt (Options);
+ begin
+ Normalize_Form_Options (Opt);
+ if On then
+ Err := Form_Opts_On (Frm, Opt);
+ else
+ Err := Form_Opts_Off (Frm, Opt);
+ end if;
+ if Err /= E_Ok then
+ Eti_Exception (Err);
+ end if;
+ end Switch_Options;
+ -- |
+ -- |
+ -- |
+ procedure Get_Options (Frm : in Form;
+ Options : out Form_Option_Set)
+ is
+ function Form_Opts (Frm : Form) return C_Int;
+ pragma Import (C, Form_Opts, "form_opts");
+
+ Res : C_Int := Form_Opts (Frm);
+ begin
+ Normalize_Form_Options (Res);
+ Options := CInt_2_FrmOS (Res);
+ end Get_Options;
+ -- |
+ -- |
+ -- |
+ function Get_Options (Frm : Form := Null_Form) return Form_Option_Set
+ is
+ Fos : Form_Option_Set;
+ begin
+ Get_Options (Frm, Fos);
+ return Fos;
+ end Get_Options;
+ -- |
+ -- |=====================================================================
+ -- | man page form_post.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Post (Frm : in Form;
+ Post : in Boolean := True)
+ is
+ function M_Post (Frm : Form) return C_Int;
+ pragma Import (C, M_Post, "post_form");
+ function M_Unpost (Frm : Form) return C_Int;
+ pragma Import (C, M_Unpost, "unpost_form");
+
+ Res : Eti_Error;
+ begin
+ if Post then
+ Res := M_Post (Frm);
+ else
+ Res := M_Unpost (Frm);
+ end if;
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Post;
+ -- |
+ -- |=====================================================================
+ -- | man page form_cursor.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Position_Cursor (Frm : Form)
+ is
+ function Pos_Form_Cursor (Frm : Form) return C_Int;
+ pragma Import (C, Pos_Form_Cursor, "pos_form_cursor");
+
+ Res : constant Eti_Error := Pos_Form_Cursor (Frm);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Position_Cursor;
+ -- |
+ -- |=====================================================================
+ -- | man page form_data.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Data_Ahead (Frm : Form) return Boolean
+ is
+ function Ahead (Frm : Form) return C_Int;
+ pragma Import (C, Ahead, "data_ahead");
+
+ Res : constant C_Int := Ahead (Frm);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Data_Ahead;
+ -- |
+ -- |
+ -- |
+ function Data_Behind (Frm : Form) return Boolean
+ is
+ function Behind (Frm : Form) return C_Int;
+ pragma Import (C, Behind, "data_behind");
+
+ Res : constant C_Int := Behind (Frm);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Data_Behind;
+ -- |
+ -- |=====================================================================
+ -- | man page form_driver.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Driver (Frm : Form;
+ Key : Key_Code) return Driver_Result
+ is
+ function Frm_Driver (Frm : Form; Key : C_Int) return C_Int;
+ pragma Import (C, Frm_Driver, "form_driver");
+
+ R : Eti_Error := Frm_Driver (Frm, C_Int (Key));
+ begin
+ if R /= E_Ok then
+ if R = E_Unknown_Command then
+ return Unknown_Request;
+ elsif R = E_Invalid_Field then
+ return Invalid_Field;
+ elsif R = E_Request_Denied then
+ return Request_Denied;
+ else
+ Eti_Exception (R);
+ return Form_Ok;
+ end if;
+ else
+ return Form_Ok;
+ end if;
+ end Driver;
+ -- |
+ -- |=====================================================================
+ -- | man page form_page.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_Current (Frm : in Form;
+ Fld : in Field)
+ is
+ function Set_Current_Fld (Frm : Form; Fld : Field) return C_Int;
+ pragma Import (C, Set_Current_Fld, "set_current_field");
+
+ Res : constant Eti_Error := Set_Current_Fld (Frm, Fld);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Current;
+ -- |
+ -- |
+ -- |
+ function Current (Frm : in Form) return Field
+ is
+ function Current_Fld (Frm : Form) return Field;
+ pragma Import (C, Current_Fld, "current_field");
+
+ Fld : constant Field := Current_Fld (Frm);
+ begin
+ if Fld = Null_Field then
+ raise Form_Exception;
+ end if;
+ return Fld;
+ end Current;
+ -- |
+ -- |
+ -- |
+ procedure Set_Page (Frm : in Form;
+ Page : in Page_Number := Page_Number'First)
+ is
+ function Set_Frm_Page (Frm : Form; Pg : C_Int) return C_Int;
+ pragma Import (C, Set_Frm_Page, "set_form_page");
+
+ Res : constant Eti_Error := Set_Frm_Page (Frm, C_Int (Page));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Page;
+ -- |
+ -- |
+ -- |
+ function Page (Frm : Form) return Page_Number
+ is
+ function Get_Page (Frm : Form) return C_Int;
+ pragma Import (C, Get_Page, "form_page");
+
+ P : constant C_Int := Get_Page (Frm);
+ begin
+ if P < 0 then
+ raise Form_Exception;
+ else
+ return Page_Number (P);
+ end if;
+ end Page;
+
+ function Get_Index (Fld : Field) return Positive
+ is
+ function Get_Fieldindex (Fld : Field) return C_Int;
+ pragma Import (C, Get_Fieldindex, "field_index");
+
+ Res : constant C_Int := Get_Fieldindex (Fld);
+ begin
+ if Res = Curses_Err then
+ raise Form_Exception;
+ end if;
+ return Positive (Natural (Res) + Positive'First);
+ end Get_Index;
+
+ -- |
+ -- |=====================================================================
+ -- | man page form_new_page.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ procedure Set_New_Page (Fld : in Field;
+ New_Page : in Boolean := True)
+ is
+ function Set_Page (Fld : Field; Flg : C_Int) return C_Int;
+ pragma Import (C, Set_Page, "set_new_page");
+
+ Res : constant Eti_Error := Set_Page (Fld, Boolean'Pos (New_Page));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_New_Page;
+ -- |
+ -- |
+ -- |
+ function Is_New_Page (Fld : Field) return Boolean
+ is
+ function Is_New (Fld : Field) return C_Int;
+ pragma Import (C, Is_New, "new_page");
+
+ Res : constant C_Int := Is_New (Fld);
+ begin
+ if Res = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_New_Page;
+
+------------------------------------------------------------------------------
+ -- We use a GNAT internal hash table mechanism to create an association
+ -- between an Ada_Defined_Field_Type and it's low level C_Field_Type
+ -- peer.
+ -- It shouldn´t be too complicated to reimplent this hashing mechanism
+ -- for other compilers.
+ --
+ type Tag_Type_Pair;
+ type Tag_Pair_Access is access all Tag_Type_Pair;
+ pragma Controlled (Tag_Pair_Access);
+
+ Null_Tag_Pair : constant Tag_Pair_Access := Tag_Pair_Access'(null);
+
+ type Tag_Type_Pair is
+ record
+ Ada_Tag : Tag;
+ Cft : C_Field_Type;
+ Next : Tag_Pair_Access;
+ end record;
+
+ type Htable_Headers is range 1 .. 31;
+ procedure Free_Tag_Type_Pair is
+ new Ada.Unchecked_Deallocation (Tag_Type_Pair, Tag_Pair_Access);
+
+ procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access);
+ function Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access;
+ function Get_Pair_Tag (T : Tag_Pair_Access) return Tag;
+
+ function Hash (T : Tag) return Htable_Headers;
+ function Equal (A, B : Tag) return Boolean;
+
+ package External_Pair_Htable is new GNAT.Htable.Static_Htable
+ (Header_Num => Htable_Headers,
+ Element => Tag_Type_Pair,
+ Elmt_Ptr => Tag_Pair_Access,
+ Null_Ptr => Null_Tag_Pair,
+ Set_Next => Set_Pair_Link,
+ Next => Get_Pair_Link,
+ Key => Tag,
+ Get_Key => Get_Pair_Tag,
+ Hash => Hash,
+ Equal => Equal);
+
+ procedure Set_Pair_Link (T : Tag_Pair_Access; Next : Tag_Pair_Access)
+ is
+ begin
+ T.all.Next := Next;
+ end Set_Pair_Link;
+
+ function Get_Pair_Link (T : Tag_Pair_Access) return Tag_Pair_Access
+ is
+ begin
+ return T.all.Next;
+ end Get_Pair_Link;
+
+ function Get_Pair_Tag (T : Tag_Pair_Access) return Tag
+ is
+ begin
+ return T.all.Ada_Tag;
+ end Get_Pair_Tag;
+
+ function Equal (A, B : Tag) return Boolean
+ is
+ begin
+ return A = B;
+ end Equal;
+
+ function Hash (T : Tag) return Htable_Headers
+ is
+ function H is new GNAT.Htable.Hash (Htable_Headers);
+ begin
+ return H (External_Tag (T));
+ end Hash;
+
+ function Search_Type (T : Ada_Defined_Field_Type'Class)
+ return C_Field_Type
+ is
+ P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
+ begin
+ if P /= null then
+ return P.Cft;
+ else
+ return Null_Field_Type;
+ end if;
+ end Search_Type;
+
+ -- Register an Ada_Defined_Field_Type given by its Tag
+ -- with it's associated C_Field_Type.
+ procedure Register_Type (T : in Ada_Defined_Field_Type'Class;
+ Cft : in C_Field_Type)
+ is
+ C : C_Field_Type := Search_Type (T);
+ P : Tag_Pair_Access;
+ begin
+ if C /= Null_Field_Type then
+ raise Form_Exception;
+ else
+ P := new Tag_Type_Pair'(T'Tag, Cft, null);
+ External_Pair_Htable.Set (P);
+ end if;
+ end Register_Type;
+
+ -- Unregister an Ada_Defined_Field_Type given by it's tag
+ procedure Unregister_Type (T : in Ada_Defined_Field_Type'Class)
+ is
+ function Free_Fieldtype (Ft : C_Field_Type) return C_Int;
+ pragma Import (C, Free_Fieldtype, "free_fieldtype");
+
+ P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
+ Ft : C_Field_Type;
+ Res : C_Int;
+ begin
+ if P = null then
+ raise Form_Exception;
+ else
+ Ft := P.Cft;
+ External_Pair_Htable.Remove (T'Tag);
+ Free_Tag_Type_Pair (P);
+ Res := Free_Fieldtype (Ft);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end if;
+ end Unregister_Type;
+
+----------------------------------------------------------------------------
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : Field;
+ Fld_Type : Ada_Defined_Field_Type)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Ct : C_Field_Type;
+ Arg1 : Ada_Defined_Field_Type'Class)
+ return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ Res : Eti_Error;
+ C : constant C_Field_Type := Search_Type (Fld_Type);
+ begin
+ if C = Null_Field_Type then
+ raise Form_Exception;
+ else
+ Res := Set_Fld_Type (Fld, C, Fld_Type);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Ada_Defined_Field_Type)
+ return C_Field_Type
+ is
+ C : constant C_Field_Type := Search_Type (Ftype);
+ begin
+ if C = Null_Field_Type then
+ raise Form_Exception;
+ else
+ return C;
+ end if;
+ end Native_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Alpha_Field)
+ return C_Field_Type
+ is
+ C_Alpha_Field_Type : C_Field_Type;
+ pragma Import (C, C_Alpha_Field_Type, "TYPE_ALPHA");
+ begin
+ return C_Alpha_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Alpha_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Alpha_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Alpha_Numeric_Field)
+ return C_Field_Type
+ is
+ C_Alpha_Numeric_Field_Type : C_Field_Type;
+ pragma Import (C, C_Alpha_Numeric_Field_Type, "TYPE_ALNUM");
+ begin
+ return C_Alpha_Numeric_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Alpha_Numeric_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Alpha_Numeric_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Integer_Field)
+ return C_Field_Type
+ is
+ C_Integer_Field_Type : C_Field_Type;
+ pragma Import (C, C_Integer_Field_Type, "TYPE_INTEGER");
+ begin
+ return C_Integer_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Integer_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : C_Int;
+ Arg2 : C_Long_Int;
+ Arg3 : C_Long_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Precision),
+ Arg2 => C_Long_Int (Fld_Type.Lower_Limit),
+ Arg3 => C_Long_Int (Fld_Type.Upper_Limit));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Integer_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Numeric_Field)
+ return C_Field_Type
+ is
+ C_Numeric_Field_Type : C_Field_Type;
+ pragma Import (C, C_Numeric_Field_Type, "TYPE_NUMERIC");
+ begin
+ return C_Numeric_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Numeric_Field)
+ is
+ type Double is new Interfaces.C.double;
+
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : Double;
+ Arg2 : Double;
+ Arg3 : Double) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type (Arg1 => Double (Fld_Type.Precision),
+ Arg2 => Double (Fld_Type.Lower_Limit),
+ Arg3 => Double (Fld_Type.Upper_Limit));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Numeric_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Regular_Expression_Field)
+ return C_Field_Type
+ is
+ C_Regexp_Field_Type : C_Field_Type;
+ pragma Import (C, C_Regexp_Field_Type, "TYPE_REGEXP");
+ begin
+ return C_Regexp_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Regular_Expression_Field)
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : Char_Ptr) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Txt : char_array (0 .. Fld_Type.Regular_Expression.all'Length);
+ Len : size_t;
+ Res : Eti_Error;
+ begin
+ To_C (Fld_Type.Regular_Expression.all, Txt, Len);
+ Res := Set_Fld_Type (Arg1 => Txt (Txt'First)'Access);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Regular_Expression_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+ -- |
+ -- |
+ -- |
+ function Native_Type (Ftype : Enumeration_Field)
+ return C_Field_Type
+ is
+ C_Enum_Type : C_Field_Type;
+ pragma Import (C, C_Enum_Type, "TYPE_ENUM");
+ begin
+ return C_Enum_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ function Create (Info : Enumeration_Info;
+ Auto_Release_Names : Boolean := False)
+ return Enumeration_Field
+ is
+ procedure Release_String is
+ new Ada.Unchecked_Deallocation (String,
+ String_Access);
+ E : Enumeration_Field;
+ L : constant size_t := 1 + size_t (Info.C);
+ S : String_Access;
+ begin
+ E.Case_Sensitive := Info.Case_Sensitive;
+ E.Match_Must_Be_Unique := Info.Match_Must_Be_Unique;
+ E.Arr := new chars_ptr_array (size_t (1) .. L);
+ for I in 1 .. Positive (L - 1) loop
+ if Info.Names (I) = null then
+ raise Form_Exception;
+ end if;
+ E.Arr (size_t (I)) := New_String (Info.Names (I).all);
+ if Auto_Release_Names then
+ S := Info.Names (I);
+ Release_String (S);
+ end if;
+ end loop;
+ E.Arr (L) := Null_Ptr;
+ return E;
+ end Create;
+
+ procedure Release (Enum : in out Enumeration_Field)
+ is
+ I : size_t := 0;
+ P : chars_ptr;
+ begin
+ loop
+ P := Enum.Arr (I);
+ exit when P = Null_Ptr;
+ Free (P);
+ Enum.Arr (I) := Null_Ptr;
+ I := I + 1;
+ end loop;
+ Enum.Arr := null;
+ end Release;
+
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Enumeration_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type);
+ Arg1 : chars_ptr_array;
+ Arg2 : C_Int; -- case
+ Arg3 : C_Int) return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ if Fld_Type.Arr = null then
+ raise Form_Exception;
+ end if;
+ Res := Set_Fld_Type (Arg1 => Fld_Type.Arr.all,
+ Arg2 => C_Int (Boolean'Pos
+ (Fld_Type.Case_Sensitive)),
+ Arg3 =>
+ C_Int (Boolean'Pos
+ (Fld_Type.Match_Must_Be_Unique)));
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Enumeration_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+
+
+ function Native_Type (Ftype : Internet_V4_Address_Field)
+ return C_Field_Type
+ is
+ C_IPV4_Field_Type : C_Field_Type;
+ pragma Import (C, C_IPV4_Field_Type, "TYPE_IPV4");
+ begin
+ return C_IPV4_Field_Type;
+ end Native_Type;
+ pragma Inline (Native_Type);
+ -- |
+ -- |
+ -- |
+ procedure Set_Type (Fld : in Field;
+ Fld_Type : in Internet_V4_Address_Field)
+ is
+ function Set_Fld_Type (F : Field := Fld;
+ Cft : C_Field_Type := Native_Type (Fld_Type))
+ return C_Int;
+ pragma Import (C, Set_Fld_Type, "set_field_type");
+ function Field_Userptr (Fld : Field)
+ return Field_User_Wrapper_Access;
+ pragma Import (C, Field_Userptr, "field_userptr");
+
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ Res : Eti_Error;
+ begin
+ Res := Set_Fld_Type;
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ A.T := new Internet_V4_Address_Field'(Fld_Type);
+ end if;
+ end Set_Type;
+
+ -- |
+ -- |=====================================================================
+ -- | man page form_field_validation.3x
+ -- |=====================================================================
+ -- |
+ -- |
+ -- |
+ function Get_Type (Fld : in Field) return Field_Type_Access
+ is
+ A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
+ begin
+ if A = null then
+ return null;
+ else
+ return A.T;
+ end if;
+ end Get_Type;
+
+begin
+ Default_Field_Options := Get_Options (Null_Field);
+ Default_Form_Options := Get_Options (Null_Form);
+end Terminal_Interface.Curses.Forms;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Menus.Item_User_Data --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Interfaces.C;
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+
+package body Terminal_Interface.Curses.Menus.Item_User_Data is
+
+ use type Interfaces.C.int;
+
+ procedure Set_User_Data (Itm : in Item;
+ Data : in User_Access)
+ is
+ function Set_Item_Userptr (Itm : Item;
+ Addr : User_Access) return C_Int;
+ pragma Import (C, Set_Item_Userptr, "set_item_userptr");
+
+ Res : constant Eti_Error := Set_Item_Userptr (Itm, Data);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_User_Data;
+
+ procedure Get_User_Data (Itm : in Item;
+ Data : out User_Access)
+ is
+ function Item_Userptr (Itm : Item) return User_Access;
+ pragma Import (C, Item_Userptr, "item_userptr");
+ begin
+ Data := Item_Userptr (Itm);
+ end Get_User_Data;
+
+end Terminal_Interface.Curses.Menus.Item_User_Data;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Menus.Menu_User_Data --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Unchecked_Conversion;
+
+package body Terminal_Interface.Curses.Menus.Menu_User_Data is
+
+ function To_Address is new
+ Unchecked_Conversion (User_Access,
+ System.Address);
+ function To_Pointer is new
+ Unchecked_Conversion (System.Address,
+ User_Access);
+
+ procedure Set_User_Data (Men : in Menu;
+ Data : in User_Access)
+ is
+ function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access;
+ pragma Import (C, Menu_Userptr, "menu_userptr");
+
+ U : Ada_User_Wrapper_Access := Menu_Userptr (Men);
+ begin
+ if U = null or else U.I = null then
+ raise Menu_Exception;
+ end if;
+ U.U := To_Address (Data);
+ end Set_User_Data;
+
+ procedure Get_User_Data (Men : in Menu;
+ Data : out User_Access)
+ is
+ function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access;
+ pragma Import (C, Menu_Userptr, "menu_userptr");
+
+ U : Ada_User_Wrapper_Access := Menu_Userptr (Men);
+ begin
+ if U = null then
+ raise Menu_Exception;
+ else
+ Data := To_Pointer (U.U);
+ end if;
+ end Get_User_Data;
+
+end Terminal_Interface.Curses.Menus.Menu_User_Data;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Menus --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.7 $
+------------------------------------------------------------------------------
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+
+with Interfaces.C; use Interfaces.C;
+with Interfaces.C.Strings;
+with Terminal_Interface.Curses;
+
+with Ada.Unchecked_Deallocation;
+with Unchecked_Conversion;
+
+package body Terminal_Interface.Curses.Menus is
+
+ use type System.Bit_Order;
+ subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
+
+ function MOS_2_CInt is new
+ Unchecked_Conversion (Menu_Option_Set,
+ C_Int);
+
+ function CInt_2_MOS is new
+ Unchecked_Conversion (C_Int,
+ Menu_Option_Set);
+
+ function IOS_2_CInt is new
+ Unchecked_Conversion (Item_Option_Set,
+ C_Int);
+
+ function CInt_2_IOS is new
+ Unchecked_Conversion (C_Int,
+ Item_Option_Set);
+
+------------------------------------------------------------------------------
+ procedure Free_Allocated_Items is
+ new Ada.Unchecked_Deallocation (Item_Array, Item_Array_Access);
+
+ procedure Free_User_Wrapper is
+ new Ada.Unchecked_Deallocation (Ada_User_Wrapper,
+ Ada_User_Wrapper_Access);
+
+------------------------------------------------------------------------------
+ procedure Request_Name (Key : in Menu_Request_Code;
+ Name : out String)
+ is
+ function Request_Name (Key : C_Int) return chars_ptr;
+ pragma Import (C, Request_Name, "menu_request_name");
+ begin
+ Fill_String (Request_Name (C_Int (Key)), Name);
+ end Request_Name;
+
+ -- !!! W A R N I N G !!!
+ -- If you want to port this binding to a non ncurses version of the
+ -- ETI, this must be rewritten. In ncurses the menu items and
+ -- descriptions may be automatic variables, because ncurses copies
+ -- the parameters into private allocated internal structures.
+ -- Other implementations don't do that usually, so depending on
+ -- scopes you may see unexpected results.
+ function Create (Name : String;
+ Description : String := "") return Item
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Newitem (Name, Desc : Char_Ptr) return Item;
+ pragma Import (C, Newitem, "new_item");
+
+ Name_Str : char_array (0 .. Name'Length);
+ Desc_Str : char_array (0 .. Description'Length);
+ Name_Len, Desc_Len : size_t;
+ Result : Item;
+ begin
+ To_C (Name, Name_Str, Name_Len);
+ To_C (Description, Desc_Str, Desc_Len);
+ Result := Newitem (Name_Str (Name_Str'First)'Access,
+ Desc_Str (Desc_Str'First)'Access);
+ if Result = Null_Item then
+ raise Eti_System_Error;
+ end if;
+ return Result;
+ end Create;
+
+ procedure Delete (Itm : in out Item)
+ is
+ function Freeitem (Itm : Item) return C_Int;
+ pragma Import (C, Freeitem, "free_item");
+
+ Res : constant Eti_Error := Freeitem (Itm);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ Itm := Null_Item;
+ end Delete;
+-------------------------------------------------------------------------------
+ procedure Set_Value (Itm : in Item;
+ Value : in Boolean := True)
+ is
+ function Set_Item_Val (Itm : Item;
+ Val : C_Int) return C_Int;
+ pragma Import (C, Set_Item_Val, "set_item_value");
+
+ Res : constant Eti_Error := Set_Item_Val (Itm, Boolean'Pos (Value));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Value;
+
+ function Value (Itm : Item) return Boolean
+ is
+ function Item_Val (Itm : Item) return C_Int;
+ pragma Import (C, Item_Val, "item_value");
+ begin
+ if Item_Val (Itm) = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Value;
+
+-------------------------------------------------------------------------------
+ function Visible (Itm : Item) return Boolean
+ is
+ function Item_Vis (Itm : Item) return C_Int;
+ pragma Import (C, Item_Vis, "item_visible");
+ begin
+ if Item_Vis (Itm) = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Visible;
+-------------------------------------------------------------------------------
+ procedure Normalize_Item_Options (Options : in out C_Int);
+ pragma Import (C, Normalize_Item_Options, "_nc_ada_normalize_item_opts");
+
+ procedure Set_Options (Itm : in Item;
+ Options : in Item_Option_Set)
+ is
+ function Set_Item_Opts (Itm : Item;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Set_Item_Opts, "set_item_opts");
+
+ Opt : C_Int := IOS_2_CInt (Options);
+ Res : Eti_Error;
+ begin
+ Normalize_Item_Options (Opt);
+ Res := Set_Item_Opts (Itm, Opt);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Options;
+
+ procedure Switch_Options (Itm : in Item;
+ Options : in Item_Option_Set;
+ On : Boolean := True)
+ is
+ function Item_Opts_On (Itm : Item;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Item_Opts_On, "item_opts_on");
+ function Item_Opts_Off (Itm : Item;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Item_Opts_Off, "item_opts_off");
+
+ Opt : C_Int := IOS_2_CInt (Options);
+ Err : Eti_Error;
+ begin
+ Normalize_Item_Options (Opt);
+ if On then
+ Err := Item_Opts_On (Itm, Opt);
+ else
+ Err := Item_Opts_Off (Itm, Opt);
+ end if;
+ if Err /= E_Ok then
+ Eti_Exception (Err);
+ end if;
+ end Switch_Options;
+
+ procedure Get_Options (Itm : in Item;
+ Options : out Item_Option_Set)
+ is
+ function Item_Opts (Itm : Item) return C_Int;
+ pragma Import (C, Item_Opts, "item_opts");
+
+ Res : C_Int := Item_Opts (Itm);
+ begin
+ Normalize_Item_Options (Res);
+ Options := CInt_2_IOS (Res);
+ end Get_Options;
+
+ function Get_Options (Itm : Item := Null_Item) return Item_Option_Set
+ is
+ Ios : Item_Option_Set;
+ begin
+ Get_Options (Itm, Ios);
+ return Ios;
+ end Get_Options;
+-------------------------------------------------------------------------------
+ procedure Name (Itm : in Item;
+ Name : out String)
+ is
+ function Itemname (Itm : Item) return chars_ptr;
+ pragma Import (C, Itemname, "item_name");
+ begin
+ Fill_String (Itemname (Itm), Name);
+ end Name;
+
+ procedure Description (Itm : in Item;
+ Description : out String)
+ is
+ function Descname (Itm : Item) return chars_ptr;
+ pragma Import (C, Descname, "item_description");
+ begin
+ Fill_String (Descname (Itm), Description);
+ end Description;
+-------------------------------------------------------------------------------
+ procedure Set_Current (Men : in Menu;
+ Itm : in Item)
+ is
+ function Set_Curr_Item (Men : Menu;
+ Itm : Item) return C_Int;
+ pragma Import (C, Set_Curr_Item, "set_current_item");
+
+ Res : constant Eti_Error := Set_Curr_Item (Men, Itm);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Current;
+
+ function Current (Men : Menu) return Item
+ is
+ function Curr_Item (Men : Menu) return Item;
+ pragma Import (C, Curr_Item, "current_item");
+
+ Res : constant Item := Curr_Item (Men);
+ begin
+ if Res = Null_Item then
+ raise Menu_Exception;
+ end if;
+ return Res;
+ end Current;
+
+ procedure Set_Top_Row (Men : in Menu;
+ Line : in Line_Position)
+ is
+ function Set_Toprow (Men : Menu;
+ Line : C_Int) return C_Int;
+ pragma Import (C, Set_Toprow, "set_top_row");
+
+ Res : constant Eti_Error := Set_Toprow (Men, C_Int (Line));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Top_Row;
+
+ function Top_Row (Men : Menu) return Line_Position
+ is
+ function Toprow (Men : Menu) return C_Int;
+ pragma Import (C, Toprow, "top_row");
+
+ Res : constant C_Int := Toprow (Men);
+ begin
+ if Res = Curses_Err then
+ raise Menu_Exception;
+ end if;
+ return Line_Position (Res);
+ end Top_Row;
+
+ function Get_Index (Itm : Item) return Positive
+ is
+ function Get_Itemindex (Itm : Item) return C_Int;
+ pragma Import (C, Get_Itemindex, "item_index");
+
+ Res : constant C_Int := Get_Itemindex (Itm);
+ begin
+ if Res = Curses_Err then
+ raise Menu_Exception;
+ end if;
+ return Positive (Natural (Res) + Positive'First);
+ end Get_Index;
+-------------------------------------------------------------------------------
+ procedure Post (Men : in Menu;
+ Post : in Boolean := True)
+ is
+ function M_Post (Men : Menu) return C_Int;
+ pragma Import (C, M_Post, "post_menu");
+ function M_Unpost (Men : Menu) return C_Int;
+ pragma Import (C, M_Unpost, "unpost_menu");
+
+ Res : Eti_Error;
+ begin
+ if Post then
+ Res := M_Post (Men);
+ else
+ Res := M_Unpost (Men);
+ end if;
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Post;
+-------------------------------------------------------------------------------
+ procedure Normalize_Menu_Options (Options : in out C_Int);
+ pragma Import (C, Normalize_Menu_Options, "_nc_ada_normalize_menu_opts");
+
+ procedure Set_Options (Men : in Menu;
+ Options : in Menu_Option_Set)
+ is
+ function Set_Menu_Opts (Men : Menu;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Set_Menu_Opts, "set_menu_opts");
+
+ Opt : C_Int := MOS_2_CInt (Options);
+ Res : Eti_Error;
+ begin
+ Normalize_Menu_Options (Opt);
+ Res := Set_Menu_Opts (Men, Opt);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Options;
+
+ procedure Switch_Options (Men : in Menu;
+ Options : in Menu_Option_Set;
+ On : in Boolean := True)
+ is
+ function Menu_Opts_On (Men : Menu;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Menu_Opts_On, "menu_opts_on");
+ function Menu_Opts_Off (Men : Menu;
+ Opt : C_Int) return C_Int;
+ pragma Import (C, Menu_Opts_Off, "menu_opts_off");
+
+ Opt : C_Int := MOS_2_CInt (Options);
+ Err : Eti_Error;
+ begin
+ Normalize_Menu_Options (Opt);
+ if On then
+ Err := Menu_Opts_On (Men, Opt);
+ else
+ Err := Menu_Opts_Off (Men, Opt);
+ end if;
+ if Err /= E_Ok then
+ Eti_Exception (Err);
+ end if;
+ end Switch_Options;
+
+ procedure Get_Options (Men : in Menu;
+ Options : out Menu_Option_Set)
+ is
+ function Menu_Opts (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Opts, "menu_opts");
+
+ Res : C_Int := Menu_Opts (Men);
+ begin
+ Normalize_Menu_Options (Res);
+ Options := CInt_2_MOS (Res);
+ end Get_Options;
+
+ function Get_Options (Men : Menu := Null_Menu) return Menu_Option_Set
+ is
+ Mos : Menu_Option_Set;
+ begin
+ Get_Options (Men, Mos);
+ return Mos;
+ end Get_Options;
+-------------------------------------------------------------------------------
+ procedure Set_Window (Men : in Menu;
+ Win : in Window)
+ is
+ function Set_Menu_Win (Men : Menu;
+ Win : Window) return C_Int;
+ pragma Import (C, Set_Menu_Win, "set_menu_win");
+
+ Res : constant Eti_Error := Set_Menu_Win (Men, Win);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Window;
+
+ function Get_Window (Men : Menu) return Window
+ is
+ function Menu_Win (Men : Menu) return Window;
+ pragma Import (C, Menu_Win, "menu_win");
+
+ W : constant Window := Menu_Win (Men);
+ begin
+ return W;
+ end Get_Window;
+
+ procedure Set_Sub_Window (Men : in Menu;
+ Win : in Window)
+ is
+ function Set_Menu_Sub (Men : Menu;
+ Win : Window) return C_Int;
+ pragma Import (C, Set_Menu_Sub, "set_menu_sub");
+
+ Res : constant Eti_Error := Set_Menu_Sub (Men, Win);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Sub_Window;
+
+ function Get_Sub_Window (Men : Menu) return Window
+ is
+ function Menu_Sub (Men : Menu) return Window;
+ pragma Import (C, Menu_Sub, "menu_sub");
+
+ W : constant Window := Menu_Sub (Men);
+ begin
+ return W;
+ end Get_Sub_Window;
+
+ procedure Scale (Men : in Menu;
+ Lines : out Line_Count;
+ Columns : out Column_Count)
+ is
+ type C_Int_Access is access all C_Int;
+ function M_Scale (Men : Menu;
+ Yp, Xp : C_Int_Access) return C_Int;
+ pragma Import (C, M_Scale, "scale_menu");
+
+ X, Y : aliased C_Int;
+ Res : constant Eti_Error := M_Scale (Men, Y'Access, X'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ Lines := Line_Count (Y);
+ Columns := Column_Count (X);
+ end Scale;
+-------------------------------------------------------------------------------
+ procedure Position_Cursor (Men : Menu)
+ is
+ function Pos_Menu_Cursor (Men : Menu) return C_Int;
+ pragma Import (C, Pos_Menu_Cursor, "pos_menu_cursor");
+
+ Res : constant Eti_Error := Pos_Menu_Cursor (Men);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Position_Cursor;
+
+-------------------------------------------------------------------------------
+ procedure Set_Mark (Men : in Menu;
+ Mark : in String)
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Set_Mark (Men : Menu;
+ Mark : Char_Ptr) return C_Int;
+ pragma Import (C, Set_Mark, "set_menu_mark");
+
+ Txt : char_array (0 .. Mark'Length);
+ Len : size_t;
+ Res : Eti_Error;
+ begin
+ To_C (Mark, Txt, Len);
+ Res := Set_Mark (Men, Txt (Txt'First)'Access);
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Mark;
+
+ procedure Mark (Men : in Menu;
+ Mark : out String)
+ is
+ function Get_Menu_Mark (Men : Menu) return chars_ptr;
+ pragma Import (C, Get_Menu_Mark, "menu_mark");
+ begin
+ Fill_String (Get_Menu_Mark (Men), Mark);
+ end Mark;
+
+-------------------------------------------------------------------------------
+ procedure Set_Foreground
+ (Men : in Menu;
+ Fore : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Menu_Fore (Men : Menu;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Menu_Fore, "set_menu_fore");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Fore);
+ Res : constant Eti_Error := Set_Menu_Fore (Men, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Foreground;
+
+ procedure Foreground (Men : in Menu;
+ Fore : out Character_Attribute_Set)
+ is
+ function Menu_Fore (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Fore, "menu_fore");
+ begin
+ Fore := CInt_To_Chtype (Menu_Fore (Men)).Attr;
+ end Foreground;
+
+ procedure Foreground (Men : in Menu;
+ Fore : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Menu_Fore (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Fore, "menu_fore");
+ begin
+ Fore := CInt_To_Chtype (Menu_Fore (Men)).Attr;
+ Color := CInt_To_Chtype (Menu_Fore (Men)).Color;
+ end Foreground;
+
+ procedure Set_Background
+ (Men : in Menu;
+ Back : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Menu_Back (Men : Menu;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Menu_Back, "set_menu_back");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Back);
+ Res : constant Eti_Error := Set_Menu_Back (Men, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Background;
+
+ procedure Background (Men : in Menu;
+ Back : out Character_Attribute_Set)
+ is
+ function Menu_Back (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Back, "menu_back");
+ begin
+ Back := CInt_To_Chtype (Menu_Back (Men)).Attr;
+ end Background;
+
+ procedure Background (Men : in Menu;
+ Back : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Menu_Back (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Back, "menu_back");
+ begin
+ Back := CInt_To_Chtype (Menu_Back (Men)).Attr;
+ Color := CInt_To_Chtype (Menu_Back (Men)).Color;
+ end Background;
+
+ procedure Set_Grey (Men : in Menu;
+ Grey : in Character_Attribute_Set := Normal_Video;
+ Color : in Color_Pair := Color_Pair'First)
+ is
+ function Set_Menu_Grey (Men : Menu;
+ Attr : C_Int) return C_Int;
+ pragma Import (C, Set_Menu_Grey, "set_menu_grey");
+
+ Ch : constant Attributed_Character := (Ch => Character'First,
+ Color => Color,
+ Attr => Grey);
+
+ Res : constant Eti_Error := Set_Menu_Grey (Men, Chtype_To_CInt (Ch));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Grey;
+
+ procedure Grey (Men : in Menu;
+ Grey : out Character_Attribute_Set)
+ is
+ function Menu_Grey (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Grey, "menu_grey");
+ begin
+ Grey := CInt_To_Chtype (Menu_Grey (Men)).Attr;
+ end Grey;
+
+ procedure Grey (Men : in Menu;
+ Grey : out Character_Attribute_Set;
+ Color : out Color_Pair)
+ is
+ function Menu_Grey (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Grey, "menu_grey");
+ begin
+ Grey := CInt_To_Chtype (Menu_Grey (Men)).Attr;
+ Color := CInt_To_Chtype (Menu_Grey (Men)).Color;
+ end Grey;
+
+ procedure Set_Pad_Character (Men : in Menu;
+ Pad : in Character := Space)
+ is
+ function Set_Menu_Pad (Men : Menu;
+ Ch : C_Int) return C_Int;
+ pragma Import (C, Set_Menu_Pad, "set_menu_pad");
+
+ Res : constant Eti_Error := Set_Menu_Pad (Men,
+ C_Int (Character'Pos (Pad)));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Pad_Character;
+
+ procedure Pad_Character (Men : in Menu;
+ Pad : out Character)
+ is
+ function Menu_Pad (Men : Menu) return C_Int;
+ pragma Import (C, Menu_Pad, "menu_pad");
+ begin
+ Pad := Character'Val (Menu_Pad (Men));
+ end Pad_Character;
+-------------------------------------------------------------------------------
+ procedure Set_Spacing (Men : in Menu;
+ Descr : in Column_Position := 0;
+ Row : in Line_Position := 0;
+ Col : in Column_Position := 0)
+ is
+ function Set_Spacing (Men : Menu;
+ D, R, C : C_Int) return C_Int;
+ pragma Import (C, Set_Spacing, "set_menu_spacing");
+
+ Res : constant Eti_Error := Set_Spacing (Men,
+ C_Int (Descr),
+ C_Int (Row),
+ C_Int (Col));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Spacing;
+
+ procedure Spacing (Men : in Menu;
+ Descr : out Column_Position;
+ Row : out Line_Position;
+ Col : out Column_Position)
+ is
+ type C_Int_Access is access all C_Int;
+ function Get_Spacing (Men : Menu;
+ D, R, C : C_Int_Access) return C_Int;
+ pragma Import (C, Get_Spacing, "menu_spacing");
+
+ D, R, C : aliased C_Int;
+ Res : constant Eti_Error := Get_Spacing (Men,
+ D'Access,
+ R'Access,
+ C'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ Descr := Column_Position (D);
+ Row := Line_Position (R);
+ Col := Column_Position (C);
+ end if;
+ end Spacing;
+-------------------------------------------------------------------------------
+ function Set_Pattern (Men : Menu;
+ Text : String) return Boolean
+ is
+ type Char_Ptr is access all Interfaces.C.Char;
+ function Set_Pattern (Men : Menu;
+ Pattern : Char_Ptr) return C_Int;
+ pragma Import (C, Set_Pattern, "set_menu_pattern");
+
+ S : char_array (0 .. Text'Length);
+ L : size_t;
+ Res : Eti_Error;
+ begin
+ To_C (Text, S, L);
+ Res := Set_Pattern (Men, S (S'First)'Access);
+ case Res is
+ when E_No_Match => return False;
+ when E_Ok => return True;
+ when others =>
+ Eti_Exception (Res);
+ return False;
+ end case;
+ end Set_Pattern;
+
+ procedure Pattern (Men : in Menu;
+ Text : out String)
+ is
+ function Get_Pattern (Men : Menu) return chars_ptr;
+ pragma Import (C, Get_Pattern, "menu_pattern");
+ begin
+ Fill_String (Get_Pattern (Men), Text);
+ end Pattern;
+-------------------------------------------------------------------------------
+ procedure Set_Format (Men : in Menu;
+ Lines : in Line_Count;
+ Columns : in Column_Count)
+ is
+ function Set_Menu_Fmt (Men : Menu;
+ Lin : C_Int;
+ Col : C_Int) return C_Int;
+ pragma Import (C, Set_Menu_Fmt, "set_menu_format");
+
+ Res : constant Eti_Error := Set_Menu_Fmt (Men,
+ C_Int (Lines),
+ C_Int (Columns));
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Format;
+
+ procedure Format (Men : in Menu;
+ Lines : out Line_Count;
+ Columns : out Column_Count)
+ is
+ type C_Int_Access is access all C_Int;
+ function Menu_Fmt (Men : Menu;
+ Y, X : C_Int_Access) return C_Int;
+ pragma Import (C, Menu_Fmt, "menu_format");
+
+ L, C : aliased C_Int;
+ Res : constant Eti_Error := Menu_Fmt (Men, L'Access, C'Access);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ else
+ Lines := Line_Count (L);
+ Columns := Column_Count (C);
+ end if;
+ end Format;
+-------------------------------------------------------------------------------
+ procedure Set_Item_Init_Hook (Men : in Menu;
+ Proc : in Menu_Hook_Function)
+ is
+ function Set_Item_Init (Men : Menu;
+ Proc : Menu_Hook_Function) return C_Int;
+ pragma Import (C, Set_Item_Init, "set_item_init");
+
+ Res : constant Eti_Error := Set_Item_Init (Men, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Item_Init_Hook;
+
+ procedure Set_Item_Term_Hook (Men : in Menu;
+ Proc : in Menu_Hook_Function)
+ is
+ function Set_Item_Term (Men : Menu;
+ Proc : Menu_Hook_Function) return C_Int;
+ pragma Import (C, Set_Item_Term, "set_item_term");
+
+ Res : constant Eti_Error := Set_Item_Term (Men, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Item_Term_Hook;
+
+ procedure Set_Menu_Init_Hook (Men : in Menu;
+ Proc : in Menu_Hook_Function)
+ is
+ function Set_Menu_Init (Men : Menu;
+ Proc : Menu_Hook_Function) return C_Int;
+ pragma Import (C, Set_Menu_Init, "set_menu_init");
+
+ Res : constant Eti_Error := Set_Menu_Init (Men, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Menu_Init_Hook;
+
+ procedure Set_Menu_Term_Hook (Men : in Menu;
+ Proc : in Menu_Hook_Function)
+ is
+ function Set_Menu_Term (Men : Menu;
+ Proc : Menu_Hook_Function) return C_Int;
+ pragma Import (C, Set_Menu_Term, "set_menu_term");
+
+ Res : constant Eti_Error := Set_Menu_Term (Men, Proc);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ end Set_Menu_Term_Hook;
+
+ function Get_Item_Init_Hook (Men : Menu) return Menu_Hook_Function
+ is
+ function Item_Init (Men : Menu) return Menu_Hook_Function;
+ pragma Import (C, Item_Init, "item_init");
+ begin
+ return Item_Init (Men);
+ end Get_Item_Init_Hook;
+
+ function Get_Item_Term_Hook (Men : Menu) return Menu_Hook_Function
+ is
+ function Item_Term (Men : Menu) return Menu_Hook_Function;
+ pragma Import (C, Item_Term, "item_term");
+ begin
+ return Item_Term (Men);
+ end Get_Item_Term_Hook;
+
+ function Get_Menu_Init_Hook (Men : Menu) return Menu_Hook_Function
+ is
+ function Menu_Init (Men : Menu) return Menu_Hook_Function;
+ pragma Import (C, Menu_Init, "menu_init");
+ begin
+ return Menu_Init (Men);
+ end Get_Menu_Init_Hook;
+
+ function Get_Menu_Term_Hook (Men : Menu) return Menu_Hook_Function
+ is
+ function Menu_Term (Men : Menu) return Menu_Hook_Function;
+ pragma Import (C, Menu_Term, "menu_term");
+ begin
+ return Menu_Term (Men);
+ end Get_Menu_Term_Hook;
+-------------------------------------------------------------------------------
+ -- This is a bit delicate if we want to manipulate an Ada created menu
+ -- from C routines or vice versa.
+ -- In Ada created menus we use the low level user pointer to maintain
+ -- binding internal additional informations about the menu. This
+ -- internal information contains a hook for the Ada provided user pointer.
+ -- Unless you understand this implementation, the safest way in mixed
+ -- language programs to deal with user pointers is, that only the language
+ -- that created the menu should also manipulate the user pointer for that
+ -- menu.
+ procedure Redefine (Men : in Menu;
+ Items : in Item_Array)
+ is
+ function Set_Items (Men : Menu;
+ Items : Item_Array_Access) return C_Int;
+ pragma Import (C, Set_Items, "set_menu_items");
+
+ function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access;
+ pragma Import (C, Menu_Userptr, "menu_userptr");
+
+ U : Ada_User_Wrapper_Access := Menu_Userptr (Men);
+ I : Item_Array_Access;
+ Res : Eti_Error;
+ begin
+ if U = null or else U.I = null then raise Menu_Exception;
+ else
+ -- create internally an array of items that contains an
+ -- additional place for the terminating null item.
+ I := new Item_Array (1 .. (Items'Length + 1));
+ I.all (1 .. Items'Length) := Items (Items'First .. Items'Last);
+ I.all (Items'Length + 1) := Null_Item;
+ Res := Set_Items (Men, I);
+ if Res /= E_Ok then
+ Free_Allocated_Items (I);
+ Eti_Exception (Res);
+ else
+ Free_Allocated_Items (U.I);
+ U.I := I;
+ end if;
+ end if;
+ end Redefine;
+
+ function Item_Count (Men : Menu) return Natural
+ is
+ function Count (Men : Menu) return C_Int;
+ pragma Import (C, Count, "item_count");
+ begin
+ return Natural (Count (Men));
+ end Item_Count;
+
+ function Items (Men : Menu) return Item_Array_Access
+ is
+ function M_Items (Men : Menu) return Item_Array_Access;
+ pragma Import (C, M_Items, "menu_items");
+ begin
+ return M_Items (Men);
+ end Items;
+
+-------------------------------------------------------------------------------
+ function Create (Items : Item_Array) return Menu
+ is
+ function Newmenu (Items : Item_Array_Access) return Menu;
+ pragma Import (C, Newmenu, "new_menu");
+
+ function Set_Menu_Userptr (Men : Menu;
+ Addr : Ada_User_Wrapper_Access) return C_Int;
+ pragma Import (C, Set_Menu_Userptr, "set_menu_userptr");
+
+ M : Menu;
+ I : Item_Array_Access;
+ U : Ada_User_Wrapper_Access;
+ Res : Eti_Error;
+ begin
+ I := new Item_Array (1 .. (Items'Length + 1));
+ I.all (1 .. Items'Length) := Items (Items'First .. Items'Last);
+ I.all (Items'Length + 1) := Null_Item;
+ M := Newmenu (I);
+ if M = Null_Menu then
+ Free_Allocated_Items (I);
+ raise Menu_Exception;
+ end if;
+ U := new Ada_User_Wrapper' (System.Null_Address, I);
+ Res := Set_Menu_Userptr (M, U);
+ if Res /= E_Ok then
+ Free_Allocated_Items (I);
+ Free_User_Wrapper (U);
+ Eti_Exception (Res);
+ end if;
+ return M;
+ end Create;
+
+ procedure Delete (Men : in out Menu)
+ is
+ function Free (Men : Menu) return C_Int;
+ pragma Import (C, Free, "free_menu");
+ function Menu_Userptr (Men : Menu) return Ada_User_Wrapper_Access;
+ pragma Import (C, Menu_Userptr, "menu_userptr");
+
+ U : Ada_User_Wrapper_Access := Menu_Userptr (Men);
+ Res : constant Eti_Error := Free (Men);
+ begin
+ if Res /= E_Ok then
+ Eti_Exception (Res);
+ end if;
+ if U = null or else U.I = null then
+ raise Menu_Exception;
+ end if;
+ Free_Allocated_Items (U.I);
+ Free_User_Wrapper (U);
+ Men := Null_Menu;
+ end Delete;
+
+------------------------------------------------------------------------------
+ function Driver (Men : Menu;
+ Key : Key_Code) return Driver_Result
+ is
+ function Driver (Men : Menu;
+ Key : C_Int) return C_Int;
+ pragma Import (C, Driver, "menu_driver");
+
+ R : Eti_Error := Driver (Men, C_Int (Key));
+ begin
+ if R /= E_Ok then
+ case R is
+ when E_Unknown_Command => return Unknown_Request;
+ when E_No_Match => return No_Match;
+ when E_Request_Denied |
+ E_Not_Selectable => return Request_Denied;
+ when others =>
+ Eti_Exception (R);
+ end case;
+ end if;
+ return Menu_Ok;
+ end Driver;
+-------------------------------------------------------------------------------
+begin
+ if Generation_Bit_Order /= System.Default_Bit_Order then
+ raise Constraint_Error;
+ end if;
+
+ Default_Menu_Options := Get_Options (Null_Menu);
+ Default_Item_Options := Get_Options (Null_Item);
+end Terminal_Interface.Curses.Menus;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Mouse --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with System;
+
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with Interfaces;
+with Interfaces.C;
+with Unchecked_Conversion;
+
+package body Terminal_Interface.Curses.Mouse is
+
+ use type System.Bit_Order;
+ use type Interfaces.C.int;
+
+ function CInt_To_Mask is new
+ Unchecked_Conversion (Source => C_Int,
+ Target => Event_Mask);
+
+ function Mask_To_CInt is new
+ Unchecked_Conversion (Source => Event_Mask,
+ Target => C_Int);
+
+ function Get_Mouse return Mouse_Event
+ is
+ type Event_Access is access all Mouse_Event;
+
+ function Getmouse (Ev : Event_Access) return C_Int;
+ pragma Import (C, Getmouse, "getmouse");
+
+ Event : aliased Mouse_Event;
+ begin
+ if Getmouse (Event'Access) = Curses_Err then
+ raise Curses_Exception;
+ end if;
+ return Event;
+ end Get_Mouse;
+
+ procedure Register_Reportable_Event (B : in Mouse_Button;
+ S : in Button_State;
+ Mask : in out Event_Mask)
+ is
+ type Evt_Access is access all Event_Mask;
+ function Register (B : C_Int;
+ S : C_Int;
+ M : Evt_Access) return C_Int;
+ pragma Import (C, Register, "_nc_ada_mouse_mask");
+
+ T : aliased Event_Mask := Mask;
+ M : Evt_Access := T'Access;
+ R : constant C_Int := Register (C_Int (Mouse_Button'Pos (B)),
+ C_Int (Button_State'Pos (S)),
+ M);
+ begin
+ if R = Curses_Err then
+ raise Curses_Exception;
+ end if;
+ Mask := T;
+ end Register_Reportable_Event;
+
+ function Start_Mouse (Mask : Event_Mask := All_Events)
+ return Event_Mask
+ is
+ type Int_Access is access all C_Int;
+ function MMask (M : C_Int; O : Int_Access := null) return C_Int;
+ pragma Import (C, MMask, "mousemask");
+ R : C_Int;
+ begin
+ R := MMask (Mask_To_CInt (Mask));
+ return CInt_To_Mask (R);
+ end Start_Mouse;
+
+ procedure Get_Event (Event : in Mouse_Event;
+ Y : out Line_Position;
+ X : out Column_Position;
+ Button : out Mouse_Button;
+ State : out Button_State)
+ is
+ procedure Dispatch_Event (M : in C_Int;
+ B : out C_Int;
+ S : out C_Int);
+ pragma Import (C, Dispatch_Event, "_nc_ada_mouse_event");
+
+ Mask : constant Interfaces.C.int := Mask_To_CInt (Event.Bstate);
+ B, S : C_Int;
+ begin
+ X := Column_Position (Event.X);
+ Y := Line_Position (Event.Y);
+ Dispatch_Event (Mask, B, S);
+ Button := Mouse_Button'Val (B);
+ State := Button_State'Val (S);
+ end Get_Event;
+
+ procedure Unget_Mouse (Event : in Mouse_Event)
+ is
+ function Ungetmouse (Ev : Mouse_Event) return C_Int;
+ pragma Import (C, Ungetmouse, "ungetmouse");
+ begin
+ if Ungetmouse (Event) = Curses_Err then
+ raise Curses_Exception;
+ end if;
+ end Unget_Mouse;
+
+ function Enclosed_In_Window (Win : Window := Standard_Window;
+ Event : Mouse_Event) return Boolean
+ is
+ function Wenclose (Win : Window; Y : C_Int; X : C_Int) return C_Int;
+ pragma Import (C, Wenclose, "wenclose");
+ begin
+ if Wenclose (Win, C_Int (Event.Y), C_Int (Event.X)) = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Enclosed_In_Window;
+
+ function Mouse_Interval (Msec : Natural := 200) return Natural
+ is
+ function Mouseinterval (Msec : C_Int) return C_Int;
+ pragma Import (C, Mouseinterval, "mouseinterval");
+ begin
+ return Natural (Mouseinterval (C_Int (Msec)));
+ end Mouse_Interval;
+
+begin
+ if Generation_Bit_Order /= System.Default_Bit_Order then
+ raise Constraint_Error;
+ end if;
+end Terminal_Interface.Curses.Mouse;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Panels.User_Data --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Interfaces.C;
+with Terminal_Interface.Curses.Aux;
+use Terminal_Interface.Curses.Aux;
+with Terminal_Interface.Curses.Panels;
+use Terminal_Interface.Curses.Panels;
+
+package body Terminal_Interface.Curses.Panels.User_Data is
+
+ use type Interfaces.C.int;
+
+ procedure Set_User_Data (Pan : in Panel;
+ Data : in User_Access)
+ is
+ function Set_Panel_Userptr (Pan : Panel;
+ Addr : User_Access) return C_Int;
+ pragma Import (C, Set_Panel_Userptr, "set_panel_userptr");
+ begin
+ if Set_Panel_Userptr (Pan, Data) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Set_User_Data;
+
+ procedure Get_User_Data (Pan : in Panel;
+ Data : out User_Access)
+ is
+ function Panel_Userptr (Pan : Panel) return User_Access;
+ pragma Import (C, Panel_Userptr, "panel_userptr");
+ begin
+ Data := Panel_Userptr (Pan);
+ end Get_User_Data;
+
+end Terminal_Interface.Curses.Panels.User_Data;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Panels --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Terminal_Interface.Curses.Aux; use Terminal_Interface.Curses.Aux;
+with Interfaces.C;
+
+package body Terminal_Interface.Curses.Panels is
+
+ use type Interfaces.C.int;
+
+ function Create (Win : Window) return Panel
+ is
+ function Newpanel (Win : Window) return Panel;
+ pragma Import (C, Newpanel, "new_panel");
+
+ Pan : Panel;
+ begin
+ Pan := Newpanel (Win);
+ if Pan = Null_Panel then
+ raise Panel_Exception;
+ end if;
+ return Pan;
+ end Create;
+
+ procedure Bottom (Pan : in Panel)
+ is
+ function Bottompanel (Pan : Panel) return C_Int;
+ pragma Import (C, Bottompanel, "bottom_panel");
+ begin
+ if Bottompanel (Pan) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Bottom;
+
+ procedure Top (Pan : in Panel)
+ is
+ function Toppanel (Pan : Panel) return C_Int;
+ pragma Import (C, Toppanel, "top_panel");
+ begin
+ if Toppanel (Pan) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Top;
+
+ procedure Show (Pan : in Panel)
+ is
+ function Showpanel (Pan : Panel) return C_Int;
+ pragma Import (C, Showpanel, "show_panel");
+ begin
+ if Showpanel (Pan) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Show;
+
+ procedure Hide (Pan : in Panel)
+ is
+ function Hidepanel (Pan : Panel) return C_Int;
+ pragma Import (C, Hidepanel, "hide_panel");
+ begin
+ if Hidepanel (Pan) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Hide;
+
+ function Get_Window (Pan : Panel) return Window
+ is
+ function Panel_Win (Pan : Panel) return Window;
+ pragma Import (C, Panel_Win, "panel_window");
+
+ Win : Window := Panel_Win (Pan);
+ begin
+ if Win = Null_Window then
+ raise Panel_Exception;
+ end if;
+ return Win;
+ end Get_Window;
+
+ procedure Replace (Pan : in Panel;
+ Win : in Window)
+ is
+ function Replace_Pan (Pan : Panel;
+ Win : Window) return C_Int;
+ pragma Import (C, Replace_Pan, "replace_panel");
+ begin
+ if Replace_Pan (Pan, Win) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Replace;
+
+ procedure Move (Pan : in Panel;
+ Line : in Line_Position;
+ Column : in Column_Position)
+ is
+ function Move (Pan : Panel;
+ Line : C_Int;
+ Column : C_Int) return C_Int;
+ pragma Import (C, Move, "move_panel");
+ begin
+ if Move (Pan, C_Int (Line), C_Int (Column)) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ end Move;
+
+ function Is_Hidden (Pan : Panel) return Boolean
+ is
+ function Panel_Hidden (Pan : Panel) return C_Int;
+ pragma Import (C, Panel_Hidden, "panel_hidden");
+ begin
+ if Panel_Hidden (Pan) = Curses_False then
+ return False;
+ else
+ return True;
+ end if;
+ end Is_Hidden;
+
+ procedure Delete (Pan : in out Panel)
+ is
+ function Del_Panel (Pan : Panel) return C_Int;
+ pragma Import (C, Del_Panel, "del_panel");
+ begin
+ if Del_Panel (Pan) = Curses_Err then
+ raise Panel_Exception;
+ end if;
+ Pan := Null_Panel;
+ end Delete;
+
+end Terminal_Interface.Curses.Panels;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Aux --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.4 $
+------------------------------------------------------------------------------
+package body Terminal_Interface.Curses.Text_IO.Aux is
+
+ procedure Put_Buf
+ (Win : in Window;
+ Buf : in String;
+ Width : in Field;
+ Signal : in Boolean := True;
+ Ljust : in Boolean := False)
+ is
+ L : Field;
+ Len : Field;
+ W : Field := Width;
+ LC : Line_Count;
+ CC : Column_Count;
+ Y : Line_Position;
+ X : Column_Position;
+
+ procedure Output (From, To : Field);
+
+ procedure Output (From, To : Field)
+ is
+ begin
+ if Len > 0 then
+ if W = 0 then
+ W := Len;
+ end if;
+ if Len > W then
+ -- LRM A10.6 (7) says this
+ W := Len;
+ end if;
+
+ pragma Assert (Len <= W);
+ Get_Size (Win, LC, CC);
+ if Column_Count (Len) > CC then
+ if Signal then
+ raise Layout_Error;
+ else
+ return;
+ end if;
+ else
+ if Len < W and then not Ljust then
+ declare
+ Filler : constant String (1 .. (W - Len))
+ := (others => ' ');
+ begin
+ Put (Win, Filler);
+ end;
+ end if;
+ Get_Cursor_Position (Win, Y, X);
+ if (X + Column_Position (Len)) > CC then
+ New_Line (Win);
+ end if;
+ Put (Win, Buf (From .. To));
+ if Len < W and then Ljust then
+ declare
+ Filler : constant String (1 .. (W - Len))
+ := (others => ' ');
+ begin
+ Put (Win, Filler);
+ end;
+ end if;
+ end if;
+ end if;
+ end Output;
+
+ begin
+ pragma Assert (Win /= Null_Window);
+ if Ljust then
+ L := 1;
+ for I in 1 .. Buf'Length loop
+ exit when Buf (L) = ' ';
+ L := L + 1;
+ end loop;
+ Len := L - 1;
+ Output (1, Len);
+ else -- input buffer is not left justified
+ L := Buf'Length;
+ for I in 1 .. Buf'Length loop
+ exit when Buf (L) = ' ';
+ L := L - 1;
+ end loop;
+ Len := Buf'Length - L;
+ Output (L + 1, Buf'Length);
+ end if;
+ end Put_Buf;
+
+end Terminal_Interface.Curses.Text_IO.Aux;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Aux --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.4 $
+------------------------------------------------------------------------------
+private package Terminal_Interface.Curses.Text_IO.Aux is
+
+ -- This routine is called from the Text_IO output routines for numeric
+ -- and enumeration types.
+ --
+ procedure Put_Buf
+ (Win : in Window; -- The output window
+ Buf : in String; -- The buffer containing the text
+ Width : in Field; -- The width of the output field
+ Signal : in Boolean := True; -- If true, we raise Layout_Error
+ Ljust : in Boolean := False); -- The Buf is left justified
+
+end Terminal_Interface.Curses.Text_IO.Aux;
+
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Complex_IO --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Terminal_Interface.Curses.Text_IO.Float_IO;
+
+package body Terminal_Interface.Curses.Text_IO.Complex_IO is
+
+ package FIO is new
+ Terminal_Interface.Curses.Text_IO.Float_IO (Complex_Types.Real'Base);
+
+ procedure Put
+ (Win : in Window;
+ Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Win, '(');
+ FIO.Put (Win, Item.Re, Fore, Aft, Exp);
+ Put (Win, ',');
+ FIO.Put (Win, Item.Im, Fore, Aft, Exp);
+ Put (Win, ')');
+ end Put;
+
+ procedure Put
+ (Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ begin
+ Put (Get_Window, Item, Fore, Aft, Exp);
+ end Put;
+
+end Terminal_Interface.Curses.Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Complex_IO --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Ada.Numerics.Generic_Complex_Types;
+
+generic
+ with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>);
+
+package Terminal_Interface.Curses.Text_IO.Complex_IO is
+
+ use Complex_Types;
+
+ Default_Fore : Field := 2;
+ Default_Aft : Field := Real'Digits - 1;
+ Default_Exp : Field := 3;
+
+ procedure Put
+ (Win : in Window;
+ Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Complex;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+private
+ pragma Inline (Put);
+
+end Terminal_Interface.Curses.Text_IO.Complex_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Decimal_IO --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Ada.Text_IO;
+with Terminal_Interface.Curses.Text_IO.Aux;
+
+package body Terminal_Interface.Curses.Text_IO.Decimal_IO is
+
+ package Aux renames Terminal_Interface.Curses.Text_IO.Aux;
+ package DIO is new Ada.Text_IO.Decimal_IO (Num);
+
+ procedure Put
+ (Win : in Window;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ Buf : String (1 .. Field'Last);
+ Len : Field := Fore + 1 + Aft;
+ begin
+ if Exp > 0 then
+ Len := Len + 1 + Exp;
+ end if;
+ DIO.Put (Buf, Item, Aft, Exp);
+ Aux.Put_Buf (Win, Buf, Len, False);
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp) is
+ begin
+ Put (Get_Window, Item, Fore, Aft, Exp);
+ end Put;
+
+end Terminal_Interface.Curses.Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Decimal_IO --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.4 $
+------------------------------------------------------------------------------
+generic
+ type Num is delta <> digits <>;
+
+package Terminal_Interface.Curses.Text_IO.Decimal_IO is
+
+ Default_Fore : Field := Num'Fore;
+ Default_Aft : Field := Num'Aft;
+ Default_Exp : Field := 0;
+
+ procedure Put
+ (Win : in Window;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp);
+
+private
+ pragma Inline (Put);
+
+end Terminal_Interface.Curses.Text_IO.Decimal_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Enumeration_IO --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Ada.Text_IO;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Terminal_Interface.Curses.Text_IO.Aux;
+
+package body Terminal_Interface.Curses.Text_IO.Enumeration_IO is
+
+ package Aux renames Terminal_Interface.Curses.Text_IO.Aux;
+ package EIO is new Ada.Text_IO.Enumeration_IO (Enum);
+
+ procedure Put
+ (Win : in Window;
+ Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting)
+ is
+ Buf : String (1 .. Field'Last);
+ Tset : Ada.Text_IO.Type_Set;
+ begin
+ if Set /= Mixed_Case then
+ Tset := Ada.Text_IO.Type_Set'Val (Type_Set'Pos (Set));
+ else
+ Tset := Ada.Text_IO.Lower_Case;
+ end if;
+ EIO.Put (Buf, Item, Tset);
+ if Set = Mixed_Case then
+ Buf (Buf'First) := To_Upper (Buf (Buf'First));
+ end if;
+ Aux.Put_Buf (Win, Buf, Width, True, True);
+ end Put;
+
+ procedure Put
+ (Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting)
+ is
+ begin
+ Put (Get_Window, Item, Width, Set);
+ end Put;
+
+end Terminal_Interface.Curses.Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Enumeration_IO --
+-- --
+-- S P E C --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.4 $
+------------------------------------------------------------------------------
+generic
+ type Enum is (<>);
+
+package Terminal_Interface.Curses.Text_IO.Enumeration_IO is
+
+ Default_Width : Field := 0;
+ Default_Setting : Type_Set := Mixed_Case;
+
+ procedure Put
+ (Win : in Window;
+ Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting);
+
+ procedure Put
+ (Item : in Enum;
+ Width : in Field := Default_Width;
+ Set : in Type_Set := Default_Setting);
+
+private
+ pragma Inline (Put);
+
+end Terminal_Interface.Curses.Text_IO.Enumeration_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Fixed_IO --
+-- --
+-- B O D Y --
+-- --
+-- Version 00.92 --
+-- --
+-- The ncurses Ada95 binding is copyrighted 1996 by --
+-- Juergen Pfeifer, Email: Juergen.Pfeifer@T-Online.de --
+-- --
+-- Permission is hereby granted to reproduce and distribute this --
+-- binding by any means and for any fee, whether alone or as part --
+-- of a larger distribution, in source or in binary form, PROVIDED --
+-- this notice is included with any such distribution, and is not --
+-- removed from any of its header files. Mention of ncurses and the --
+-- author of this binding in any applications linked with it is --
+-- highly appreciated. --
+-- --
+-- This binding comes AS IS with no warranty, implied or expressed. --
+------------------------------------------------------------------------------
+-- Version Control:
+-- $Revision: 1.3 $
+------------------------------------------------------------------------------
+with Ada.Text_IO;
+with Terminal_Interface.Curses.Text_IO.Aux;
+
+package body Terminal_Interface.Curses.Text_IO.Fixed_IO is
+
+ package Aux renames Terminal_Interface.Curses.Text_IO.Aux;
+ package FIXIO is new Ada.Text_IO.Fixed_IO (Num);
+
+ procedure Put
+ (Win : in Window;
+ Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp)
+ is
+ Buf : String (1 .. Field'Last);
+ Len : Field := Fore + 1 + Aft;
+ begin
+ if Exp > 0 then
+ Len := Len + 1 + Exp;
+ end if;
+ FIXIO.Put (Buf, Item, Aft, Exp);
+ Aux.Put_Buf (Win, Buf, Len, False);
+ end Put;
+
+ procedure Put
+ (Item : in Num;
+ Fore : in Field := Default_Fore;
+ Aft : in Field := Default_Aft;
+ Exp : in Field := Default_Exp) is
+ begin
+ Put (Get_Window, Item, Fore, Aft, Exp);
+ end Put;
+
+end Terminal_Interface.Curses.Text_IO.Fixed_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT ncurses Binding --
+-- --
+-- Terminal_Interface.Curses.Text_IO.Fixed_IO --
+-- --
+-- S P E C --
+--
projects / ncurses.git / commitdiff