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 >
Pascal/Delphi Source File  |  1994-04-05  |  12KB  |  393 lines
  1. PROGRAM GetOpt;
  2.      
  3. USES DOS, Exec, Intuition, utility, gadtools, graphics, AmigaDOS, LSKExtras;
  4.  
  5. TYPE
  6.     ch2A = ARRAY[0..1] of char;
  7.     
  8. CONST
  9.    
  10.    LLGad  = 1; CCGad  = 2;
  11.    Bool_1 = 3; Bool_2 = 4; { used as gadget ID's and array identifiers}
  12.    
  13.    Vers        : string = '$VER: GetOpt v1.0 © Lee S Kindness 18.12.93'#0;
  14.    ScreenTitle : string = 'GetOption v1.0 (c)1993 LSK...';
  15.       
  16. VAR
  17.    Gads                    : ARRAY [LLGad..Bool_2] OF pGadget;
  18.    Gad_Tags                : tNewGadget;
  19.    My_Font                 : tTextAttr;
  20.    screendef               : pScreen;
  21.    visualinf               : pointer;
  22.    TheWindow               : pWindow;
  23.    TBorderS                : INTEGER;
  24.    Gad1txt, Gad2txt, title : STRING;
  25.    DrawInf                 : pDrawInfo;
  26.    IntText                 : tIntuiText;
  27.    ch1, ch2                : ch2A;
  28.    Txt1len, txt2len        : integer; 
  29.    
  30.    
  31. { ===================================================================== }
  32.  
  33. Procedure ErrExit(Errortxt : string; ExitCode : integer);
  34.  
  35. Begin
  36.     ErrorExit('** GetOption Error **', Errortxt);
  37.     CloseLibrary(pLibrary(IntuitionBase));
  38.     If GadToolsBase <> NIL then CloseLibrary(pLibrary(GadtoolsBase));
  39.     If TheWindow <> NIL then CloseWindow(TheWindow);
  40.     If gads[LLGad] <> NIL then FreeGadgets(gads[LLGad]);
  41.     If VisualInf <> NIL then FreeVisualInfo(VisualInf);
  42.     Halt(exitcode);
  43. end;
  44.   
  45. { ===================================================================== }
  46.  
  47. PROCEDURE open_libs; { open used libraries }
  48.  
  49. BEGIN
  50.     IntuitionBase := NIL;
  51.    IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',34));
  52.    if IntuitionBase = NIL then halt(122);
  53.    If IntuitionBase^.LibNode.lib_Version < 36 Then
  54.         ErrExit('Intuition library v36 (2.0) required'#0, 122);
  55.               
  56.    GadToolsBase := NIL; 
  57.    GadToolsBase  := Openlibrary('gadtools.library',36); 
  58.    IF GadtoolsBase = NIL THEN 
  59.        ErrExit('Gadtools Library v36 (2.0) required'#0, 122);
  60.  
  61.     UtilityBase := NIL;
  62.    UtilityBase  := Openlibrary('utility.library',36); 
  63.    IF utilityBase = NIL THEN 
  64.        ErrExit('Utility Library v36 (2.0) required'#0, 122);
  65. END;
  66.  
  67. { ===================================================================== }
  68.  
  69. Function RetrieveStr(p : pointer) : string;
  70. Type
  71.   a = Packed Array [0..255] Of Char;     { fills a string with the }
  72. Var                                      { contents of the string  }
  73.   i    : Integer;                        { pointed at              }
  74.   sptr : ^a;                             { (from HSPC init.unit)   }
  75.   s    : string;
  76. Begin
  77.   sptr := p;
  78.   s := '';
  79.   i := 0;
  80.   While sptr^[i] <> #0 Do Begin
  81.     s := s + sptr^[i];
  82.     inc(i)
  83.   End;
  84.   RetrieveStr := s
  85. End;
  86.  
  87. { ===================================================================== }
  88.  
  89. PROCEDURE open_window;
  90.  
  91. CONST
  92.     PubName : string = 'error';
  93.     
  94. VAR 
  95.     Win_Tags    : ARRAY[0..15] OF tTagItem;
  96.     UScore_Tags : ARRAY[0..1] OF tTagItem;
  97.     xsze        : integer;
  98.     LockKey : Longint;
  99.     PS_List : pList;
  100.     My_Node : pPubScreenNode;
  101.  
  102. BEGIN
  103.     gads[LLGad]  := NIL;
  104.     LockKey := LockIBase(0);
  105.     screendef := IntuitionBase^.ActiveScreen;
  106.     PS_List := LockPubScreenList;
  107.     My_Node := pPubScreenNode(PS_List^.lh_Head);
  108.     While My_Node^.psn_Node.ln_Succ <> NIL Do Begin
  109.         If my_Node^.psn_Screen = screendef Then
  110.             PubName := retrievestr(My_Node^.psn_Node.ln_Name);
  111.         My_Node := pPubScreenNode(My_Node^.psn_Node.ln_Succ);
  112.     End;
  113.     UnLockPubScreenList;
  114.     UnlockIBase(LockKey);
  115.     
  116.     If pubname = 'error' Then Begin
  117.         screendef := lockPubScreen(NIL);
  118.        If screendef = NIL Then 
  119.           ErrExit('Failed to lock public screen'#0, 0);
  120.    End Else Begin
  121.         pubname := pubname + #0;
  122.        screendef := lockPubScreen(@PubName[1]);
  123.        If screendef = NIL Then 
  124.           ErrExit('Failed to lock public screen'#0, 0);
  125.     End;
  126.     
  127.    VisualInf := GetVisualInfoA(screendef, NIL);
  128.    IF visualinf = NIL THEN
  129.       ErrExit('Failed to get visual info'#0, 0);
  130.    Gads[CCGad] := CreateContext(@gads[LLGad]);
  131.    IF Gads[CCGad] = NIL THEN
  132.       ErrExit('Failed to create context'#0, 0);
  133.    TBorderS := screendef^.WBorTop + (screendef^.Font^.ta_YSize + 1);
  134.    
  135.    DrawInf := GetScreenDrawInfo(screendef);
  136. { get the screens font }
  137.     WITH My_Font DO BEGIN
  138.       ta_Name  := DrawInf^.dri_font^.tf_message.mn_Node.ln_Name;
  139.       ta_YSize := DrawInf^.dri_font^.tf_YSize;
  140.       ta_Style := DrawInf^.dri_font^.tf_Style;
  141.       ta_Flags := DrawInf^.dri_font^.tf_Flags;
  142.    END;
  143.    XSze := TBorderS + 1;
  144.    
  145.    IntText.ITextFont := @My_Font;
  146.    IntText.IText     := @Gad1txt[1];
  147.     txt1len := IntuiTextLength(@IntText);
  148.     txt1len := txt1len + 10;
  149.     IntText.IText     := @Gad2txt[1];
  150.     txt2len := IntuiTextLength(@IntText);
  151.     txt2len := txt2len + 10;
  152.    
  153. { Initilise gadget structures }
  154.    WITH Gad_Tags DO BEGIN
  155.       ng_TextAttr   := @My_Font;
  156.       ng_LeftEdge   := 8;
  157.       ng_TopEdge    := TBorderS + 2;
  158.       ng_Width      := txt1len;
  159.       ng_Height     := XSze;
  160.       ng_GadgetText := @Gad1txt[1];
  161.       ng_VisualInfo := VisualInf;
  162.       ng_GadgetID   := Bool_1;
  163.    END;
  164.    UScore_Tags[0].ti_Tag  := GT_Underscore;
  165.    UScore_Tags[0].ti_Data := LONG('~');
  166.    UScore_Tags[1].ti_Tag  := TAG_END;
  167. { create gadgets }
  168.    Gads[Bool_1] := CreateGadgetA(BUTTON_KIND, Gads[CCGad], @Gad_Tags, @UScore_Tags);
  169.    WITH Gad_Tags DO BEGIN
  170.        ng_Leftedge   := txt1len + 14;
  171.        ng_Width      := txt2len;
  172.       ng_GadgetText := @Gad2txt[1];
  173.       ng_GadgetID   := Bool_2;
  174.    END;
  175.    Gads[Bool_2] := CreateGadgetA(BUTTON_KIND, Gads[Bool_1], @Gad_Tags, @UScore_Tags);
  176.       IF Gads[CCGad] = NIL THEN
  177.       ErrExit('Failed to create gadgets'#0, 0);
  178. { window structure }
  179.    Win_Tags[0].ti_Tag  := WA_InnerWidth;
  180.    Win_Tags[0].ti_Data := txt1len + 14 + txt2len;
  181.    Win_Tags[1].ti_Tag  := WA_InnerHeight;
  182.    Win_Tags[1].ti_Data := XSze + 4;
  183.    Win_Tags[2].ti_Tag  := WA_Left;
  184.    Win_Tags[2].ti_Data := screendef^.MouseX - ((txt1len + 14 + txt2len) div 2);
  185.    Win_Tags[3].ti_Tag  := WA_Top;
  186.    Win_Tags[3].ti_Data := screendef^.MouseY - ((XSze + 4) div 2);
  187.    Win_Tags[4].ti_Tag  := WA_Title;
  188.    Win_Tags[4].ti_Data := LONG(@title[1]); 
  189.    Win_Tags[5].ti_Tag  := WA_IDCMP;
  190.    Win_Tags[5].ti_Data := IDCMP_REFRESHWINDOW 
  191.                                  OR BUTTONIDCMP
  192.                                  OR IDCMP_VANILLAKEY
  193.                                  OR IDCMP_MOUSEBUTTONS;
  194.    Win_Tags[6].ti_Tag  := WA_DragBar;
  195.    Win_Tags[6].ti_Data := True_;
  196.    Win_Tags[7].ti_Tag  := WA_Gadgets;
  197.    Win_Tags[7].ti_Data := LONG(gads[LLGad]);
  198.    Win_Tags[8].ti_Tag  := WA_SimpleRefresh;
  199.    Win_Tags[8].ti_Data := True_;
  200.    Win_Tags[9].ti_Tag  := WA_Activate;
  201.    Win_Tags[9].ti_Data := True_;
  202.    Win_Tags[10].ti_Tag := WA_ScreenTitle;
  203.    Win_Tags[10].ti_Data:= LONG(@ScreenTitle[1]);
  204.    Win_Tags[11].ti_Tag := WA_RMBTrap;
  205.    Win_Tags[11].ti_Data:= True_; 
  206.    Win_Tags[12].ti_Tag  := WA_DepthGadget;
  207.    Win_Tags[12].ti_Data := True_;
  208.     Win_Tags[13].ti_Tag := WA_PubScreenName;
  209.    Win_Tags[13].ti_Data:= LONG(@pubname[1]);
  210.    Win_Tags[14].ti_Tag := WA_PubScreenFallBack;
  211.    Win_Tags[14].ti_Data:= True_;
  212.    Win_Tags[15].ti_Tag := TAG_DONE;
  213.    
  214.    TheWindow := OpenWindowTaglist(NIL,@Win_Tags);
  215.    IF TheWindow = NIL THEN
  216.       ErrExit('Failed to create window'#0, 206);
  217.    GT_RefreshWindow(TheWindow, NIL);
  218.    UnlockPubScreen(NIL, screendef);
  219. END;
  220. { ===================================================================== }
  221.  
  222. PROCEDURE Close_Libs;   { close all opened libs }
  223. BEGIN
  224.    CloseLibrary(pLibrary(IntuitionBase));
  225.    CloseLibrary(pLibrary(GadtoolsBase));
  226.    CloseLibrary(pLibrary(UtilityBase));
  227. END;
  228.  
  229. { ===================================================================== }
  230.  
  231. PROCEDURE Close_Window;
  232. BEGIN
  233.    CloseWindow(TheWindow);       { close window and free gadgets and }
  234.    FreeGadgets(gads[LLGad]);     { visualinfo                        }
  235.    FreeVisualInfo(VisualInf);
  236. END;
  237.  
  238. { ===================================================================== }
  239.  
  240. FUNCTION HandleIDCMP : ShortInt;
  241. CONST
  242.    exitflag : shortint = -33;
  243.    
  244. VAR                                { the main loop of the program. }
  245.    dummy      : longint;           { monitors IDCMP messages and   }
  246.    message    : pIntuiMessage;     { responds as appropriate       }
  247.    MsgClass   : LongInt;
  248.    MsgCode    : Word;
  249.    gadcode    : pGadget;
  250.    tempint    : ARRAY[1..4] of longint;
  251.    small      : boolean;
  252.  
  253. BEGIN
  254.     tempint[4] := TheWindow^.Height;
  255.     Small := false;
  256.    WHILE exitflag < 0 DO BEGIN
  257.       dummy    := Wait(BitMask(TheWindow^.UserPort^.MP_SIGBIT));
  258.       repeat
  259.           message  := GT_GetIMsg(TheWindow^.userPort);
  260.           MsgClass := message^.Class;
  261.           MsgCode  := message^.Code;
  262.           GadCode  := pGadget(message^.IAddress);
  263.           GT_ReplyIMsg(message);
  264.           CASE MsgClass OF
  265.           
  266.               IDCMP_MOUSEBUTTONS : begin
  267.                   CASE MsgCode OF
  268.                       MENUUP : begin
  269.                           tempint[1] := TheWindow^.LeftEdge;
  270.                               tempint[2] := TheWindow^.TopEdge;
  271.                               tempint[3] := TheWindow^.Width;
  272.                               IF Small then begin
  273.                               ChangeWindowBox(TheWindow, tempint[1], tempint[2], tempint[3], Tempint[4]);
  274.                               Small := false;
  275.                           end else begin
  276.                               ChangeWindowBox(TheWindow, tempint[1], tempint[2], tempint[3], TBorderS);
  277.                               Small := true;
  278.                           end;
  279.                       end;
  280.                   end;
  281.               end;
  282.               
  283.              IDCMP_REFRESHWINDOW : BEGIN
  284.                 GT_BeginRefresh(TheWindow);
  285.                 GT_EndRefresh(TheWindow, TRUE);
  286.              END;
  287.              
  288.              IDCMP_GADGETUP : BEGIN
  289.                 CASE gadcode^.GadgetID OF
  290.                    Bool_1 : ExitFlag := 0;   
  291.                    Bool_2 : ExitFlag := RETURN_WARN;
  292.                 END; {case}
  293.              END; {case}
  294.              
  295.              IDCMP_VANILLAKEY : BEGIN
  296.                  IF (Chr(MsgCode) = ch1[0]) OR (Chr(MsgCode) = ch1[1]) OR
  297.                                                  (Chr(MsgCode) = '0') then ExitFlag := 0;
  298.                  IF (Chr(MsgCode) = ch2[0]) OR (Chr(MsgCode) = ch2[1]) OR
  299.                                                  (Chr(MsgCode) = '1') then ExitFlag := RETURN_WARN
  300.              END;
  301.           END; {case}
  302.       until message = NIL;
  303.    END; {while}
  304.    HandleIDCMP := ExitFlag;
  305. END;
  306.  
  307. { ===================================================================== }
  308.  
  309. Function MakeUScore(strn : string; VAR ch : char) : string;
  310.  
  311. { Puts a ~ in front of the first letter, this letter is outputted as ch }
  312. { and forms the keyboard shortcut.                                      }
  313.  
  314. VAR tmp : string;
  315.     n : byte;
  316.  
  317. Begin
  318.     strn := strn + ' '; 
  319.     tmp[0] := strn[0]; 
  320.     tmp[1] := '~'; 
  321.     For n := 1 to length(strn)-1 do begin
  322.         tmp[n+1] := strn[n];
  323.     end;
  324.     ch := tmp[2];
  325.     MakeUScore := tmp;
  326. end;
  327.     
  328. { ==== Main Procedure ================================================= }
  329.  
  330. PROCEDURE main;
  331.  
  332. VAR ErrorCode, n : Shortint;
  333.     tmp1, tmp2 : string;
  334.     c1, c2 : byte;
  335.     
  336.     
  337.  
  338. BEGIN
  339.     IF NOT (paramstr(1) = '?') then begin
  340.         CASE Paramcount OF
  341.         2 : begin
  342.                 tmp1 := paramstr(1);
  343.                 tmp2 := paramstr(2);
  344.                 Title := 'What''s your choice?'#0;
  345.                 ScreenTitle := ScreenTitle + ' ' + 'What''s your choice?' + #0;
  346.              end;
  347.         1 : begin
  348.                 tmp1 := paramstr(1);
  349.                 tmp2 := 'Shell';
  350.                 Title := 'What''s your choice?'#0;
  351.                 ScreenTitle := ScreenTitle + ' ' + 'What''s your choice?' + #0;
  352.              end;
  353.         0 : begin
  354.                 tmp1 := 'Workbench';
  355.                 tmp2 := 'Shell';
  356.                 Title := 'What''s your choice?'#0;
  357.                 ScreenTitle := ScreenTitle + ' ' + 'What''s your choice?' + #0;
  358.              end;
  359.         else begin
  360.                 tmp1 := paramstr(1);
  361.                 tmp2 := paramstr(2);
  362.                 title := paramstr(3) + #0;
  363.                 ScreenTitle := ScreenTitle + ' ' + Paramstr(3) + #0;
  364.              end;
  365.         end;
  366.         Gad1txt := MakeUScore(tmp1, ch1[0]) + #0;
  367.         Gad2txt := MakeUScore(tmp2, ch2[0]) + #0;
  368.         Open_Libs;
  369.         ch1[0] := chr(ToLower(ord(ch1[0])));
  370.       ch1[1] := chr(ToUpper(ord(ch1[0])));
  371.         ch2[0] := chr(ToLower(ord(ch2[0])));
  372.         ch2[1] := chr(ToUpper(ord(ch2[0])));
  373.        Open_Window;
  374.        ErrorCode := HandleIDCMP; 
  375.        close_Window;
  376.        Close_Libs;
  377.        Halt(ErrorCode);
  378.     end else begin
  379.        Writeln('GetOption (c)LSK. USAGE: GetOption [Button1txt] [button2txt] [WindowTitle]');
  380.        writeln('                         Return ok for button 1, Return warn for button 2 ');
  381.        Halt(116);
  382.     end;
  383. END;
  384.  
  385. { =================================================================== }
  386.  
  387. BEGIN
  388. main
  389. END.
  390.  
  391.       
  392.       
  393.