home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Pascal / Source□ / Talk Source / My Libraries / MyUtils.unit < prev    next >
Encoding:
Text File  |  1992-04-20  |  8.0 KB  |  376 lines  |  [TEXT/PJMM]
  1. unit MyUtils;
  2.  
  3. { This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
  4.  
  5. interface
  6.  
  7.     type
  8.         versionRecord = packed record
  9.                 version: integer;
  10.                 devcode: byte;
  11.                 revision: byte;
  12.                 country: integer;
  13.                 short: str15;
  14.                 long: str255;
  15.             end;
  16.  
  17.     function TrapAvailable (tNumber: INTEGER): BOOLEAN;
  18.     function MyNumToString (n: longInt): str255;
  19.     function NumToStr (n: longInt): str255;
  20.     function StrToNum (s: str255): longInt;
  21.     function GetIndexedString (strh, i: integer): str255;
  22.     procedure DotDotDot (var s: str255; var width: integer);
  23.     procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
  24.     procedure SetIDItemEnable (menu, item: integer; enable: boolean);
  25.     function GetIDItemEnable (menu, item: integer): boolean;
  26.     function GetItemEnable (mh: menuHandle; item: integer): boolean;
  27.     procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
  28.     function MyFrontWindow: boolean;
  29.     function DAFrontWindow: boolean;
  30.     function GetIndStrSize (size, id, index: integer): str255;
  31.     procedure GetVersion (var vers: versionRecord);
  32.     procedure SetVersionParamText (c2, c3: str255);
  33.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
  34.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
  35.     procedure PlotSICN (id: integer; index, v, h: integer);
  36.     procedure SegmentInit;
  37.     procedure SegmentUtil;
  38.     procedure SegmentUtil2;
  39.     procedure SegmentTerm;
  40.     function HLockState (h: univ handle): signedByte;
  41. {    procedure SPrintS5V (var dst: str255;var  src,s1, s2, s3, s4, s5: str255);}
  42.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  43.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  44.     function UpCase (ch: char): char;
  45.  
  46. implementation
  47.  
  48.     uses
  49.         MyTypes, Traps;
  50.  
  51. {$S Init}
  52.     procedure SegmentInit;
  53.     begin
  54.     end;
  55.  
  56. {$S Util}
  57.     procedure SegmentUtil;
  58.     begin
  59.     end;
  60.  
  61. {$S Util2}
  62.     procedure SegmentUtil2;
  63.     begin
  64.     end;
  65.  
  66. {$S Term}
  67.     procedure SegmentTerm;
  68.     begin
  69.     end;
  70.  
  71. {$S Util}
  72.     function TrapAvailable (tNumber: INTEGER): BOOLEAN;
  73. {Check to see if a given trap is implemented. Babble as taken from IM6 }
  74.         const
  75.             TrapMask = $0800;
  76.         var
  77.             tType: TrapType;
  78.             ignoreError: OSErr;
  79.     begin
  80.         if BAND(tNumber, TrapMask) > 0 then
  81.             tType := ToolTrap
  82.         else
  83.             tType := OSTrap;
  84.         if tType = ToolTrap then begin
  85.             tNumber := BAND(tNumber, $7FF);
  86.             if tNumber >= $400 then
  87.                 tNumber := _Unimplemented
  88.             else if tNumber >= $200 then
  89.                 if NGetTrapAddress($A86E, ToolTrap) <> NGetTrapAddress($AA6E, ToolTrap) then
  90.                     tNumber := _Unimplemented;
  91.         end;
  92.         TrapAvailable := NGetTrapAddress(tNumber, tType) <> GetTrapAddress(_Unimplemented);
  93.     end; {TrapAvailable}
  94.  
  95. {$S Util}
  96.     function MyNumToString (n: longInt): str255;
  97.         var
  98.             s: str255;
  99.     begin
  100.         if abs(n) < 4096 then
  101.             NumToString(n, s)
  102.         else if abs(n) < 4194304 then begin
  103.             NumToString(n div 1024, s);
  104.             s := Concat(s, 'k');
  105.         end
  106.         else begin
  107.             NumToString(n div 1048576, s);
  108.             s := Concat(s, 'M');
  109.         end;
  110.         MyNumToString := s;
  111.     end;
  112.  
  113. {$S Util}
  114.     function NumToStr (n: longInt): str255;
  115.         var
  116.             s: str255;
  117.     begin
  118.         NumToString(n, s);
  119.         NumToStr := s;
  120.     end;
  121.  
  122. {$S Util}
  123.     function StrToNum (s: str255): longInt;
  124.         var
  125.             n: longInt;
  126.     begin
  127.         StringToNum(s, n);
  128.         StrToNum := n;
  129.     end;
  130.  
  131. {$S Util}
  132.     function GetIndexedString (strh, i: integer): str255;
  133.         var
  134.             s: str255;
  135.     begin
  136.         GetIndString(s, strh, i);
  137.         GetIndexedString := s;
  138.     end;
  139.  
  140. {$S Util2}
  141.     procedure DotDotDot (var s: str255; var width: integer);
  142.         var
  143.             maxwidth, len: integer;
  144.     begin
  145.         maxwidth := width;
  146.         width := StringWidth(s);
  147.         if width > maxwidth then begin
  148.             width := width + CharWidth('…');
  149. {$PUSH}
  150. {$R-}
  151.             len := ord(s[0]);
  152.             while (len > 0) and (width > maxwidth) do begin
  153.                 width := width - CharWidth(s[len]);
  154.                 len := len - 1;
  155.             end;
  156.             len := len + 1;
  157.             s[0] := chr(len);
  158.             s[len] := '…';
  159. {$POP}
  160.         end;
  161.     end;
  162.  
  163. {$S}
  164.     procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
  165.     begin
  166.         if enable then
  167.             EnableItem(mh, item)
  168.         else
  169.             DisableItem(mh, item);
  170.     end;
  171.  
  172. {$S}
  173.     procedure SetIDItemEnable (menu, item: integer; enable: boolean);
  174.     begin
  175.         SetItemEnable(GetMHandle(menu), item, enable);
  176.     end;
  177.  
  178. {$S}
  179.     function GetItemEnable (mh: menuHandle; item: integer): boolean;
  180.     begin
  181.         if item > 31 then
  182.             GetItemEnable := true
  183.         else
  184.             GetItemEnable := BTST(mh^^.enableFlags, item);
  185.     end;
  186.  
  187. {$S}
  188.     function GetIDItemEnable (menu, item: integer): boolean;
  189.     begin
  190.         GetIDItemEnable := GetItemEnable(GetMHandle(menu), item);
  191.     end;
  192.  
  193. {$S Util2}
  194.     procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
  195.     begin
  196.         if dotted then
  197.             SetItemMark(mh, item, '•')
  198.         else
  199.             SetItemMark(mh, item, chr(0));
  200.     end;
  201.  
  202. {$S Util2}
  203.     function MyFrontWindow: boolean;
  204.         var
  205.             wp: windowPtr;
  206.     begin
  207.         wp := FrontWindow;
  208.         if wp = nil then
  209.             MyFrontWindow := false
  210.         else
  211.             MyFrontWindow := windowPeek(wp)^.windowKind >= userKind;
  212.     end;
  213.  
  214. {$S Util2}
  215.     function DAFrontWindow: boolean;
  216.         var
  217.             wp: windowPtr;
  218.     begin
  219.         wp := FrontWindow;
  220.         if wp = nil then
  221.             DAFrontWindow := false
  222.         else
  223.             DAFrontWindow := windowPeek(wp)^.windowKind < 0;
  224.     end;
  225.  
  226. {$S Util2}
  227.     function GetIndStrSize (size, id, index: integer): str255;
  228.         var
  229.             s255: str255;
  230.     begin
  231.         GetIndString(s255, id, index);
  232.         GetIndStrSize := copy(s255, 1, size - 1);
  233.     end;
  234.  
  235. {$S Util}
  236.     procedure GetVersion (var vers: versionRecord);
  237.         var
  238.             vh: handle;
  239.     begin
  240.         with vers do begin
  241.             vh := GetResource('vers', 1);
  242.             if vh = nil then begin
  243.                 version := $0000;
  244.                 devcode := $20;
  245.                 revision := $00;
  246.                 country := 0;
  247.                 short := '0.0.0';
  248.                 long := 'Unknown v0.0.0';
  249.             end
  250.             else begin
  251.                 BlockMove(vh^, @vers, sizeof(vers));
  252. {$PUSH}
  253.  {$R-}
  254.                 BlockMove(Ptr(longint(vh^) + (longint(@short) - longint(@vers)) + ord(short[0]) + 1), @long, sizeof(long));
  255.                 if ord(short[0]) >= sizeof(short) then
  256.                     short[0] := chr(sizeof(short) - 1);
  257. {$POP}
  258.                 ReleaseResource(vh);
  259.             end;
  260.         end;
  261.     end;
  262.  
  263. {$S Util}
  264.     procedure SetVersionParamText (c2, c3: str255);
  265.         var
  266.             vers: versionRecord;
  267.     begin
  268.         GetVersion(vers);
  269.         ParamText(vers.short, vers.long, c2, c3);
  270.     end;
  271.  
  272. {$S Util}
  273.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
  274.         var
  275.             procID: longInt;
  276.             oe: OSErr;
  277.     begin
  278.         oe := GetWDInfo(wdrn, vrn, dirID, procID);
  279.         if oe <> noErr then begin
  280.             vrn := wdrn;
  281.             dirID := 0;
  282.         end;
  283.         GetDirID := oe;
  284.     end;
  285.  
  286. {$S Util2}
  287.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
  288.         var
  289.             pb: paramBlockRec;
  290.             oe: OSErr;
  291.     begin
  292.         with pb do begin
  293.             if (name <> '') & (name[length(name)] <> ':') then
  294.                 name := concat(name, ':');
  295.             pb.ioNamePtr := @name;
  296.             ioVRefNum := vrn;
  297.             ioVolIndex := index;
  298.             oe := PBGetVInfo(@pb, false);
  299.             if oe = noErr then begin
  300.                 vrn := ioVRefNum;
  301.                 CrDate := ioVCrDate;
  302.             end;
  303.         end;
  304.         GetVolInfo := oe;
  305.     end;
  306.  
  307. {$S Util}
  308.     procedure PlotSICN (id: integer; index, v, h: integer);
  309.         var
  310.             sh: Handle;
  311.             bm: BitMap;
  312.             r: Rect;
  313.             gp: grafptr;
  314.     begin
  315.         sh := GetResource('SICN', id);
  316.         HLock(sh);
  317.         bm.baseAddr := Ptr(longInt(sh^) + (index - 1) * 32);
  318.         bm.rowBytes := 2;
  319.         SetRect(r, h, v, h + 16, v + 16);
  320.         bm.bounds := r;
  321.         GetPort(gp);
  322.         CopyBits(bm, gp^.portBits, r, r, srcCopy, nil);
  323.         HUnlock(sh);
  324.     end;
  325.  
  326.     function HLockState (h: univ handle): signedByte;
  327.     begin
  328.         HLockState := HGetState(h);
  329.         HLock(h);
  330.     end;
  331.  
  332.     procedure DoSub (var dst: str255; n: integer; var s: str255);
  333.         var
  334.             p: integer;
  335.     begin
  336.         p := Pos(concat('^', chr(n + 48)), dst);
  337.         if p > 0 then begin
  338.             Delete(dst, p, 2);
  339.             Insert(s, dst, p);
  340.         end;
  341.     end;
  342.  
  343. {$Z+}
  344.     procedure SPrintS5V (var dst: str255; var src, s1, s2, s3, s4, s5: str255);
  345.     begin
  346.         dst := src;
  347.         DoSub(dst, 5, s5);
  348.         DoSub(dst, 4, s4);
  349.         DoSub(dst, 3, s3);
  350.         DoSub(dst, 2, s2);
  351.         DoSub(dst, 1, s1);
  352.     end;
  353. {$Z-}
  354.  
  355.     procedure SPrintS5 (var dst: str255; src, s1, s2, s3, s4, s5: str255);
  356.     begin
  357.         SPrintS5V(dst, src, s1, s2, s3, s4, s5);
  358.     end;
  359.  
  360.     procedure SPrintS3 (var dst: str255; src, s1, s2, s3: str255);
  361.     begin
  362.         dst := src;
  363.         DoSub(dst, 3, s3);
  364.         DoSub(dst, 2, s2);
  365.         DoSub(dst, 1, s1);
  366.     end;
  367.  
  368.     function UpCase (ch: char): char;
  369.     begin
  370.         if ch in ['a'..'z'] then
  371.             UpCase := chr(ord(ch) - $20)
  372.         else
  373.             UpCase := ch;
  374.     end;
  375.  
  376. end.