FWD

/*

** This program is free software: you can redistribute it and/or modify

** it under the terms of the GNU Affero General Public License as

** published by the Free Software Foundation, either version 3 of the

** License, or (at your option) any later version.

**

** This program is distributed in the hope that it will be useful,

** but WITHOUT ANY WARRANTY; without even the implied warranty of

** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

** GNU Affero General Public License for more details.

**

** You may find a copy of the GNU Affero GPL version 3 at the following

** location: https://www.gnu.org/licenses/agpl-3.0.en.html

** 

** Additional terms under GNU Affero GPL version 3 section 7:

** 

**   Under Section 7 of the GNU Affero GPL version 3, the following additional

**   terms apply to the works covered under the License.  These additional terms

**   are non-permissive additional terms allowed under Section 7 of the GNU

**   Affero GPL version 3 and may not be removed by you.

** 

**   0. Attribution Requirement.

** 

**     You must preserve all legal notices or author attributions in the covered

**     work or Appropriate Legal Notices displayed by works containing the covered

**     work.  You may not remove from the covered work any author or developer

**     credit already included within the covered work.

** 

**   1. No License To Use Trademarks.

** 

**     This license does not grant any license or rights to use the trademarks

**     Golden Code, FWD, any Golden Code or FWD logo, or any other trademarks

**     of Golden Code Development Corporation. You are not authorized to use the

**     name Golden Code, FWD, or the names of any author or contributor, for

**     publicity purposes without written authorization.

** 

**   2. No Misrepresentation of Affiliation.

** 

**     You may not represent yourself as Golden Code Development Corporation or FWD.

** 

**     You may not represent yourself for publicity purposes as associated with

**     Golden Code Development Corporation, FWD, or any author or contributor to

**     the covered work, without written authorization.

** 

**   3. No Misrepresentation of Source or Origin.

** 

**     You may not represent the covered work as solely your work.  All modified

**     versions of the covered work must be marked in a reasonable way to make it

**     clear that the modified work is not originating from Golden Code Development

**     Corporation or FWD.  All modified versions must contain the notices of

**     attribution required in this license.

*/

/*

Each line in the font file has this format: name,size,bold,italic,underline.

where:".

- name: is the font name (case insensitive)

- size: is the font size for which metrics will be captured, integer. if not specified, metrics from 1 to maxSize are captured

- bold: true if the bold metrics are captured. false otherwise

- italic: true if the italic metrics are captured. false otherwise

- underline: true if the underline metrics are captured. false otherwise

If any of the bold/italic/underline flags are missing, metrics for all combinations of flag set/unset are captured.

*/

def var maxSize as int init 20.

def stream fnames.

def stream frpt.

def var showdpiwarning as log init true.

def var asXml as log init true.

def var fontFile as char init "font-list.txt".

message "Enter the maximum font size (<= 1638):" update maxSize.

message "Enter the file name with the font list:" update fontFile format "x(32)".

file-info:file-name = fontFile.

if file-info:file-type = ? then do:

   message "File" fontFile "does not exist or is not accessible".

   return.

end.

procedure CreateFontIndirectA external "gdi32".

   def input param lplf as long.

   def return param hfont as long.

end.

procedure DeleteObject external "gdi32".

   def input param hgdiobj as long.

   def return param res as long.

end.

procedure SelectObject external "gdi32".

   def input param hdc as long.

   def input param hgdiobj as long.

   def return param res as long.

end.

procedure GetTextMetricsA external "gdi32".

   def input param hdc as long.

   def input param lptm as long.

   def return param returnvalue as long.

end.

procedure GetDC external "user32.dll".

   def input param ihwnd as long.

   def return param hdc as long.

end.

procedure ReleaseDC external "user32.dll".

   def input param ihwnd as long.

   def input param hdc as long.

   def return param res as long.

end.

procedure GetDeviceCaps external "gdi32".

   def input param hdc as long.

   def input param nindex as long.

   def return param res as long.

end.

procedure getMetrics.

   def input param fontname as char.

   def input param fontsize as int.

   def input-output param lp as memptr.

   def input param fbold as log.

   def input param fitalic as log.

   def input param funderline as log.

   def var res as int.

   def var hdc as integer.

   def var dpi as int.

   def var LOGPIXELSY as int init 90.

   def var err as log init false.

   run GetDc(input current-window:hwnd, output hdc).

   /* get DPI */

   run GetDeviceCaps(input hdc, input LOGPIXELSY, output dpi).

   if showdpiwarning and dpi <> 96

   then do:

      message "DPI is" dpi "instead of 96!" view-as alert-box.

      showdpiwarning = false.

   end.

   /* create font */

   def var hfont as int64.

   def var lplf as memptr.

   set-size(lplf) = 5 * 4 + 8 * 1 + 1 * 32.

   def var i as int.

   do i = 1 to get-size(lplf):

     put-byte(lplf, i) = 0.

   end.

   put-long(lplf, (1 - 1) * 4 + 1) = -1 * int64(round(fontsize * dpi / 72.0, 2)).

   put-long(lplf, (5 - 1) * 4 + 1) = (if fbold then 700 else 0).

   put-byte(lplf, 5 * 4 + 1) = (if fitalic then 1 else 0).

   put-byte(lplf, 5 * 4 + 2) = (if funderline then 1 else 0).

   put-string(lplf, 5 * 4 + 8 + 1) = fontname.

   run CreateFontIndirectA(input get-pointer-value(lplf), output hfont).

   /* select font */

   def var foohdc as integer.

   run SelectObject(input hdc, input hfont, output foohdc).

   /* get metrics */

   set-size(lp) = 15 * 4 + 5 + 10.

   run GetTextMetricsA(input hdc, input get-pointer-value(lp), output res).

   if res = 0 then err = yes.

   /* delete hfont */

   run DeleteObject(input hfont, output res).

   if res = 0 then err = yes.

   run ReleaseDC(input current-window:hwnd, input hdc, output res).

   if res = 0 then err = yes.

   /* delete the lplf */

   set-size(lplf) = 0.

   if err

   then do:

      message "GetTextMetrics failed for" fontname fontsize ". Memory leak?".

      quit.

   end.

end.

procedure recordMetrics.

   def input param fname as char.

   def input param sz as int.

   def input param fbold as log.

   def input param fitalic as log.

   def input param funderline as log.

   def var lp as memptr.

   def var h as int.

   def var avgWidth as int.

   def var maxWidth as int.

   run getMetrics(fname, sz, input-output lp, fbold, fitalic, funderline).

   h = get-long(lp, 1).

   avgWidth = get-long(lp, 5 * 4 + 1).

   maxWidth = get-long(lp, 6 * 4 + 1).

   if asXml then do:

     put stream frpt unformatted space(3)

     '<font name="' fname '" '

           'size="' sz '" '

           'bold="' trim(string(fbold, "true/false")) '" '

           'italic="' trim(string(fitalic, "true/false")) '" '

           'underline="' trim(string(funderline, "true/false")) '" '

           'width="' avgWidth '" '

           'max-width="' maxWidth '" '

           'height="' h '"/>'  skip.

   end.

   else do:

     put stream frpt unformatted 

        fname space(1) 

        sz    space(1) 

        trim(string(fbold, "true/false")) space(1) 

        trim(string(fitalic, "true/false")) space(1) 

        trim(string(funderline, "true/false")) space(1) 

        avgWidth space(1) 

        h skip.

   end.

   /* delete the lp */

   set-size(lp) = 0.

end.

def var sz as int.

def var fname as char.

def var fxmlname as char.

fxmlname = (if asXml then "font-metrics.xml" else "font-metrics.csv").

form fname label "Font Name" sz label "Size" with frame fstate down.

output stream frpt to value(fxmlname).

input stream fnames from value(fontFile).

if asXml 

then do:

   put stream frpt unformatted '<?xml version="1.0" encoding="UTF-8"?>' skip.

   put stream frpt unformatted '<!DOCTYPE font-list SYSTEM "font-metrics.dtd">' skip.

   put stream frpt unformatted "<font-list>" skip.

end.

repeat:

   def var fsize as int.

   def var fbold as log.

   def var fitalic as log.

   def var funder as log.

   fname = ?.

   fsize = ?.

   fbold = ?.

   fitalic = ?.

   funder = ?.

   import stream fnames delimiter "," fname fsize fbold fitalic funder no-error.

   if error-status:error then leave.

   do sz = (if fsize = ? or fsize = 0 then 1 else fsize) to (if fsize = ? or fsize = 0 then maxSize else fsize):

     display fname sz with frame fstate.

     def var i as int.

     do i = 1 to 8:

        def var cbold as log.

        def var citalic as log.

        def var cunder as log.

        cbold = (i > 4).

        citalic = (i = 3 or i = 4 or i = 7 or i = 8).

        cunder = i mod 2 = 0.

        if (fbold   = ? or fbold   = cbold)  and

           (fitalic = ? or fitalic = citalic)and

           (funder  = ? or funder  = cunder)

        then run recordMetrics(fname, sz, cbold, citalic, cunder).

     end.

   end.

   down 1 with frame fstate.

   /* force a flush */

   output stream frpt close.

   output stream frpt to value(fxmlname) append.

end.

if asXml then put stream frpt unformatted "</font-list>" skip.

output stream frpt close.

input stream fnames close.

message "The metrics were captured in file:" fxmlname.