/**********************************************************************/
/*  Name:     PCLfont.sas                                             */
/*  Purpose:  To create a PCL universal printer with extended font    */
/*            support.                                                */
/*  Usage:    %inc 'PCLfont.sas';                                     */
/*            %PCLfont.sas(file.tfm);                                 */
/*                                                                    */
/*  Notes:                                                            */
/*     1.  It is important that the "fontlib" keyword parameter be    */
/*         specified if you are not authorized to modify the sashelp  */
/*         library.  Modify your config file or use the SASHELP       */
/*         invocation option to concatenate your library with the     */
/*         SASHELP library.                                           */
/*                                                                    */
/*     2.  The Font Family code is set to Times Roman by default.  If */
/*         you would like to associate the font with a different font */
/*         family, use the "family" keyword parameter to pass the     */
/*         the appropriate code.                                      */
/*                                                                    */
/*            FONT FAMILY CODES                                       */ 
/*               Times Roman            1                             */ 
/*               Helvetica              2                             */ 
/*               Courier                3                             */
/*               Symbol                 4                             */ 
/*               ITC Avant Garde Gothic 5                             */
/*               ITC Bookman            6                             */
/*               New Century Schoolbook 7                             */
/*               Palatino               8                             */
/*               ITC Zapf Chancery      9                             */
/*               ITC Zapf Dingbats     10                             */
/*                                                                    */
/*     3.  The Character Set ID is set to "font specific" by default. */
/*         You may override this value by specifying a character set  */
/*         ID with the "charsetid" keyword parameter.                 */
/*                                                                    */
/*            CHARACTER SET IDs                                       */
/*               ID CHARACTER SET                                     */
/*                 1  Western                                         */
/*                 3  font specific (symbol charsets)                 */
/*                 5  ANSI - 7-bit ASCII                              */
/*                 6  French/German-Swiss                             */
/*                 9  Greek                                           */
/*                10  Cyrillic                                        */
/*                14  Katakana                                        */
/*                16  Finnish/Swedish                                 */
/*                18  Danish/Norwegian                                */
/*                20  German                                          */
/*                21  French                                          */
/*                22  English-UK                                      */
/*                23  Italian                                         */
/*                25  Spanish                                         */
/*                28  Japanese                                        */
/*                29  Korean                                          */
/*                31  Traditional Chinese                             */
/*                32  Simplified Chinese                              */
/*                33  Turkish                                         */
/*                34  Hebrew                                          */
/*                35  Arabic                                          */
/*                36  Baltic                                          */
/*                37  Thai                                            */
/*                38  Central European                                */
/*                39  Vietnamese                                      */
/*                41  Estonian                                        */
/*                42  Unicode                                         */
/*                43  English-USA                                     */
/*                44  UTF-8                                           */
/*                                                                    */
/*     4.  Font scaling defaults to "Scalable font with constant      */
/*         aspect ratio".  You must specify a different font scaling  */
/*         code with the "scale" keyword parameter to change the      */
/*         default.  The TFM file does not have enough information    */
/*         to determine whether a font is scalable or not.            */
/*                                                                    */
/*            FONT SCALING CODES                                      */
/*               0 Bitmap Font                                        */
/*               1 Scalable font with constant aspect ratio           */
/*               2 Scalable font whose height and width can be scaled */
/*                 independently                                      */
/*                                                                    */
/*    5.  Only type 0 font ID specifications are supported for now.   */
/*                                                                    */
/**********************************************************************/

%macro PCLfont(TFMpath, fontlib=sasuser, printer="myprinter", prototype="PCL 5E", 
                charsetid=3, family=1, scale=1, type=0);

/*
 | Read specific information from the Tagged Font Metric File
 |    Typeface name
 |    Typeface selection string
 |    Number of symbol sets
 |    Spacing
 |    Slant
 |    Stroke weight
 |    Appearance width
 |    Symbol set name
 |    Symbol set selection string
 */
filename tmp1 "newfont.sasxreg";
filename TFM "&TFMpath";

data metrics;
   infile TFM recfm=n ;
   file tmp1;
   length swName $ 15;
   input byteOrder $CHAR2. @5 dirOffset IBR4. @(dirOffset+1) nTags IBR2.;
   currentTag = 0;
   do while (currentTag < nTags);
      currentPtr = (currentTag*12 + dirOffset+3);
      input @currentPtr tagType PIBR2.;
      input dataType PIBR2.;
      input dataBlkSize PIBR4.;
      select (tagType);
         when (404)
            /*
             | Symbol Set Directory
             */ 
            do;
               /*
                |  Get Symbol Set Offsets for the Symbol Set Name,
                |  Symbol Set Selection String, and Symbol Set Index
                |  Array.
                */
               nSymbolsets = dataBlkSize/14;
               index = nSymbolsets;
               do while (index > 0);
                  input offset PIBR4. @offset+1 SymbnameOfst PIBR4.
                        SymbStrOfst PIBR4. IndexArrayOfst PIBR4.;
                  /*
                   | Get Symbol Set Name
                   */
                  strlen = 0;
                  input @SymbnameOfst+1 nextchar $CHAR1.;
                  do while (nextchar ^= '00'x);
                     strlen + 1;
                     input nextchar $CHAR1.;
                  end;
                  if strlen > 0 then 
                     do;
                        input @SymbnameOfst+1 SymbName $VARYING256. strlen;
                     end; 
                  /*
                   |  Get Symbol Set Selection String
                   */
                  strlen = 0;
                  input @SymbStrOfst+1 nextchar $CHAR1.;
                  do while (nextchar ^= '00'x);
                     strlen + 1;
                     input nextchar $CHAR1.;
                  end;
                  if strlen > 0 then 
                     do;
                        input @SymbStrOfst+1 SymbStr $VARYING256. strlen;
                     end; 
                  index = index - 1;
                  
                  /*
                   |  Add Character Set data to the PCL portion of the registry
                   */  
                  str1 = "[CORE\PRINTING\PCL\CHARACTER SETS\" || compress(SymbName) || "]";
                  put str1; 
                  
                  str1 = '"Description" = "' || SymbName || '"';
                  str2 = compress(str1);
                  put str2;
                  
                  str1 = '"ID" = int:' || &charsetid;
                  str1 = compress(str1);
                  put str1;
                  
                  str1 = '"Code"="' || SymbStr || '"';
                  str1 = compress(str1);
                  put str1;
                  output;
               end;
            end;
         when (411)
            /*
             |  Font Stroke Weight
             */
            do;
               input strokeWeight PIBR1.;
               sw = strokeWeight;
               select;
                  when (sw <=  51) 
                     do;
                        xugSW =  1;
                        swName = "Thin";
                     end;   
                  when (sw >=  52 && sw <=  68) 
                     do;
                        xugSW =  2;
                        swName = "Extra Thin";
                     end;
                  when (sw >=  69 && sw <=  85)
                     do;
                        xugSW =  3;
                        swName = "Light";
                     end;
                  when (sw >=  86 && sw <= 102)
                     do;
                        xugSW =  4; 
                        swName = "Normal";
                     end;
                  when (sw >= 103 && sw <= 119)
                     do;
                        xugSW = 5;
                        swName = "Book";
                     end;
                  when (sw >= 120 && sw <= 136)
                     do;
                        xugSW =  6;
                        swName = "Medium";
                     end;
                  when (sw >= 137 && sw <= 153)
                     do;
                        xugSW =  7;
                        swName = "Semi Bold";
                     end;
                  when (sw >= 154 && sw <= 170)
                     do;
                        xugSW =  8;
                        swName = "Demi Bold";
                     end;
                  when (sw >= 171 && sw <= 187)
                     do;
                        xugSW =  9;
                        swName = "Bold";
                     end;
                  when (sw >= 188 && sw <= 204)
                     do;
                        xugSW = 10; 
                        swName = "Heavy";
                     end;
                  when (sw >= 205 && sw <= 221)
                     do;
                        xugSW = 11;
                        swName = "Extra Bold";
                     end;
                  when (sw >= 222 && sw <= 255)
                     do;
                        xugSW = 12;
                        swName = "Ultra Bold";
                     end;
                  otherwise 
                     do;
                        xugSW = 6;
                        swName = "Medium";
                     end;
               end;
            end;   
         when (412)
            /*
             |  Font Spacing
             */
            do;
               input spacing PIBR2.;
               if (spacing = 0) then 
                  xugspacing = 8;
               else
                  xugspacing = 4;
            end;
         when (413) 
            /*
             |  Font Slant
             */
            do;
               input slant IBR2.;
               if (slant = 0) then
                  do;
                     xugSlant = 1;
                     stylName = "Regular";
                  end;
               else
                  do;
                     xugSlant = 2;
                     stylName = "Italic";
                  end;
            end;
         when (414)
            /* 
             |  Appearance Width
             */
            do;
               input width PIBR1.;
               select (width);
                  when (width >= 0 && width <= 20) 
                     xugwidth = 8; /* ultra compressed                */
                  when (width >= 21 && width <= 48)
                     xugwidth = 7; /* extra compressed                */
                  when (width >=48 && width <= 74)
                     xugwidth = 6; /* compressed                      */
                  when (width >=75 && width <= 101)
                     xugwidth = 5; /* condensed                       */
                  when (width >= 102 && width <= 128)
                     xugwidth = 1; /* narrow                          */
                  when (width >= 129 && width <= 155)
                     xugwidth = 2; /* normal                          */
                  when (width >= 156 && width <= 182)
                     xugwidth = 3; /* wide                            */
                  when (width >= 183 && width <= 209)
                     xugwidth = 9; /* expanded                        */
                  when (width >= 210 && width <= 255)
                     xugwidth = 4; /* double wide                     */
                  otherwise xugwidth = 2; /* normal             */  
               end;   
            end;
         when (417)
            /*
             |  Font Typeface
             */ 
            do;
               if (dataBlkSize <= 4) then
                  input typeface $VARYING256. dataBlkSize;
               else
                  do;
                     input dataPtr PIBR4. @dataPtr typeface $VARYING256. dataBlkSize;
                  end;
            end; 
              
         when (442)
            /*
             |  Font Typeface Selection String
             */ 
            do; 
               if (dataBlkSize <= 4) then
                     input typefaceStr $VARYING256. dataBlkSize;
               else
                     input dataPtr PIBR4. @dataPtr typefaceStr $VARYING256. dataBlkSize;
            end;
         otherwise;
      end;
      currentTag = currentTag+1;
   end; 
   put;
   output;
   /*******************************************************************
    |  Put Proc Registry statements in a temporary file.
    *******************************************************************/
   
   /*
    | Add the new font to an existing prototype
    */
   prototype = UPCASE(prototype);
   put "[CORE\PRINTING\PROTOTYPES\" &prototype "\PRINTER SETUP\FONTS]";
   str3 = '"' || typeface || '"=link:"\\CORE\\PRINTING\\PCL\\FONTS\\' || typeface || '"';
   str4 = compress(str3, '00'x);
   str4 = compress(str4);
   put str4;

   /*
    | Add the character set to the generic PCL section of the registry
    */
   str3 = '[CORE\PRINTING\PCL\FONTS\' || typeface || ']';
   str3 = compress(str3, '00'x);
   str3 = compress(str3);

   put; 
   put str3;
   str3 = compress('"Family" = int:' || &family);
   put str3;
   
   str3 = compress('"Width" = int:' || xugwidth);
   put str3;
   
   str3 = compress('"Spacing" = int:' || xugspacing);
   put str3;

   str3 = compress('"Scale" = int:' || &scale);
   put str3;
   
   str3 = compress('"Type" = int:' || &type);
   put str3;
   
   put '"Sizes"="8,9,10,11,(12,72,2)"';

   /*
    | Establish link to character set attributes
    | ** This should be a list of links instead of just a single link
    |    to one character set.
    */
   str3 = '[CORE\PRINTING\PCL\FONTS\' || compress(compress(typeface), '00'x) || "\CHARACTER SETS]";
   put str3;
   str3 = '"' || compress(SymbName) || '"=link:"\\CORE\\PRINTING\\PCL\\CHARACTER SETS\\' || compress(SymbName) || '"';
    
   put str3;
 
   /*
    | Stroke weight of font
    */  
   str3 = compress('[CORE\PRINTING\PCL\FONTS\' || typeface || '\WEIGHTS]');
   str3 = compress(str3, '00'x);
   put str3;

   str3 = compress('"' || swName || '" = int:' || xugSW);
   put str3;

   /*
    | Style of font
    */   
   str3 = compress('[CORE\PRINTING\PCL\FONTS\' || typeface || '\STYLES]');
   str3 = compress(str3, '00'x);
   put str3;
   str3 = compress('"' || stylName || '" = int:' || xugSlant);
   put str3;

   /*
    | Create the font selection code
    | ** only Type 0 is supported at this time
    */
   select (type);
      when (1)
         do;
            if (xugSW < 10) then
               str4 = compress(xugSlant || '0' || xugSW);
            else
               str4 = compress(xugSlant || xugSW);
            str3 = compress('[CORE\PRINTING\PCL\FONTS\' || typeface || '\CODE\' || str4); 
            put str3;
         end;
      otherwise
         do;
            if (xugSW < 10) then
               str4 = compress(xugSlant || '0' || xugSW);
            else
               str4 = compress(xugSlant || xugSW);
            str3 = compress('[CORE\PRINTING\PCL\FONTS\' || typeface || '\CODE\' || str4); 
            str3 = compress(str3, '00'x);
            put str3;
         end;
   end;
   
   /*
    | Extract the metric file name from the
    | path and remove the extension.
    */   
   x = index(upcase("&TFMpath"), '.TFM');
   fnamelen = x;
   pathlen = x;
   tfmFile = substr("&TFMpath", 1, x-1);
   path = tfmFile;
   do while (x-1 > 0);
      y = indexc(tfmFile, '~.\/');
      if (y > 0) then 
         do;
         fnamelen = fnamelen - y;
         tfmFile = substr(tfmFile, y+1, fnamelen);
         end;
      x = x - 1;
   end;
   str3 = compress('"Metrics" = "TFM_' || upcase(tfmFile) || '"');
   put str3;
   path = substr(path, 1, pathlen - fnamelen);
   call symput('path', path);
   stop;
run; 

  
/*
 | Add the TFM data to the core driver catalog
 */
proc genfmd path="&path" type=pcl lib=&fontlib; run;

data prt;
   name   = &printer;
   model  = &prototype;
   device = "DISK";
   dest   = "sasprt.pcl";
   opcode = "add";
;

/*
 | Update the SAS Registry
 */
proc registry import=tmp1;run;


/*
 | Create Printer Definition
 */
proc prtdef data=prt list replace;
run;
%mend; /* addPCLfnt */
/*Example*/
%macro PCLfont(TFMpath, fontlib=sasuser, printer="myprinter", prototype="PCL 5E", charsetid=3, family=1, scale=1, type=0);