home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 555a.lha / FontList / source / FontList.mod < prev    next >
Text File  |  1991-09-19  |  9KB  |  217 lines
  1. (*------------------------------------------------------------------------------
  2.     Project    : FontList
  3.     Module    : FontList.mod
  4.     Author    : Robert Brandner (rb)
  5.     Address    : Schillerstr. 3 / A-8280 Fürstenfeld / AUSTRIA / EUROPE
  6.     Copyright    : Public Domain
  7.     Language    : Modula-II (M2Amiga V4.0d)
  8.     History    : V0.1 24-Mar 91, rb
  9.     History    : V0.5 25-Mar 91, rb Ausgabe auf unsichtbare Bitmap
  10.     History    : V0.6 22-Aug 91, rb Anpassung an V4.0
  11.     Contents    : Liste aller Fonts in FONTS: mit Schriftprobe ausdrucken.
  12. ------------------------------------------------------------------------------*)
  13.  
  14. (*$ StackChk    := FALSE *)
  15. (*$ RangeChk    := FALSE *)
  16. (*$ OverflowChk := FALSE *)
  17. (*$ ReturnChk   := FALSE *)
  18. (*$ LongAlign   := FALSE *) (* make this TRUE for MC680x0, x>1 *)
  19. (*$ Volatile    := FALSE *)
  20. (*$ LargeVars   := FALSE *)
  21. (*$ StackParms  := FALSE *)
  22.  
  23. MODULE FontList;
  24.  
  25. FROM DosD         IMPORT sharedLock,FileInfoBlock,FileLockPtr,
  26.                  FileHandlePtr,newFile;
  27. FROM DosL         IMPORT Lock,UnLock,Examine,ExNext,Open,Close,Write;
  28. FROM Arts         IMPORT Terminate;
  29. FROM SYSTEM       IMPORT ADR;
  30. FROM String       IMPORT Copy,Concat,Length;
  31. FROM Conversions  IMPORT StrToVal;
  32. FROM GraphicsD      IMPORT TextAttr,TextFontPtr,normalFont,FontFlags,FontFlagSet,
  33.              RastPortPtr,RastPort,ColorMapPtr,BitMap,
  34.              ViewModeSet;
  35. FROM GraphicsL      IMPORT SetFont,CloseFont,SetRGB4CM,SetRast,Move,Text,SetAPen,
  36.              InitRastPort,InitBitMap,AllocRaster,FreeRaster,
  37.              GetColorMap;
  38. FROM DiskFontL      IMPORT OpenDiskFont;
  39. FROM HardCopy      IMPORT DumpRPort;
  40. FROM Printer      IMPORT Error,SpecialSet;
  41. FROM Terminal     IMPORT WriteString,WriteLn;
  42.  
  43. CONST TITLE="\[1mFontList V0.6\[0m  © '91 Robert Brandner";
  44.       TEXT="AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZzÄÖöÜü";
  45.       FLAGS=FontFlagSet{romFont,diskFont,proportional,designed};
  46.       PRTERROR="Can't open PRT:";
  47.       BMERROR="No memory for Bitplane.";
  48.       F1ERROR="FONTS: not found.";
  49.       F2ERROR="FONTS: assigned to file.";
  50.  
  51. VAR lock, lock2 : FileLockPtr;
  52.     (*$ LongAlign := TRUE *)     (* Dos braucht Variablen an Langwortgrenzen! *)
  53.     info,info2  : FileInfoBlock;
  54.     (*$ POP LongAlign *)
  55.     ok, prtok   : BOOLEAN;
  56.     Path, FName : ARRAY[0..99] OF CHAR;
  57.     size, max   : LONGINT;
  58.     rp            : RastPort;
  59.     bm            : BitMap;
  60.     cm            : ColorMapPtr;
  61.     ta          : TextAttr;
  62.     font        : TextFontPtr;
  63.     prterr      : Error;
  64.     printer     : FileHandlePtr;
  65.     newline     : ARRAY[0..0] OF CHAR;
  66.  
  67. (*------------------------------------------------------------------------------
  68.     String auf Drucker ausgeben. (Drucker wird jedesmal wieder ge-
  69.     schlossen, da es sonst zu Kollisionen mit DumpRPort kommt.
  70. ------------------------------------------------------------------------------*)
  71.  
  72. PROCEDURE Print(txt:ARRAY OF CHAR);
  73. VAR act:LONGINT;
  74. BEGIN
  75.   printer:=Open(ADR("PRT:"),newFile);       (* Printer als File öffnen.   *)
  76.   IF printer=NIL THEN
  77.     WriteString(PRTERROR); WriteLn;        (* melden, daß Printer nicht  *)
  78.     Terminate;                    (* geöffnet werden konnte.    *)
  79.   END;
  80.   (*$ StackParms := TRUE *)
  81.   act:=Write(printer,ADR(txt),Length(txt));     (* Text ausgeben           *)
  82.   (* POP StackParms *)
  83.   WriteString(txt);                 (* gleichen Text auf Screen   *)
  84.   Close(printer); printer:=NIL;            (* Printer schließen.         *)
  85. END Print;
  86.  
  87. (*--- Anzeigen des Fonts <FName>.font, in Größe <max>. -----------------------*)
  88.  
  89. PROCEDURE ShowFont;
  90. BEGIN
  91.   Concat(FName,".font");          (* Fontnamen ergänzen               *)
  92.   WITH ta DO                  (* TextAttr-Struktur füllen           *)
  93.     name:=ADR(FName);              (* Fontname                   *)
  94.     ySize:=max;                  (* Fonthöhe                   *)
  95.     style:=normalFont;             (* normale Schriftart               *)
  96.     flags:=FLAGS;              (* wenn möglich, prop. und designed   *)
  97.   END;
  98.   font:=OpenDiskFont(ADR(ta));        (* Font öffnen                    *)
  99.   IF font#NIL THEN              (* erfolgreich geöffnet               *)
  100.     SetRast(ADR(rp),0);              (* Screen löschen              *)
  101.     SetFont(ADR(rp),font);          (* neuen Font verwenden                  *)
  102.     Move(ADR(rp),5,5+rp.txBaseline);
  103.     Text(ADR(rp),ADR(TEXT),58);       (* Test-Text auf Bitmap ausgeben      *)
  104.     CloseFont(font);              (* Font wieder schließen              *)
  105.     font:=NIL;
  106.     prtok:=DumpRPort(ADR(rp),cm,ViewModeSet{},0,0,960,rp.txHeight+10,
  107.                  960,rp.txHeight+10,SpecialSet{},prterr);
  108.   ELSE
  109.     Print("Couldn't open");           (* melden, daß Font nicht geöffnet    *)
  110.     Print(newline);               (* werden konnte.              *)
  111.   END;
  112. END ShowFont;
  113.  
  114. (*------------------------------------------------------------------------------
  115.     Durchsuchen des FONTS:Fontname Directorys. Einträge sollten Files
  116.     sein, und als Namen die Größe haben (8,9,11,...).
  117. ------------------------------------------------------------------------------*)
  118.  
  119. PROCEDURE ScanSizes(Path:ARRAY OF CHAR);
  120. VAR ok,signed,err:BOOLEAN;
  121. BEGIN
  122.   signed:=FALSE;
  123.   max:=1;
  124.   lock2:=Lock(ADR(Path),sharedLock);
  125.   IF lock2=NIL THEN RETURN END;                (* kann nicht zugreifen.      *)
  126.   ok:=Examine(lock2,ADR(info2));
  127.   REPEAT                           (* Ganzes Dir. durchsuchen    *)
  128.     ok:=ExNext(lock2,ADR(info2));
  129.     IF ok THEN
  130.       IF info2.dirEntryType<0 THEN             (* Ein File gefunden.         *)
  131.         StrToVal(info2.fileName,size,          (* in Zahl umwandeln, zum     *)
  132.                  signed,10,err);           (* Größenvergleich            *)
  133.         IF size>max THEN                       (* max. Größe zu späteren     *)
  134.           max:=size;                           (* Öffnen des Fonts merken    *)
  135.         END;
  136.         Print(info2.fileName);                    (* Alle Fontgrößen            *)
  137.         Print(", ");                      (* ausgeben.              *)
  138.       END;
  139.     END;
  140.   UNTIL NOT ok;
  141.   UnLock(lock2); lock2:=NIL;
  142.   Print(newline);
  143.   ShowFont;                       (* Font in Grafik ausgeben    *)
  144. END ScanSizes;
  145.  
  146. (*------------------------------------------------------------------------------
  147.     Durchsuchen des FONTS: Directorys. Gefundene Directorys weiter
  148.     durchsuchen, sie sollten die versch. Größen enthalten.
  149. ------------------------------------------------------------------------------*)
  150.  
  151. PROCEDURE ScanFonts;
  152. VAR NewPath:ARRAY[0..99] OF CHAR;
  153. BEGIN
  154.   REPEAT                       (* ganzes Dir. durchsuchen    *)
  155.     ok:=ExNext(lock,ADR(info));
  156.     IF ok THEN
  157.       IF info.dirEntryType>0 THEN              (* ein Directory gefunden.    *)
  158.         Copy(NewPath,Path);                 (* Neuen Pfad                 *)
  159.         Concat(NewPath,info.fileName);         (* zusammenbauen.             *)
  160.         Copy(FName,info.fileName);           (* Fontnamen merken.          *)
  161.         Print(newline);
  162.         Print("Font  : ");
  163.         Print(FName); Print(newline);
  164.         Print("Sizes : ");
  165.         ScanSizes(NewPath);                    (* Directory durchsuchen.     *)
  166.       END;
  167.     END;
  168.   UNTIL NOT ok;
  169. END ScanFonts;
  170.  
  171. (*------------------------------------------------------------------------------
  172.     Öffnen einer unsichtbaren Bitmap, und einrichten eines Rastports,
  173.     sowie einer Colormap für diese Bitmap.
  174. ------------------------------------------------------------------------------*)
  175.  
  176. PROCEDURE MakeBitMap;
  177. BEGIN
  178.   InitBitMap(bm,1,960,200);                  (* 960 Pixels Druckerbreite     *)
  179.   InitRastPort(rp);
  180.   rp.bitMap:=ADR(bm);                      (* Rastport und BMap verbinden. *)
  181.   bm.planes[0]:=AllocRaster(960,200);         (* Bitplane anfordern.          *)
  182.   IF bm.planes[0]=NIL THEN
  183.     WriteString(BMERROR); WriteLn;            (* melden, wenn keine Bitplane  *)
  184.     Terminate;                                (* bekommen, und abbrechen.     *)
  185.   END;
  186.   cm:=GetColorMap(2);                      (* Colormap anfordern          *)
  187.   SetRGB4CM(cm,0,0FH,0FH,0FH);                (* Hintergrund weiß.          *)
  188.   SetRGB4CM(cm,1,00H,00H,00H);                  (* Schriftfarbe schwarz.          *)
  189.   SetAPen(ADR(rp),1);
  190. END MakeBitMap;
  191.  
  192. BEGIN
  193.   WriteString(TITLE); WriteLn;
  194.   Path:="FONTS:";
  195.   newline[0]:=CHAR(10);
  196.   lock:=Lock(ADR(Path),sharedLock);
  197.   IF lock=NIL THEN
  198.     WriteString(F1ERROR);WriteLn;                   (* FONTS: nicht da    *)
  199.     Terminate;
  200.   END;
  201.   ok:=Examine(lock,ADR(info));
  202.   IF info.dirEntryType<0 THEN
  203.     WriteString(F2ERROR);WriteLn;                (* FONTS: ist auf ein *)
  204.     Terminate;                                      (* File assigned.     *)
  205.   END;
  206.   MakeBitMap;                        (* Bitmap erzeugen.   *)
  207.   ScanFonts;
  208.   WriteString("Ready");WriteLn;
  209. CLOSE
  210.   IF lock#NIL THEN UnLock(lock) END;
  211.   IF lock2#NIL THEN UnLock(lock2) END;
  212.   IF font#NIL THEN CloseFont(font) END;
  213.   IF printer#NIL THEN Close(printer) END;
  214.   IF bm.planes[0]#NIL THEN FreeRaster(bm.planes[0],960,200) END;
  215. END FontList.
  216.  
  217.