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 text file represents a text (case-sensitive) for which the metrics will be 

captured.  Metrics will be computed for each font in the font file (and combinations of its size

and attributes), each text being set one per line.

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, integer. if not specified, metrics for 1 to max-size 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 flag set/unset are captured.

*/

def var maxSize as int init 20.

def stream fnames.

def stream flines.

def stream frpt.

def var showdpiwarning as log init true.

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

def var textFile as char init "ui_strings.txt".

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

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

message "Enter the file name with the text list:" update textFile 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.

file-info:file-name = textFile.

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

   message "File" textFile "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 GetTextExtentPointA external "gdi32".

   def input param hdc as long.

   def input param lpctstr as long.

   def input param sz as long.

   def input param lsz 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 line as char.

   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).

   /* write string */

   def var lpstr as memptr.

   set-size(lpstr) = length(line) + 1.

   put-string(lpstr, 1) = line.

   /* get metrics */

   set-size(lp) = 2 * 4.

   run GetTextExtentPointA(input hdc, input get-pointer-value(lpstr), input length(line), 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.

   /* delete the lpstr */

   set-size(lpstr) = 0.

   if err

   then do:

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

      quit.

   end.

end.

procedure recordMetrics.

   def input param line as char.

   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 w as int.

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

   w = get-long(lp, 1).

   h = get-long(lp, 1 + 4).

   put stream frpt unformatted space(6)

   '<font name="' fname '" '

         'size="' sz '" '

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

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

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

         'width="' w '" '

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

   /* delete the lp */

   set-size(lp) = 0.

end.

def var line as char.

def var fname as char.

def var sz as int.

def var fxmlname as char.

fxmlname = "text-metrics.xml".

form fname label "Font Name" format "x(32)" line label "Line" sz label "Size" with frame fstate down.

output stream frpt to value(fxmlname).

input stream flines from value(textFile).

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

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

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

repeat:

   import stream flines unformatted line no-error.

   if error-status:error then leave.

   def var xline as char.

   xline = line.

   xline = replace(xline, '&', "&").

   xline = replace(xline, '"', """).

   xline = replace(xline, "'", "'").

   xline = replace(xline, '<', "&lt;").

   xline = replace(xline, '>', ">").

   put stream frpt unformatted space(3) '<text value="' xline '">' skip.

   input stream fnames from value(fontFile).

   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 line 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(line, fname, sz, cbold, citalic, cunder).

       end.

     end.

     down with frame fstate.

     if frame-line(fstate) = frame-down(fstate)

     then up frame-down(fstate) - 1 with frame fstate.

     /* force a flush */

     output stream frpt close.

     output stream frpt to value(fxmlname) append.

   end.

   put stream frpt unformatted space(3) '</text>' skip.

   input stream fnames close.

end.

put stream frpt unformatted "</text-list>" skip.

output stream frpt close.

input stream flines close.

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