home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / Finger 1.3.5 / source / My Units / MyFMenus.unit < prev    next >
Encoding:
Text File  |  1992-02-24  |  5.7 KB  |  271 lines  |  [TEXT/PJMM]
  1. unit MyFMenus;
  2.  
  3. { This code is part of the Finger/Fingerd source code, written in THINK Pascal 4 }
  4. { Copyright 1991-1992 Peter N Lewis }
  5. { If you use this code, you must give me credit in your about box and documentation }
  6. { This is part of my generic library of routines }
  7.  
  8. interface
  9.  
  10.     procedure InitFMenus (default: procptr);
  11. { procedure default(themenu,theitem:integer) }
  12.     procedure FinishFMenus;
  13.     function GetFMenu (id: integer): MenuHandle;
  14.     procedure AddFCommand (themenu, theitem: integer; command: OSType);
  15.     procedure SetFCommand (command: OSType; cmdproc: procptr);
  16. { procedure cmdproc }
  17.     procedure SetFSetMenu (command: OSType; smproc: procptr);
  18. { procedure smproc(themenu,theitem:integer) }
  19.     procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
  20.     procedure GetCommand (themenu, theitem: integer; var command: OSType);
  21.     procedure DoCommand (themenu, theitem: integer; command: OSType);
  22.     procedure DoFMenu (themenu, theitem: integer);
  23.     procedure SetFMenus;
  24.  
  25. implementation
  26.  
  27.     uses
  28.         BaseGlobals;
  29.  
  30.     procedure DoSMP (themenu, theitem: integer; smp: procptr);
  31.     inline
  32.         $205F, $4E90;
  33.  
  34.     procedure DoDefCMDP (themenu, theitem: integer; cmdp: procptr);
  35.     inline
  36.         $205F, $4E90;
  37.  
  38.     procedure DoCMDP (cmdp: procptr);
  39.     inline
  40.         $205F, $4E90;
  41.  
  42.     type
  43.         fmenuHeader = record
  44.                 visible: integer;
  45.                 count: integer;
  46.                 unknown1: integer;
  47.                 menuID: integer;
  48.                 unknown2: integer;
  49.                 unknown3: integer;
  50.                 name: str63;
  51.             end;
  52.         fmenuHeaderPtr = ^fmenuHeader;
  53.         fmenuItem = packed record
  54.                 command: OSType;
  55.                 mark: char;
  56.                 unknown2: byte;
  57.                 cmdKey: char;
  58.                 disabled: byte;
  59.                 name: str63;
  60.             end;
  61.         fmenuItemPtr = ^fmenuItem;
  62.         convertRecord = record
  63.                 menu, item: integer;
  64.                 cmd: OSType;
  65.                 cmdp, smp: procptr;
  66.             end;
  67.         convertArray = array[1..1000] of convertRecord;
  68.         convertPtr = ^convertArray;
  69.         convertHandle = ^convertPtr;
  70.  
  71.     var
  72.         defaultproc: procptr;
  73.         convert_count: integer;
  74.         converts: convertHandle;
  75.  
  76. {$S Init}
  77.     procedure InitFMenus (default: procptr);
  78. { procedure default(themenu,theitem:integer) }
  79.     begin
  80.         defaultproc := default;
  81.         convert_count := 0;
  82.         converts := convertHandle(NewHandle(0));
  83.     end;
  84.  
  85. {$S Term}
  86.     procedure FinishFMenus;
  87.     begin
  88.         DisposHandle(handle(converts));
  89.     end;
  90.  
  91. {$S Init}
  92.     procedure AddFCommand (themenu, theitem: integer; command: OSType);
  93.     begin
  94.         if BAND(convert_count, 7) = 0 then
  95.             SetHandleSize(handle(converts), (convert_count + 8) * SizeOf(convertRecord));
  96.         convert_count := convert_count + 1;
  97.         with converts^^[convert_count] do begin
  98.             menu := themenu;
  99.             item := theitem;
  100.             cmd := command;
  101.             cmdp := defaultproc;
  102.             smp := nil;
  103.         end;
  104.     end;
  105.  
  106. {$S Init}
  107.     procedure NextPtr (var p: univ ptr; sp: univ ptr);
  108.     begin
  109.         p := ptr(longInt(sp) + sp^ + 2 - ord(odd(sp^)));
  110.     end;
  111.  
  112. {$S Init}
  113.     function GetFMenu (id: integer): MenuHandle;
  114.         var
  115.             h: handle;
  116.             mh: menuHandle;
  117.             ph: fmenuHeaderPtr;
  118.             p: fmenuItemPtr;
  119.             s: string[70];
  120.             i: integer;
  121.     begin
  122.         h := GetResource('fmnu', id);
  123.         HLock(h);
  124.         ph := fmenuHeaderPtr(h^);
  125.         mh := NewMenu(ph^.menuID, ph^.name);
  126.         NextPtr(p, @ph^.name);
  127.         for i := 1 to ph^.count do begin
  128.             if p^.name = '-' then
  129.                 AppendMenu(mh, '(-')
  130.             else begin
  131.                 AddFCommand(ph^.menuID, i, p^.command);
  132.                 s := p^.name;
  133.                 if p^.mark <> chr(0) then
  134.                     s := concat(s, '!', p^.mark);
  135.                 if p^.cmdKey <> chr(0) then
  136.                     s := concat(s, '/', p^.cmdKey);
  137.                 if p^.disabled = 1 then
  138.                     s := concat('(', s);
  139.                 AppendMenu(mh, s);
  140.             end;
  141.             NextPtr(p, @p^.name);
  142.         end;
  143.         DisposHandle(h);
  144.         GetFMenu := mh;
  145.     end;
  146.  
  147. {$S}
  148.     procedure FindCommand (command: OSType; var cmdproc: procptr);
  149.         var
  150.             i: integer;
  151.     begin
  152.         i := 1;
  153.         while i <= convert_count do begin
  154.             with converts^^[i] do
  155.                 if cmd = command then begin
  156.                     cmdproc := cmdp;
  157.                     Exit(FindCommand);
  158.                 end;
  159.             i := i + 1;
  160.         end;
  161.         cmdproc := defaultproc;
  162.     end;
  163.  
  164. {$S}
  165.     procedure FindMenu (themenu, theitem: integer; var i: integer);
  166.     begin
  167.         i := 1;
  168.         while i <= convert_count do begin
  169.             with converts^^[i] do
  170.                 if (menu = themenu) and (item = theitem) then
  171.                     Exit(FindMenu);
  172.             i := i + 1;
  173.         end;
  174.         i := -1;
  175.     end;
  176.  
  177. {$S Init}
  178.     procedure SetFCommand (command: OSType; cmdproc: procptr);
  179. { procedure cmdproc }
  180.         var
  181.             i: integer;
  182.     begin
  183.         for i := 1 to convert_count do
  184.             with converts^^[i] do
  185.                 if cmd = command then
  186.                     cmdp := cmdproc;
  187.     end;
  188.  
  189. {$S Init}
  190.     procedure SetFSetMenu (command: OSType; smproc: procptr);
  191. { procedure smproc }
  192.         var
  193.             i: integer;
  194.     begin
  195.         for i := 1 to convert_count do
  196.             with converts^^[i] do
  197.                 if cmd = command then
  198.                     smp := smproc;
  199.     end;
  200.  
  201. {$S Init}
  202.     procedure SetFBoth (command: OSType; cmdproc, smproc: procptr);
  203. { procedure smproc }
  204.         var
  205.             i: integer;
  206.     begin
  207.         for i := 1 to convert_count do
  208.             with converts^^[i] do
  209.                 if cmd = command then begin
  210.                     cmdp := cmdproc;
  211.                     smp := smproc;
  212.                 end;
  213.     end;
  214.  
  215. {$S}
  216.     procedure GetCommand (themenu, theitem: integer; var command: OSType);
  217.         var
  218.             i: integer;
  219.     begin
  220.         FindMenu(themenu, theitem, i);
  221.         if i = -1 then
  222.             command := 'xxx0'
  223.         else
  224.             command := converts^^[i].cmd;
  225.     end;
  226.  
  227. {$S}
  228.     procedure DoCmd (themenu, theitem: integer; cmdp: procptr);
  229.     begin
  230.         if cmdp = defaultproc then
  231.             DoDefCMDP(themenu, theitem, cmdp)
  232.         else
  233.             DoCMDP(cmdp);
  234.     end;
  235.  
  236. {$S}
  237.     procedure DoCommand (themenu, theitem: integer; command: OSType);
  238.         var
  239.             cmdproc: procptr;
  240.     begin
  241.         FindCommand(command, cmdproc);
  242.         DoCmd(themenu, theitem, cmdproc);
  243.     end;
  244.  
  245. {$S}
  246.     procedure DoFMenu (themenu, theitem: integer);
  247.         var
  248.             i: integer;
  249.     begin
  250.         FindMenu(themenu, theitem, i);
  251.         if i = -1 then
  252.             DoCmd(themenu, theitem, defaultproc)
  253.         else
  254.             with converts^^[i] do
  255.                 DoCmd(themenu, theitem, cmdp);
  256.         if not quitNow then
  257.             HiliteMenu(0);
  258.     end;
  259.  
  260. {$S}
  261.     procedure SetFMenus;
  262.         var
  263.             i: integer;
  264.     begin
  265.         for i := 1 to convert_count do
  266.             with converts^^[i] do
  267.                 if smp <> nil then
  268.                     DoSMP(menu, item, smp);
  269.     end;
  270.  
  271. end.