home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / new / amigalibdisks / d996 / 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