home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d1xx / d138 / modulatools.lha / ModulaTools / ModulaTools.source / FontTools.mod < prev    next >
Encoding:
Modula Implementation  |  1988-03-20  |  12.0 KB  |  332 lines
  1. (******************************************************************************)
  2. (*                                                                            *)
  3. (*  Version 1.00a.002 (Beta) :   March 2, 1988                                *)
  4. (*                                                                            *)
  5. (*    These procedures were originally written under version 1.20 of the TDI  *)
  6. (* Modula-2 compiler. I have rewritten this module to operate under the v2.00 *)
  7. (* compiler. However, should you find any problem or inconsistency with the   *)
  8. (* functionality of this code, please contact me at the following address:    *)
  9. (*                                                                            *)
  10. (*                               Jerry Mack                                   *)
  11. (*                               23 Prospect Hill Ave.                        *)
  12. (*                               Waltham, MA   02154                          *)
  13. (*                                                                            *)
  14. (*    Check the module MenuUtils for TDI's (considerably less powerful) ver-  *)
  15. (* sions of my Menu and IntuitionText procedures. The modules GadgetUtils and *)
  16. (* EasyGadgets should also be of great help.                                  *)
  17. (*                                                                            *)
  18. (******************************************************************************)
  19. (*                                                                            *)
  20. (*    The source code to FontTools is in the public domain. You may do with   *)
  21. (* it as you please.                                                          *)
  22. (*                                                                            *)
  23. (******************************************************************************)
  24.  
  25. IMPLEMENTATION MODULE FontTools;
  26.  
  27. FROM DiskFontLibrary IMPORT AvailFont, AvailFonts, AFDisk, AFMemory,
  28.                             AvailFontsHeader, AvailFontsHeaderPtr,
  29.                             DiskFontName, DiskFontBase, OpenDiskFont;
  30. FROM Libraries       IMPORT LibraryPtr, OpenLibrary, CloseLibrary;
  31. FROM Storage         IMPORT ALLOCATE, DEALLOCATE;
  32. FROM Strings         IMPORT String, Compare, Equal, Greater, InitStringModule;
  33. FROM SYSTEM          IMPORT ADDRESS, NULL;
  34. FROM Text            IMPORT TextAttr, CloseFont, RemFont;
  35.  
  36. TYPE
  37.    StringPtr = POINTER TO String;
  38.  
  39. VAR
  40.    FontName          : StringPtr;
  41.    OpenedDiskFontLib : BOOLEAN;
  42.    FontBufferSize    : LONGCARD;   (* amount of memory to store Font info    *)
  43.    ExtraMemory       : LONGCARD;   (* additional memory needed for Font info *)
  44.    TotalFonts        : CARDINAL;
  45.  
  46.  
  47.    (* $T- disable range checking: compiler thinks afhAvailFonts has 1 element *)
  48.  
  49.    PROCEDURE SortFontsByName;
  50.  
  51.    VAR
  52.       i,j      : CARDINAL;
  53.       tempFont : AvailFont;
  54.       IName    : StringPtr;
  55.       JName    : StringPtr;
  56.  
  57.    BEGIN
  58.       WITH FontBuffer^ DO
  59.  
  60.          FOR i := afhNumEntries-1 TO 1 BY -1 DO
  61.             IName := afhAvailFonts[i].afAttr.taName;
  62.  
  63.             FOR j := 0 TO i-1 DO
  64.                JName := afhAvailFonts[j].afAttr.taName;
  65.  
  66.                IF (Compare(JName^, IName^) = Greater) THEN
  67.                   tempFont         := afhAvailFonts[i];
  68.                   afhAvailFonts[i] := afhAvailFonts[j];
  69.                   afhAvailFonts[j] := tempFont;
  70.                   IName := afhAvailFonts[i].afAttr.taName;
  71.                   JName := afhAvailFonts[j].afAttr.taName;
  72.                END; (* IF Compare *)
  73.  
  74.             END; (* FOR j *)
  75.  
  76.          END; (* FOR i *)
  77.  
  78.       END; (* WITH FontBuffer^ *)
  79.    END SortFontsByName;
  80.  
  81.  
  82.  
  83.    PROCEDURE SortFontsByPointSize;
  84.  
  85.    VAR
  86.       TotalFonts   : CARDINAL;
  87.       CurrentFont  : CARDINAL;
  88.       FirstFont    : CARDINAL;
  89.       CurrentName  : StringPtr;
  90.       FirstName    : StringPtr;
  91.  
  92.  
  93.       PROCEDURE RearrangePointSizes;
  94.  
  95.       VAR
  96.          tempFont     : AvailFont;
  97.          i,j          : CARDINAL;
  98.          ISize, JSize : CARDINAL;
  99.  
  100.       BEGIN
  101.          WITH FontBuffer^ DO
  102.  
  103.             FOR i := CurrentFont-1 TO FirstFont+1 BY -1 DO
  104.                ISize := afhAvailFonts[i].afAttr.taYSize;
  105.  
  106.                FOR j := FirstFont TO i-1 DO
  107.                   JSize := afhAvailFonts[j].afAttr.taYSize;
  108.  
  109.                   IF (JSize > ISize) THEN
  110.                      tempFont         := afhAvailFonts[i];
  111.                      afhAvailFonts[i] := afhAvailFonts[j];
  112.                      afhAvailFonts[j] := tempFont;
  113.                      ISize := afhAvailFonts[i].afAttr.taYSize;
  114.                      JSize := afhAvailFonts[j].afAttr.taYSize;
  115.                   END; (* IF JSize *)
  116.  
  117.                END; (* FOR j *)
  118.  
  119.             END; (* FOR i *)
  120.  
  121.          END; (* WITH FontBuffer^ *)
  122.       END RearrangePointSizes;
  123.  
  124.  
  125.    BEGIN
  126.       WITH FontBuffer^ DO
  127.  
  128.          TotalFonts  := afhNumEntries-1;
  129.          CurrentFont := 1;
  130.          FirstFont   := 0;
  131.          FirstName   := afhAvailFonts[FirstFont].afAttr.taName;
  132.  
  133.          WHILE CurrentFont <= TotalFonts DO
  134.             CurrentName := afhAvailFonts[CurrentFont].afAttr.taName;
  135.  
  136.             IF (Compare(FirstName^, CurrentName^) <> Equal) THEN
  137.  
  138.                RearrangePointSizes;
  139.  
  140.                FirstFont := CurrentFont;
  141.                FirstName := afhAvailFonts[FirstFont].afAttr.taName;
  142.  
  143.             END; (* IF Compare *)
  144.             INC(CurrentFont);
  145.  
  146.          END; (* WHILE FontsLeft *)
  147.  
  148.          RearrangePointSizes;
  149.  
  150.       END; (* WHILE FontBuffer^ *)
  151.    END SortFontsByPointSize;
  152.   
  153.  
  154. (******************************************************************************)
  155. (*                                                                            *)
  156. (*   This procedure finds all of the fonts in the FONTS: directory and sorts  *)
  157. (* them by both name and point-size. Upon exit, FontBuffer will contain a     *)
  158. (* sorted array of TextAttr structures describing the fonts. These are the    *)
  159. (* structures used by the OpenDiskFont procedure and are also used to change  *)
  160. (* the current system font for writing Menus, IntuitionText, etc.             *)
  161. (*                                                                            *)
  162. (******************************************************************************)
  163.  
  164.    PROCEDURE GetAndSortAllFonts () : BOOLEAN;
  165.  
  166.    BEGIN
  167.  
  168.       DiskFontBase     := OpenLibrary (DiskFontName, 33);
  169.       UserDiskFontBase := DiskFontBase;        (* give user access to library *)
  170.  
  171.       IF (DiskFontBase <> NULL) THEN
  172.  
  173.          OpenedDiskFontLib := TRUE;
  174.  
  175.          ALLOCATE(FontBuffer, FontBufferSize);
  176.  
  177.          ExtraMemory := AvailFonts(FontBuffer,FontBufferSize,{AFDisk,AFMemory});
  178.  
  179.          IF (ExtraMemory > 0) THEN
  180.             INC(FontBufferSize, ExtraMemory);
  181.             ExtraMemory := AvailFonts(FontBuffer, FontBufferSize,
  182.                                                  {AFDisk,AFMemory});
  183.          END; (* IF ExtraMemory *)
  184.  
  185.          SortFontsByName;
  186.          SortFontsByPointSize;
  187.  
  188.       ELSE
  189.          OpenedDiskFontLib := FALSE;
  190.       END; (* IF DiskFontBase *)
  191.  
  192.       RETURN OpenedDiskFontLib;
  193.  
  194.    END GetAndSortAllFonts;
  195.  
  196.  
  197. (******************************************************************************)
  198. (*                                                                            *)
  199. (*   This procedure deallocates the memory used by FontBuffer and closes the  *)
  200. (* DiskFont.library opened in GetAndSortAllFonts.                             *)
  201. (*                                                                            *)
  202. (******************************************************************************)
  203.  
  204.    PROCEDURE ReturnFontResourcesToSystem;
  205.    
  206.    BEGIN
  207.       IF (OpenedDiskFontLib) THEN
  208.  
  209.          DEALLOCATE(FontBuffer, FontBufferSize);
  210.          CloseLibrary (DiskFontBase);
  211.  
  212.          UserDiskFontBase  := NULL;
  213.          OpenedDiskFontLib := FALSE;
  214.  
  215.       END; (* IF OpenedDiskFontLib *)
  216.    END ReturnFontResourcesToSystem;
  217.  
  218.  
  219. (******************************************************************************)
  220. (*                                                                            *)
  221. (*   This procedure opens all the fonts in the FONTS: directory, adding them  *)
  222. (* to the system font-list. The fonts are opened in the order in which they   *)
  223. (* are stored in the FontBuffer. The procedure returns the number of fonts    *)
  224. (* which were successfully opened.                                            *)
  225. (*                                                                            *)
  226. (******************************************************************************)
  227.  
  228.    PROCEDURE OpenAllFonts () : CARDINAL;
  229.    
  230.    VAR
  231.       tempFont : FontListNodePtr;
  232.       thisFont : FontListNodePtr;
  233.       i        : CARDINAL;
  234.  
  235.    BEGIN
  236.  
  237.       IF (GetAndSortAllFonts()) THEN
  238.   
  239.          FOR i := 0 TO FontBuffer^.afhNumEntries-1 DO
  240.  
  241.             NEW(tempFont);
  242.  
  243.             IF (tempFont = NIL) THEN          (* memory-availability problem; *)
  244.                RETURN i;                      (* not i+1, since font is not   *)
  245.             END;                              (* opened yet...                *)
  246.  
  247.             IF (i = 0) THEN
  248.                thisFont := tempFont;
  249.                FontList := thisFont;
  250.             ELSE
  251.                thisFont^.next := tempFont;
  252.                thisFont       := tempFont;
  253.             END; (* IF i *) 
  254.  
  255.             thisFont^.node := OpenDiskFont(FontBuffer^.afhAvailFonts[i].afAttr);
  256.             thisFont^.next := NIL;
  257.  
  258.          END; (* FOR i *)
  259.  
  260.          RETURN FontBuffer^.afhNumEntries;      (* stored all available fonts *)
  261.  
  262.        ELSE
  263.          RETURN 0;
  264.       END; (* IF GetAndSortAllFonts *)
  265.    END OpenAllFonts;
  266.  
  267.  
  268. (******************************************************************************)
  269. (*                                                                            *)
  270. (* This procedure closes all of the fonts in the the global variable FontList.*)
  271. (* If no other process is accessing them, the fonts will be removed from the  *)
  272. (* system-font list. However, if another process is using any of the fonts in *)
  273. (* FontList, then RemFont will return a non-zero value and the font(s) will   *)
  274. (* remain in the system font-list.                                            *)
  275. (*                                                                            *)
  276. (******************************************************************************)
  277.  
  278. (******************************************************************************)
  279. (*                                                                            *)
  280. (*   NOTE: There is a bug with this procedure that causes a machine crash. I  *)
  281. (* did not have time to correct this error, as I sold my Modula-2 compiler.   *)
  282. (* I think the problem has to do with referencing an uninitialized pointer,   *)
  283. (* but that is only a guess. If my guess is correct, then the correction will *)
  284. (* will have to be made in the procedure OpenAllFonts above.                  *)
  285. (*   I apologize for not fixing this error, but Icouldn't afford to spend any *)
  286. (* more time on these tools.                                                  *)
  287. (*                                                                            *)
  288. (******************************************************************************)
  289.  
  290.    PROCEDURE CloseAllFonts;
  291.  
  292.    VAR
  293.       currentFont : FontListNodePtr;
  294.       nextFont    : FontListNodePtr;
  295.       success     : LONGINT;
  296.  
  297.    BEGIN
  298.       currentFont := FontList;                  (* get root node (first font) *)
  299.  
  300.       WHILE (currentFont <> NIL) DO
  301.  
  302.          CloseFont (currentFont^.node^);
  303.          success := RemFont (currentFont^.node^);
  304.  
  305.          nextFont := currentFont^.next;
  306.          DISPOSE(currentFont);
  307.          currentFont := nextFont;
  308.  
  309.       END; (* WHILE currentFont *)
  310.       ReturnFontResourcesToSystem;              (* empty FontBuffer and close *)
  311.                                                 (* DiskFont.lib               *)
  312.       FontList := NIL;
  313.  
  314.    END CloseAllFonts;
  315.  
  316.  
  317. (* $T+  enable range checking *)
  318.  
  319.  
  320. BEGIN
  321.  
  322.    InitStringModule;
  323.  
  324.    FontBufferSize    := LONGCARD(2048);
  325.    OpenedDiskFontLib := FALSE;
  326.    UserDiskFontBase  := NULL;
  327.    ExtraMemory       := 0;
  328.    FontBuffer        := NULL;
  329.    FontList          := NIL;
  330.  
  331. END FontTools.
  332.