paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 22:49:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

* added nwsnut demo for netware

Browse Source
This commit is contained in:
armin 2005-01-04 11:44:47 +00:00
parent 27fcfc44ff
commit b611829203
9 changed files with 2289 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
demo/Makefile
View File

@ -1,5 +1,5 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/12/29]
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/12/30]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom morphos netwlibc
@ -237,6 +237,9 @@ endif
ifeq ($(OS_TARGET),netware)
override TARGET_DIRS+=netware
endif
ifeq ($(OS_TARGET),netwlibc)
override TARGET_DIRS+=netwlibc
endif
override INSTALL_FPCPACKAGE=y
ifdef REQUIRE_UNITSDIR
override UNITSDIR+=$(REQUIRE_UNITSDIR)
@ -1630,6 +1633,9 @@ endif
ifeq ($(OS_TARGET),netware)
TARGET_DIRS_NETWARE=1
endif
ifeq ($(OS_TARGET),netwlibc)
TARGET_DIRS_NETWLIBC=1
endif
ifdef TARGET_DIRS_TEXT
text_all:
$(MAKE) -C text all
@ -1945,6 +1951,51 @@ netware:
$(MAKE) -C netware all
.PHONY: netware_all netware_debug netware_smart netware_release netware_units netware_examples netware_shared netware_install netware_sourceinstall netware_exampleinstall netware_distinstall netware_zipinstall netware_zipsourceinstall netware_zipexampleinstall netware_zipdistinstall netware_clean netware_distclean netware_cleanall netware_info netware_makefiles netware
endif
ifdef TARGET_DIRS_NETWLIBC
netwlibc_all:
$(MAKE) -C netwlibc all
netwlibc_debug:
$(MAKE) -C netwlibc debug
netwlibc_smart:
$(MAKE) -C netwlibc smart
netwlibc_release:
$(MAKE) -C netwlibc release
netwlibc_units:
$(MAKE) -C netwlibc units
netwlibc_examples:
$(MAKE) -C netwlibc examples
netwlibc_shared:
$(MAKE) -C netwlibc shared
netwlibc_install:
$(MAKE) -C netwlibc install
netwlibc_sourceinstall:
$(MAKE) -C netwlibc sourceinstall
netwlibc_exampleinstall:
$(MAKE) -C netwlibc exampleinstall
netwlibc_distinstall:
$(MAKE) -C netwlibc distinstall
netwlibc_zipinstall:
$(MAKE) -C netwlibc zipinstall
netwlibc_zipsourceinstall:
$(MAKE) -C netwlibc zipsourceinstall
netwlibc_zipexampleinstall:
$(MAKE) -C netwlibc zipexampleinstall
netwlibc_zipdistinstall:
$(MAKE) -C netwlibc zipdistinstall
netwlibc_clean:
$(MAKE) -C netwlibc clean
netwlibc_distclean:
$(MAKE) -C netwlibc distclean
netwlibc_cleanall:
$(MAKE) -C netwlibc cleanall
netwlibc_info:
$(MAKE) -C netwlibc info
netwlibc_makefiles:
$(MAKE) -C netwlibc makefiles
netwlibc:
$(MAKE) -C netwlibc all
.PHONY: netwlibc_all netwlibc_debug netwlibc_smart netwlibc_release netwlibc_units netwlibc_examples netwlibc_shared netwlibc_install netwlibc_sourceinstall netwlibc_exampleinstall netwlibc_distinstall netwlibc_zipinstall netwlibc_zipsourceinstall netwlibc_zipexampleinstall netwlibc_zipdistinstall netwlibc_clean netwlibc_distclean netwlibc_cleanall netwlibc_info netwlibc_makefiles netwlibc
endif
all: $(addsuffix _all,$(TARGET_DIRS))
debug: $(addsuffix _debug,$(TARGET_DIRS))
smart: $(addsuffix _smart,$(TARGET_DIRS))

1
demo/Makefile.fpc
View File

@ -13,6 +13,7 @@ dirs_win32=win32 graph
dirs_linux=linux graph
dirs_os2=os2 graph
dirs_netware=netware
dirs_netwlibc=netwlibc
[install]
fpcpackage=y

19
demo/fpcdemos.txt
View File

@ -2,15 +2,16 @@ FPC demo package
================
This packages contains the following subdirs:
- text text mode demos (should run everywhere)
- graph demos those use the graph unit (runs nearly everywhere)
includes gameunit (text&graph), outputs to another subdir level
- modex demos those make extensive use of modeX (runs with go32v2 only)
- win32 demos those are win32 specific
- linux demos those are linux specific
- os2 demos those are OS/2 specific
- palmos demos those are palmos specific (dragonball)
- netware demos those are netware(clib) specific
- text text mode demos (should run everywhere)
- graph demos those use the graph unit (runs nearly everywhere)
includes gameunit (text&graph), outputs to another subdir level
- modex demos those make extensive use of modeX (runs with go32v2 only)
- win32 demos those are win32 specific
- linux demos those are linux specific
- os2 demos those are OS/2 specific
- palmos demos those are palmos specific (dragonball)
- netware demos those are netware(clib) specific
- netwlibc demos those are netware(libc) specific
To build the programs simply type 'make' in the base dir. Do do
a cross build, type make OS_TARGET=crosstarget, i.e.

167
demo/netware/Makefile
View File

@ -1,8 +1,8 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/12/29]
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/12/30]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom morphos netwlibc
MAKEFILETARGETS=netware
BSDs = freebsd netbsd openbsd darwin
UNIXs = linux $(BSDs) sunos qnx
LIMIT83fs = go32v2 os2 emx watcom
@ -220,7 +220,7 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
endif
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
ifeq ($(OS_TARGET),netware)
override TARGET_PROGRAMS+=nutmon check
override TARGET_PROGRAMS+=nutmon check nuttest
endif
ifdef REQUIRE_UNITSDIR
override UNITSDIR+=$(REQUIRE_UNITSDIR)
@ -951,171 +951,11 @@ TAROPT=vz
TAREXT=.tar.gz
endif
override REQUIRE_PACKAGES=rtl
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),x86_64)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),linux)
ifeq ($(CPU_TARGET),arm)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),go32v2)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),win32)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),os2)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),freebsd)
ifeq ($(CPU_TARGET),x86_64)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),beos)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),netbsd)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),amiga)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),atari)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),sunos)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),sunos)
ifeq ($(CPU_TARGET),sparc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),qnx)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),netware)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),openbsd)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),openbsd)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),wdosx)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),palmos)
ifeq ($(CPU_TARGET),m68k)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),macos)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),darwin)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),emx)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),watcom)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),morphos)
ifeq ($(CPU_TARGET),powerpc)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifeq ($(OS_TARGET),netwlibc)
ifeq ($(CPU_TARGET),i386)
REQUIRE_PACKAGES_RTL=1
endif
endif
ifdef REQUIRE_PACKAGES_RTL
PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR))))))
ifneq ($(PACKAGEDIR_RTL),)
@ -1595,3 +1435,4 @@ ifneq ($(wildcard fpcmake.loc),)
include fpcmake.loc
endif
nutmon.nlm: nutmon.pp nutconnection.pp
nuttest.nlm: nuttest.pp ../netwlibc/nuttest.pp

7
demo/netware/Makefile.fpc
View File

@ -1,13 +1,14 @@
#
# Makefile.fpc for FPC Netware demos (part of FPC demo package)
# Makefile.fpc for FPC Netware clib demos (part of FPC demo package)
#
[target]
programs_netware=nutmon check
programs_netware=nutmon check nuttest
[default]
fpcdir=../..
[rules]
nutmon.nlm: nutmon.pp nutconnection.pp
# $(COMPILER) -Dw -Ch8096 -Cs32728 basicpm.pas
nuttest.nlm: nuttest.pp ../netwlibc/nuttest.pp

2
demo/netware/nuttest.pp Normal file
View File

@ -0,0 +1,2 @@
{nuttest.pp is for clib and libc}
{$i ../netwlibc/nuttest.pp}

1437
demo/netwlibc/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

16
demo/netwlibc/Makefile.fpc Normal file
View File

@ -0,0 +1,16 @@
#
# Makefile.fpc for FPC Netware libc demos (part of FPC demo package)
#
[target]
programs_netwlibc=nuttest
[default]
fpcdir=../..
[prerules]
# binutils are the same for targets netware and netwlibc
override BINUTILSPREFIX=$(CPU_TARGET)-netware-
[rules]

763
demo/netwlibc/nuttest.pp Normal file
View File

@ -0,0 +1,763 @@
Program nuttest;
{$if not defined(netware)}
{$error Sorry, this Demo is for netware and netwlibc only}
{$endif}
{$mode objfpc}
{$if defined (netware_libc)}
{$description FreePascal NUT Demo - libc}
{$Screenname FreePascal NWSNUT Demo - libc}
{$else}
{$description FreePascal NUT Demo - clib}
{$Screenname default}
{$endif}
{$Copyright 2005 Armin Diehl <armin@freepascal.org>}
{$Version 1,0,0}
{$if defined(netware_clib)}
uses nwserv,nwsnut,sysutils;
{$else}
uses libc,nwsnut,sysutils;
{$endif}
var
gExiting : boolean = FALSE;
gThreadCount : integer = 0;
gNUTHandle : PNUTInfo = NIL;
const
gMyName = 'NUT Demo';
gMessageTable : array [0..26] of pchar = (
gMyName,
'1.00',
'Exit NUT Demo?',
'NUT Demo',
'NUTDEMO Tag',
'Main Menu',
'Sub-menu option #1',
'Unsorted Sub-menu Example',
'Program Trace Portal',
'Bobby',
'Sub-menu option #2',
'Sub-Menu',
'Bravo',
'Tango',
'Alpha',
'Zulu',
'Unsorted Menu',
'Sorted List',
'Sub-menu Example',
'Item List Example',
'Form Example',
'Menu In Form',
'Option 1',
'Option 2',
'Save Data?',
'Edit String Example',
'Edit Text Exampl');
// keep in sync with above...
PROGRAM_NAME = $0000;
PROGRAM_VERSION = $0001;
PROGRAM_EXIT = $0002;
SCREEN_NAME = $0003;
RS_TAG_NAME = $0004;
MENU_MAIN__HDR = $0005;
MENU_SUB_OPTION1 = $0006;
MENU_MAIN_NOSORT = $0007;
TRACE_PORTAL__HDR = $0008;
MENU_NOSORT_OPTION_A = $0009;
MENU_SUB_OPTION2 = $000A;
MENU_SUB__HDR = $000B;
MENU_NOSORT_OPTION_B = $000C;
MENU_NOSORT_OPTION_C = $000D;
MENU_NOSORT_OPTION_D = $000E;
MENU_NOSORT_OPTION_E = $000F;
MENU_NOSORT__HDR = $0010;
LIST_SUBLIST__HDR = $0011;
MENU_MAIN_SUBMENU = $0012;
MENU_MAIN_LIST = $0013;
MENU_MAIN_FORM = $0014;
MENU_IN_FORM_TITLE = $0015;
FORM_MENU_OPT1 = $0016;
FORM_MENU_OPT2 = $0017;
EXIT_FORM_MSG = $0018;
MENU_MAIN_EDIT_STRING = $0019;
MENU_MAIN_EDIT_TEXT = $001A;
function NLM_VerifyProgramExit : longint; cdecl;
var res : integer;
begin
res := NWSConfirm (PROGRAM_EXIT, // Header
0, // centerLine
0, // Center Column
1, // Default Choice
nil, // Action Procedure
gNUTHandle, // Handle
nil); // Action Parameter
// Escape(-1) means No(0).
if (res = -1) then inc (res);
Result := res;
end;
(****************************************************************************
* Edit a string
****************************************************************************)
procedure NLM_EditStringSub; cdecl;
const
maxLen = 40;
var err : integer;
str : ansistring;
begin
//------------------------------------------------------------------------
// Generate dynamic messages - this allows you to call NUT functions
// and specify messages on the fly
//*/
NWSSetDynamicMessage(DYNAMIC_MESSAGE_ONE, 'String Edit Function',gNUTHandle^.messages);
NWSSetDynamicMessage(DYNAMIC_MESSAGE_TWO, ' Editing can be fun: ',gNUTHandle^.messages);
str := 'String to edit';
setlength (str, maxLen);
err := NWSEditString(
10, // center line
40, // center column
1, // edit height
40, // edit width
DYNAMIC_MESSAGE_ONE, // header msg
DYNAMIC_MESSAGE_TWO, // prompt msg
pchar(str), // buffer
maxLen, // max length of string
EF_ANY OR EF_UPPER, // acceptable chars
gNUTHandle, // nut handle
nil, // insert-key procedure
nil, // action procedure
nil); // parameters
// if escape key was pressed
if (err = 1) then
NWSTrace(gNUTHandle,'String was not saved');
end;
(****************************************************************************
* Edit text in a window
****************************************************************************)
procedure NLM_EditTextSub;
const maxLen = 1024;
var err : integer;
str : ansistring;
begin
// Generate dynamic messages - this allows you to call NUT functions
// and specify messages on the fly
NWSSetDynamicMessage(DYNAMIC_MESSAGE_ONE,'Text Edit Function', gNUTHandle^.messages);
NWSSetDynamicMessage(DYNAMIC_MESSAGE_TWO,'Save changes?', gNUTHandle^.messages);
str := 'This could be any kind of text'#13'that you might have.';
setlength (str,maxLen+1);
// Edit the text in a portal with scroll bars that appear only when the
// text goes beyond the portal bounderies
err := NWSEditTextWithScrollBars (
10, // center line
40, // center column
4, // edit height
40, // edit width
DYNAMIC_MESSAGE_ONE, // header msg
pchar(str), // buffer
maxLen, // max length of string
DYNAMIC_MESSAGE_TWO, // confirm msg
true, // force confirm
SHOW_VERTICAL_SCROLL_BAR OR // // scroll bar props
SHOW_HORIZONTAL_SCROLL_BAR OR
CONSTANT_SCROLL_BARS,
gNUTHandle);
// escape key was pressed
if err = 1 then
NWSTrace(gNUTHandle,'Text was not saved');
end;
function NLM_FormMenuAction (option : longint; param : pointer):longint; cdecl;
begin
// Do anything that might be needed by the selection of a given menu option
// and the value returned will indicate which data item is to be displayed
// in the menu field on the form.
result := option;
end;
function NLM_HotSpotAction (fp : PField; selectKey : longint; var changedField : longint; Handle : PNUTInfo) : longint; cdecl;
begin
// do the work here. . .
NWSTrace(handle, 'This is your hot spot routine');
result :=K_RIGHT; // send us to the next field...
end;
(****************************************************************************
* Form display with various fields
****************************************************************************)
procedure NLM_FormSub;
var
line,
formSaved,
menuChoice,
myInteger,
myHexInteger : longint;
MyOtherInteger : cardinal;
myBoolean : longbool;
myString : ansistring;
mfctl : PMFCONTROL;
begin
myInteger := 600;
myHexInteger := $2ffc;
myOtherInteger := 900;
// Don't do this list if we should be exiting.
if gExiting then exit;
// At this point, the current list is the Main Menu. If we begin adding
// new items to the current list, it would mess up the Main menu (to say
// the least). So, we will save the Main Menu List on the List stack
// (PushList) and then initialize a new form (set head and tail to NULL)
// by calling NWSInitForm().
NWSPushList(gNUTHandle);
NWSInitForm(gNUTHandle);
// Define the fields in the form
line := 0;
NWSAppendCommentField (line, 1, 'Boolean Field:', gNUTHandle);
NWSAppendBoolField (line, 25, NORMAL_FIELD, myBoolean, 0, gNUTHandle);
line += 2;
NWSAppendCommentField (line, 1, 'Integer Field:', gNUTHandle);
NWSAppendIntegerField (line, 25, NORMAL_FIELD, myInteger, 0, 9999, 0, gNUTHandle);
line += 2;
NWSAppendCommentField (line, 1, 'String Field:', gNUTHandle);
myString := 'Data String';
setLength (myString,30);
NWSAppendStringField (line, 25, 30, NORMAL_FIELD, pchar(myString), 'A..Za..z ',0, gNUTHandle);
line += 2;
NWSAppendCommentField (line, 1, 'Unsigned Integer Field:', gNUTHandle);
NWSAppendUnsignedIntegerField (line, 25, NORMAL_FIELD, @myOtherInteger, 0, 99999, 0, gNUTHandle);
line += 2;
NWSAppendCommentField (line, 1, 'Hex Field:', gNUTHandle);
NWSAppendHexField (line, 25, NORMAL_FIELD, @myHexInteger, 0, 99999, 0, gNUTHandle);
line += 2;
NWSAppendCommentField (line, 1, 'Comment Field:', gNUTHandle);
NWSAppendCommentField (line, 25, 'A comment', gNUTHandle);
line += 2;
NWSAppendCommentField (line, 1, 'Hot Spot Field:', gNUTHandle);
NWSAppendHotSpotField (line, 25, NORMAL_FIELD, 'Hot Field', @NLM_HotSpotAction, gNUTHandle);
mfctl := NWSInitMenuField (MENU_IN_FORM_TITLE, 10, 40, @NLM_FormMenuAction, gNUTHandle);
NWSAppendToMenuField (mfctl, FORM_MENU_OPT1, 1, gNUTHandle);
NWSAppendToMenuField (mfctl, FORM_MENU_OPT2, 2, gNUTHandle);
menuChoice := 1; // display the text for option one
line += 2;
NWSAppendCommentField (line, 1, 'Menu Field:', gNUTHandle);
NWSAppendMenuField (line, 25, NORMAL_FIELD, @menuChoice, mfctl, 0, gNUTHandle);
// Edit the form
formSaved := NWSEditPortalForm (
MENU_MAIN_FORM, // I- header
11, // I- center line
40, // I- center col
16, // I- form height
50, // I- form width
F_VERIFY, // I- ctl flags
F_NO_HELP, // I- form help
EXIT_FORM_MSG, // I- confirm msg
gNUTHandle);
// This function returns TRUE if the form was saved, FALSE if not.
// If the form was not saved you must restore all variables to their
// original values manually
if longbool (formSaved) then
NWSTrace(gNUTHandle,'The form data was not saved');
// cleanup and discard this form
NWSDestroyForm(gNUTHandle);
NWSPopList(gNUTHandle);
end;
(****************************************************************************
* Display information in a portal given a selection from the list
****************************************************************************)
procedure NLM_DisplayPortalInformation (selectedItem : pchar);
var
portal : longint;
szTemp : ansistring; //char szTemp[80+1];
portalPCB : PPCB;
begin
// Dim the current portal
NWSDeselectPortal(gNUTHandle);
// Create a portal in which we will display the connection information.
// (A portal is a window).
portal := NWSCreatePortal(
5, // I- line
2, // I- column
10, // I- frameHeight
76, // I- frameWidth
6, // I- virtualHeight
76, // I- virtualWidth
SAVE, // I- saveFlag
selectedItem, // I- headerText
VNORMAL, // I- headerAttribute
SINGLE, // I- borderType
VINTENSE, // I- borderAttribute
CURSOR_OFF, // I- cursorFlag
VIRTUAL, // I- directflag
gNUTHandle);
case cardinal(portal) of
$FFFFFFFE : begin
NWSTrace(gNUTHandle, 'NWSCreatePortal reports: Unable to allocate memory for PCB, virtual screen, or save area.');
exit;
end;
$FFFFFFFF : begin
NWSTrace(gNUTHandle, 'NWSCreatePortal reports: Maximum number of portals already defined.');
exit;
end;
end;
// Get portal's PCB.
NWSGetPCB (portalPCB, portal, gNUTHandle);
// Make our portal current and clear it.
NWSSelectPortal(portal, gNUTHandle);
NWSClearPortal(portalPCB);
// Place information on portal.
NWSDisplayTextInPortal(1,0,'This is data displayed in a portal',VINTENSE,portalPCB);
szTemp := format ('Item selected: %s',[selectedItem]);
NWSDisplayTextInPortal(3,0,pchar(szTemp),VNORMAL,portalPCB);
NWSDisplayTextInPortal(5,0,'<Press ESCAPE to exit>',VINTENSE,portalPCB);
// Update portal content to user screen.
NWSUpdatePortal(portalPCB);
// Wait for user to press ESCAPE.
NWSWaitForEscape(gNUTHandle);
// Trash portal.
NWSDestroyPortal(portal, gNUTHandle);
end;
(****************************************************************************
* Action procedure for the list
****************************************************************************)
function NLM_ListSubAction (keyPressed : longint;
elementSelected:PPLIST;
itemLineNumber:plongint;
actionParameter:pointer) : longint; cdecl;
begin
result := -1;
case keyPressed of
M_ESCAPE : result := 0;
M_SELECT : begin
NLM_DisplayPortalInformation(@elementSelected^^.text);
result := -1;
end;
end;
end;
(****************************************************************************
* Build a list of items
****************************************************************************)
procedure NLM_ListSubBuild;
var i : integer;
s : ansistring;
begin
for i := 1 to 50 do
begin
s := format ('Item number %02d',[i]);
NWSAppendToList (pchar(s),nil,gNUTHandle);
end;
end;
(****************************************************************************
* Create and display the list
****************************************************************************)
procedure NLM_DisplaySubList;
begin
if gExiting then exit;
// At this point, the current list is the Main Menu. If we begin adding
// new items to the current list, it would mess up the Main menu (to say
// the least). So, we will save the Main Menu List on the List stack
// (PushList) and then initialize a new list (set head and tail to NULL)
// by calling InitList(). Note that Lists use NWInitList() and Menus use
// NWInitMenu().
NWSPushList(gNUTHandle);
NWSInitList(gNUTHandle, nil);
// Build a list
NLM_ListSubBuild;
// Display the list and allow user interaction.
NWSList(
LIST_SUBLIST__HDR, // I- header
0, // I- centerLine
0, // I- centerColumn
10, // I- height
72, // I- width
M_ESCAPE OR M_SELECT, // I- validKeyFlags
nil, // IO element
gNUTHandle, // I- handle
nil, // I- formatProcedure
@NLM_ListSubAction, // I- actionProcedure
nil); // I- actionParameter
// Before returning, we must free the list items allocated by
// NLM_ListSubBuild...(). Then the Main Menu list context
// must be restored. Note that Lists use NWDestroyList() and
// Menus use NWDestroyMenu().
NWSDestroyList(gNUTHandle);
NWSPopList(gNUTHandle);
end;
(****************************************************************************
* Unsorted sub-menu (NWSLIST) action procedure. Note that the parameters
* for an NWSList() action procedure are very different from the parameters
* passed to an NWSMenu() action procedure.
****************************************************************************)
function NLM_MenuNoSortAct (keyPressed:longint; elementSelected:PPLIST; itemLineNumber:plongint; actionParameter:pointer):longint; cdecl;
var index : integer;
begin
// Setup index variable to be the same as it would be in a NWSMenu()
// action procedure.
if keypressed = M_ESCAPE then
index := -1
else
index := integer(elementSelected^^.otherInfo^);
// Perform the user-selected action.
// (Just like a normal NWSMenu() action procedure...)
case index of
-1: begin
result := 0; exit;
end;
MENU_NOSORT_OPTION_A :
NWSTrace(gNUTHandle,'Insert no-sort sub-menu option #A here.');
MENU_NOSORT_OPTION_B :
NWSTrace(gNUTHandle,'Insert no-sort sub-menu option #B here.');
MENU_NOSORT_OPTION_C :
NWSTrace(gNUTHandle,'Insert no-sort sub-menu option #C here.');
MENU_NOSORT_OPTION_D :
NWSTrace(gNUTHandle,'Insert no-sort sub-menu option #D here.');
MENU_NOSORT_OPTION_E :
NWSTrace(gNUTHandle,'Insert no-sort sub-menu option #E here.')
else
NWSTrace(gNUTHandle,pchar(format('Option %d not implemented.',[index])));
end;
// If we should be exiting, pretend that ESCAPE was pressed.
if gExiting then
result := 0
else
result := -1;
end;
(****************************************************************************
* Unsorted sub-menu.
*
* There are times when you would like to display a menu, but you don't want
* the elements to be sorted. NWSMenu() automatically sorts the list of menu
* items and there is no way to disable this feature.
*
* The NWSList() function has an M_NO_SORT flag that is not available to the
* NWSMenu() function; however, using NWSList to display a menu can be scary
* if you don't know how.
*
* The following code demonstrates how to build a menu and then display it as
* a list. The action procedure (above) is specific to NWSList() and is not
* a suitable action procedure for NWSMenu().
***************************************************************************)
procedure NLM_MenuNoSort;
var defItem : PLIST;
begin
if gExiting then exit;
// At this point, the current list is the Main Menu. If we begin adding
// new items to the current list, it would mess up the Main menu (to say
// the least). So, we will save the Main Menu List on the List stack
// (PushList) and then initialize a new list (set head and tail to NULL)
// by calling InitMenu(). Note that Lists use NWInitList() and Menus use
// NWInitMenu().
NWSPushList(gNUTHandle);
NWSInitMenu(gNUTHandle);
// Insert menu items in the order they will be displayed.
NWSAppendToMenu(MENU_NOSORT_OPTION_B, MENU_NOSORT_OPTION_B, gNUTHandle);
NWSAppendToMenu(MENU_NOSORT_OPTION_A, MENU_NOSORT_OPTION_A, gNUTHandle);
defItem := NWSAppendToMenu(MENU_NOSORT_OPTION_C, MENU_NOSORT_OPTION_C, gNUTHandle);
NWSAppendToMenu(MENU_NOSORT_OPTION_E, MENU_NOSORT_OPTION_E, gNUTHandle);
NWSAppendToMenu(MENU_NOSORT_OPTION_D, MENU_NOSORT_OPTION_D, gNUTHandle);
// Display the menu (as though it were a list) and allow user interaction.
NWSList(
MENU_NOSORT__HDR, // header
0, // centerLine
65, // centerColumn
5, // height
20, // width
M_ESCAPE OR M_SELECT OR
M_NO_SORT, // validKeyFlags
@defItem, // element
gNUTHandle, // handle
nil, // formatProcedure
@NLM_MenuNoSortAct, // actionProcedure
nil); // actionParameter
// Before returning, we must free the list items allocated by
// NWSAppendToMenu(). Then the Main Menu list context must be restored.
// Note that Lists use NWDestroyList() and Menus use NWDestroyMenu().
NWSDestroyMenu(gNUTHandle);
NWSPopList(gNUTHandle);
end;
(****************************************************************************
* Sub menu (sorted) action procedure.
****************************************************************************)
function NLM_MenuSubAction (index:longint; parm:pointer):longint; cdecl;
begin
// Perform the user-selected action.
case index of
-1 : begin
result := 0; exit;
end;
MENU_SUB_OPTION1: NWSTrace(gNUTHandle,'Insert sub-menu option #1 here.');
MENU_SUB_OPTION2: NWSTrace(gNUTHandle,'Insert sub-menu option #2 here.')
else
NWSTrace(gNUTHandle,'Option not implemented.');
end;
// If we should be exiting, pretend that ESCAPE was pressed.
if gExiting then
result := 0
else
result := -1;
end;
procedure NLM_MenuSub;
begin
if gExiting then exit;
// At this point, the current list is the Main Menu. If we begin adding
// new items to the current list, it would mess up the Main menu (to say
// the least). So, we will save the Main Menu List on the List stack
// (PushList) and then initialize a new list (set head and tail to NULL)
// by calling InitMenu(). Note that Lists use NWInitList() and Menus use
// NWInitMenu().
NWSPushList(gNUTHandle);
NWSInitMenu(gNUTHandle);
// Insert menu items. Note that the insertion order does not matter being
// that NWSMenu() will always sort the Menu selections automatically.
NWSAppendToMenu(MENU_SUB_OPTION1, MENU_SUB_OPTION1, gNUTHandle);
NWSAppendToMenu(MENU_SUB_OPTION2, MENU_SUB_OPTION2, gNUTHandle);
// Display the menu and allow user interaction.
NWSMenu(MENU_SUB__HDR, // Header
0, // centerLine
15, // centerColumn
nil, // defaultElement
@NLM_MenuSubAction, // actionProcedure
gNUTHandle,
nil); // actionParameter
// Before returning, we must free the list items allocated by
// NWSAppendToMenu(). Then the Main Menu list context must be restored.
// Note that Lists use NWDestroyList() and Menus use NWDestroyMenu().
NWSDestroyMenu(gNUTHandle);
NWSPopList(gNUTHandle);
end;
function NLM_MenuMainAction (index:longint; parm:pointer):longint; cdecl;
begin
case index of
-1: if longbool(NLM_VerifyProgramExit) then // ESC pressed
begin
result := 0;
exit;
end;
MENU_MAIN_SUBMENU : NLM_MenuSub;
MENU_MAIN_NOSORT : NLM_MenuNoSort;
MENU_MAIN_LIST : NLM_DisplaySubList;
MENU_MAIN_FORM : NLM_FormSub;
MENU_MAIN_EDIT_STRING : NLM_EditStringSub;
MENU_MAIN_EDIT_TEXT : NLM_EditTextSub
else
NWSTrace(gNUTHandle,'Option not implemented.');
end;
if gExiting then
result := 0
else
result := -1;
end;
procedure DoMainMenu;
var defaultOption : PLIST;
begin
if gExiting then exit;
// At this point, the current list is uninitialized (being that it is the
// first list of the program.) Before using the current list it must be
// initialized (set head and tail to NULL) by calling InitMenu().
// Note that Lists use NWInitList() and Menus use NWInitMenu().
NWSInitMenu(gNUTHandle);
// Insert menu items. Note that the insertion order does not matter being
// that NWSMenu() will always sort the Menu selections automatically.
// The defaultOption stores a pointer to the menu item which we wish to be
// highlighed by default.
NWSAppendToMenu(MENU_MAIN_SUBMENU, MENU_MAIN_SUBMENU, gNUTHandle);
NWSAppendToMenu(MENU_MAIN_NOSORT, MENU_MAIN_NOSORT, gNUTHandle);
NWSAppendToMenu(MENU_MAIN_LIST, MENU_MAIN_LIST, gNUTHandle);
NWSAppendToMenu(MENU_MAIN_FORM, MENU_MAIN_FORM, gNUTHandle);
defaultOption :=
NWSAppendToMenu(MENU_MAIN_EDIT_STRING, MENU_MAIN_EDIT_STRING, gNUTHandle);
NWSAppendToMenu(MENU_MAIN_EDIT_TEXT, MENU_MAIN_EDIT_TEXT, gNUTHandle);
// Display the menu and allow user interaction.
NWSMenu(MENU_MAIN__HDR, // Header
0, // centerLine
0, // centerColumn
defaultOption, // defaultElement
@NLM_MenuMainAction, // procedure to handle events
gNUTHandle,
nil); // actionParameter
// Before returning, we must free the list items allocated by
// NWSAppendToMenu(). Note that Lists use NWDestroyList() and Menus use
// NWDestroyMenu().
NWSDestroyMenu(gNUTHandle);
end;
procedure DeinitializeNUT;
begin
if gNUTHandle <> nil then
NWSRestoreNut(gNUTHandle);
end;
var oldNetwareUnloadProc : pointer = nil;
procedure onUnload;
var i : integer;
begin
gExiting := TRUE;
// Wait for main() to terminate.
// If main() has not terminateded within a 1/2 second, ungetch an
// escape key. This will "trick" a blocking NWSList() or NWSMenu()
// function and wake it up.
i := 0;
while (gThreadCount > 0) do
begin
delay (100);
inc(i);
if i = 5 then
ungetcharacter(ESCAPE);
{$if defined (netware_libc)}
pthread_yield;
{$else}
ThreadSwitchWithDelay;
{$endif}
end;
System.NetwareUnloadProc := oldNetwareUnloadProc;
end;
procedure InitializeNUT;
var err : integer;
NLMHandle : TNLMHandle;
screen : TScr;
allocTag : TRtag;
begin
// use the SIGTERM handler defined in system.pp to facilitate a console UNLOAD command.
oldNetwareUnloadProc := System.NetwareUnloadProc;
NetwareUnloadProc := @onUnload;
NLMHandle := getnlmhandle;
{$if defined(netware_clib)}
screen := CreateScreen ('FreePascal NWSNUT Demo - clib',AUTO_DESTROY_SCREEN);
if screen <> nil then
DisplayScreen (screen);
{$else}
screen := getscreenhandle();
{$endif}
if ((pointer(NLMHandle) = nil) or (pointer(screen) = nil)) then
begin
gExiting := TRUE;
Exit;
end;
// Fire up NWSNUT on our screen which was set up via the linker. LibC
// doesn't have a great deal of flexibility with screens. Setting up your
// own, additional screen may prove challenging, however, it should be
// possible.
allocTag := AllocateResourceTag(NLMHandle, gMyName, AllocSignature);
if pointer(allocTag) = nil then
begin
gExiting := TRUE;
Exit;
end;
err := NWSInitializeNut(PROGRAM_NAME, PROGRAM_VERSION, NORMAL_HEADER,
NUT_REVISION_LEVEL, gMessageTable, nil, screen, allocTag,
gNUTHandle);
if err <> 0 then
gExiting := TRUE;
end;
begin
inc (gThreadCount);
InitializeNUT;
DoMainMenu;
DeinitializeNUT;
dec (gThreadCount);
end.