home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d9xx
/
d996
/
startup-menu.lha
/
Startup-Menu
/
GetOption
/
GetOpt10.PAS
next >
Wrap
Pascal/Delphi Source File
|
1994-04-05
|
12KB
|
393 lines
PROGRAM GetOpt;
USES DOS, Exec, Intuition, utility, gadtools, graphics, AmigaDOS, LSKExtras;
TYPE
ch2A = ARRAY[0..1] of char;
CONST
LLGad = 1; CCGad = 2;
Bool_1 = 3; Bool_2 = 4; { used as gadget ID's and array identifiers}
Vers : string = '$VER: GetOpt v1.0 © Lee S Kindness 18.12.93'#0;
ScreenTitle : string = 'GetOption v1.0 (c)1993 LSK...';
VAR
Gads : ARRAY [LLGad..Bool_2] OF pGadget;
Gad_Tags : tNewGadget;
My_Font : tTextAttr;
screendef : pScreen;
visualinf : pointer;
TheWindow : pWindow;
TBorderS : INTEGER;
Gad1txt, Gad2txt, title : STRING;
DrawInf : pDrawInfo;
IntText : tIntuiText;
ch1, ch2 : ch2A;
Txt1len, txt2len : integer;
{ ===================================================================== }
Procedure ErrExit(Errortxt : string; ExitCode : integer);
Begin
ErrorExit('** GetOption Error **', Errortxt);
CloseLibrary(pLibrary(IntuitionBase));
If GadToolsBase <> NIL then CloseLibrary(pLibrary(GadtoolsBase));
If TheWindow <> NIL then CloseWindow(TheWindow);
If gads[LLGad] <> NIL then FreeGadgets(gads[LLGad]);
If VisualInf <> NIL then FreeVisualInfo(VisualInf);
Halt(exitcode);
end;
{ ===================================================================== }
PROCEDURE open_libs; { open used libraries }
BEGIN
IntuitionBase := NIL;
IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',34));
if IntuitionBase = NIL then halt(122);
If IntuitionBase^.LibNode.lib_Version < 36 Then
ErrExit('Intuition library v36 (2.0) required'#0, 122);
GadToolsBase := NIL;
GadToolsBase := Openlibrary('gadtools.library',36);
IF GadtoolsBase = NIL THEN
ErrExit('Gadtools Library v36 (2.0) required'#0, 122);
UtilityBase := NIL;
UtilityBase := Openlibrary('utility.library',36);
IF utilityBase = NIL THEN
ErrExit('Utility Library v36 (2.0) required'#0, 122);
END;
{ ===================================================================== }
Function RetrieveStr(p : pointer) : string;
Type
a = Packed Array [0..255] Of Char; { fills a string with the }
Var { contents of the string }
i : Integer; { pointed at }
sptr : ^a; { (from HSPC init.unit) }
s : string;
Begin
sptr := p;
s := '';
i := 0;
While sptr^[i] <> #0 Do Begin
s := s + sptr^[i];
inc(i)
End;
RetrieveStr := s
End;
{ ===================================================================== }
PROCEDURE open_window;
CONST
PubName : string = 'error';
VAR
Win_Tags : ARRAY[0..15] OF tTagItem;
UScore_Tags : ARRAY[0..1] OF tTagItem;
xsze : integer;
LockKey : Longint;
PS_List : pList;
My_Node : pPubScreenNode;
BEGIN
gads[LLGad] := NIL;
LockKey := LockIBase(0);
screendef := IntuitionBase^.ActiveScreen;
PS_List := LockPubScreenList;
My_Node := pPubScreenNode(PS_List^.lh_Head);
While My_Node^.psn_Node.ln_Succ <> NIL Do Begin
If my_Node^.psn_Screen = screendef Then
PubName := retrievestr(My_Node^.psn_Node.ln_Name);
My_Node := pPubScreenNode(My_Node^.psn_Node.ln_Succ);
End;
UnLockPubScreenList;
UnlockIBase(LockKey);
If pubname = 'error' Then Begin
screendef := lockPubScreen(NIL);
If screendef = NIL Then
ErrExit('Failed to lock public screen'#0, 0);
End Else Begin
pubname := pubname + #0;
screendef := lockPubScreen(@PubName[1]);
If screendef = NIL Then
ErrExit('Failed to lock public screen'#0, 0);
End;
VisualInf := GetVisualInfoA(screendef, NIL);
IF visualinf = NIL THEN
ErrExit('Failed to get visual info'#0, 0);
Gads[CCGad] := CreateContext(@gads[LLGad]);
IF Gads[CCGad] = NIL THEN
ErrExit('Failed to create context'#0, 0);
TBorderS := screendef^.WBorTop + (screendef^.Font^.ta_YSize + 1);
DrawInf := GetScreenDrawInfo(screendef);
{ get the screens font }
WITH My_Font DO BEGIN
ta_Name := DrawInf^.dri_font^.tf_message.mn_Node.ln_Name;
ta_YSize := DrawInf^.dri_font^.tf_YSize;
ta_Style := DrawInf^.dri_font^.tf_Style;
ta_Flags := DrawInf^.dri_font^.tf_Flags;
END;
XSze := TBorderS + 1;
IntText.ITextFont := @My_Font;
IntText.IText := @Gad1txt[1];
txt1len := IntuiTextLength(@IntText);
txt1len := txt1len + 10;
IntText.IText := @Gad2txt[1];
txt2len := IntuiTextLength(@IntText);
txt2len := txt2len + 10;
{ Initilise gadget structures }
WITH Gad_Tags DO BEGIN
ng_TextAttr := @My_Font;
ng_LeftEdge := 8;
ng_TopEdge := TBorderS + 2;
ng_Width := txt1len;
ng_Height := XSze;
ng_GadgetText := @Gad1txt[1];
ng_VisualInfo := VisualInf;
ng_GadgetID := Bool_1;
END;
UScore_Tags[0].ti_Tag := GT_Underscore;
UScore_Tags[0].ti_Data := LONG('~');
UScore_Tags[1].ti_Tag := TAG_END;
{ create gadgets }
Gads[Bool_1] := CreateGadgetA(BUTTON_KIND, Gads[CCGad], @Gad_Tags, @UScore_Tags);
WITH Gad_Tags DO BEGIN
ng_Leftedge := txt1len + 14;
ng_Width := txt2len;
ng_GadgetText := @Gad2txt[1];
ng_GadgetID := Bool_2;
END;
Gads[Bool_2] := CreateGadgetA(BUTTON_KIND, Gads[Bool_1], @Gad_Tags, @UScore_Tags);
IF Gads[CCGad] = NIL THEN
ErrExit('Failed to create gadgets'#0, 0);
{ window structure }
Win_Tags[0].ti_Tag := WA_InnerWidth;
Win_Tags[0].ti_Data := txt1len + 14 + txt2len;
Win_Tags[1].ti_Tag := WA_InnerHeight;
Win_Tags[1].ti_Data := XSze + 4;
Win_Tags[2].ti_Tag := WA_Left;
Win_Tags[2].ti_Data := screendef^.MouseX - ((txt1len + 14 + txt2len) div 2);
Win_Tags[3].ti_Tag := WA_Top;
Win_Tags[3].ti_Data := screendef^.MouseY - ((XSze + 4) div 2);
Win_Tags[4].ti_Tag := WA_Title;
Win_Tags[4].ti_Data := LONG(@title[1]);
Win_Tags[5].ti_Tag := WA_IDCMP;
Win_Tags[5].ti_Data := IDCMP_REFRESHWINDOW
OR BUTTONIDCMP
OR IDCMP_VANILLAKEY
OR IDCMP_MOUSEBUTTONS;
Win_Tags[6].ti_Tag := WA_DragBar;
Win_Tags[6].ti_Data := True_;
Win_Tags[7].ti_Tag := WA_Gadgets;
Win_Tags[7].ti_Data := LONG(gads[LLGad]);
Win_Tags[8].ti_Tag := WA_SimpleRefresh;
Win_Tags[8].ti_Data := True_;
Win_Tags[9].ti_Tag := WA_Activate;
Win_Tags[9].ti_Data := True_;
Win_Tags[10].ti_Tag := WA_ScreenTitle;
Win_Tags[10].ti_Data:= LONG(@ScreenTitle[1]);
Win_Tags[11].ti_Tag := WA_RMBTrap;
Win_Tags[11].ti_Data:= True_;
Win_Tags[12].ti_Tag := WA_DepthGadget;
Win_Tags[12].ti_Data := True_;
Win_Tags[13].ti_Tag := WA_PubScreenName;
Win_Tags[13].ti_Data:= LONG(@pubname[1]);
Win_Tags[14].ti_Tag := WA_PubScreenFallBack;
Win_Tags[14].ti_Data:= True_;
Win_Tags[15].ti_Tag := TAG_DONE;
TheWindow := OpenWindowTaglist(NIL,@Win_Tags);
IF TheWindow = NIL THEN
ErrExit('Failed to create window'#0, 206);
GT_RefreshWindow(TheWindow, NIL);
UnlockPubScreen(NIL, screendef);
END;
{ ===================================================================== }
PROCEDURE Close_Libs; { close all opened libs }
BEGIN
CloseLibrary(pLibrary(IntuitionBase));
CloseLibrary(pLibrary(GadtoolsBase));
CloseLibrary(pLibrary(UtilityBase));
END;
{ ===================================================================== }
PROCEDURE Close_Window;
BEGIN
CloseWindow(TheWindow); { close window and free gadgets and }
FreeGadgets(gads[LLGad]); { visualinfo }
FreeVisualInfo(VisualInf);
END;
{ ===================================================================== }
FUNCTION HandleIDCMP : ShortInt;
CONST
exitflag : shortint = -33;
VAR { the main loop of the program. }
dummy : longint; { monitors IDCMP messages and }
message : pIntuiMessage; { responds as appropriate }
MsgClass : LongInt;
MsgCode : Word;
gadcode : pGadget;
tempint : ARRAY[1..4] of longint;
small : boolean;
BEGIN
tempint[4] := TheWindow^.Height;
Small := false;
WHILE exitflag < 0 DO BEGIN
dummy := Wait(BitMask(TheWindow^.UserPort^.MP_SIGBIT));
repeat
message := GT_GetIMsg(TheWindow^.userPort);
MsgClass := message^.Class;
MsgCode := message^.Code;
GadCode := pGadget(message^.IAddress);
GT_ReplyIMsg(message);
CASE MsgClass OF
IDCMP_MOUSEBUTTONS : begin
CASE MsgCode OF
MENUUP : begin
tempint[1] := TheWindow^.LeftEdge;
tempint[2] := TheWindow^.TopEdge;
tempint[3] := TheWindow^.Width;
IF Small then begin
ChangeWindowBox(TheWindow, tempint[1], tempint[2], tempint[3], Tempint[4]);
Small := false;
end else begin
ChangeWindowBox(TheWindow, tempint[1], tempint[2], tempint[3], TBorderS);
Small := true;
end;
end;
end;
end;
IDCMP_REFRESHWINDOW : BEGIN
GT_BeginRefresh(TheWindow);
GT_EndRefresh(TheWindow, TRUE);
END;
IDCMP_GADGETUP : BEGIN
CASE gadcode^.GadgetID OF
Bool_1 : ExitFlag := 0;
Bool_2 : ExitFlag := RETURN_WARN;
END; {case}
END; {case}
IDCMP_VANILLAKEY : BEGIN
IF (Chr(MsgCode) = ch1[0]) OR (Chr(MsgCode) = ch1[1]) OR
(Chr(MsgCode) = '0') then ExitFlag := 0;
IF (Chr(MsgCode) = ch2[0]) OR (Chr(MsgCode) = ch2[1]) OR
(Chr(MsgCode) = '1') then ExitFlag := RETURN_WARN
END;
END; {case}
until message = NIL;
END; {while}
HandleIDCMP := ExitFlag;
END;
{ ===================================================================== }
Function MakeUScore(strn : string; VAR ch : char) : string;
{ Puts a ~ in front of the first letter, this letter is outputted as ch }
{ and forms the keyboard shortcut. }
VAR tmp : string;
n : byte;
Begin
strn := strn + ' ';
tmp[0] := strn[0];
tmp[1] := '~';
For n := 1 to length(strn)-1 do begin
tmp[n+1] := strn[n];
end;
ch := tmp[2];
MakeUScore := tmp;
end;
{ ==== Main Procedure ================================================= }
PROCEDURE main;
VAR ErrorCode, n : Shortint;
tmp1, tmp2 : string;
c1, c2 : byte;
BEGIN
IF NOT (paramstr(1) = '?') then begin
CASE Paramcount OF
2 : begin
tmp1 := paramstr(1);
tmp2 := paramstr(2);
Title := 'What''s your choice?'#0;
ScreenTitle := ScreenTitle + ' ' + 'What''s your choice?' + #0;
end;
1 : begin
tmp1 := paramstr(1);
tmp2 := 'Shell';
Title := 'What''s your choice?'#0;
ScreenTitle := ScreenTitle + ' ' + 'What''s your choice?' + #0;
end;
0 : begin
tmp1 := 'Workbench';
tmp2 := 'Shell';
Title := 'What''s your choice?'#0;
ScreenTitle := ScreenTitle + ' ' + 'What''s your choice?' + #0;
end;
else begin
tmp1 := paramstr(1);
tmp2 := paramstr(2);
title := paramstr(3) + #0;
ScreenTitle := ScreenTitle + ' ' + Paramstr(3) + #0;
end;
end;
Gad1txt := MakeUScore(tmp1, ch1[0]) + #0;
Gad2txt := MakeUScore(tmp2, ch2[0]) + #0;
Open_Libs;
ch1[0] := chr(ToLower(ord(ch1[0])));
ch1[1] := chr(ToUpper(ord(ch1[0])));
ch2[0] := chr(ToLower(ord(ch2[0])));
ch2[1] := chr(ToUpper(ord(ch2[0])));
Open_Window;
ErrorCode := HandleIDCMP;
close_Window;
Close_Libs;
Halt(ErrorCode);
end else begin
Writeln('GetOption (c)LSK. USAGE: GetOption [Button1txt] [button2txt] [WindowTitle]');
writeln(' Return ok for button 1, Return warn for button 2 ');
Halt(116);
end;
END;
{ =================================================================== }
BEGIN
main
END.