cpdffont.ml

open Pdfutil
open Cpdferror
open Pdfio

(* Embed missing fonts with Ghostscript. *)
let embed_missing_fonts path_to_ghostscript gs_quiet fi fo =
  if path_to_ghostscript = "" then begin
    Pdfe.log "Please supply path to gs with -gs\n";
    exit 2
  end;
    let gscall =
      Filename.quote_command path_to_ghostscript
       ((if gs_quiet then ["-dQUIET"] else []) @ 
       ["-dNOPAUSE";
        "-sDEVICE=pdfwrite";
        ("-sOUTPUTFILE=" ^ fo);
        "-dBATCH";
        fi])
    in
      match Sys.command gscall with
      | 0 -> exit 0
      | _ -> Pdfe.log "Font embedding failed.\n"; exit 2

(* Return any font dictionary from a page or xobject given a chain and the page number. *)
let font_from_name pdf fontname pagenumber =
  try
    let resources = ref (select pagenumber (Pdfpage.pages_of_pagetree pdf)).Pdfpage.resources in
    let chain = ref (tl (String.split_on_char '/' fontname)) in
    let font = ref Pdf.Null in
      while !chain <> [] do
        match !chain with
        | [f] ->
            font := unopt (Pdf.lookup_chain pdf !resources ["/Font"; ("/" ^ f)]);
            chain := []
        | x::xs ->
            resources := unopt (Pdf.lookup_chain pdf !resources ["/XObject"; "/" ^ x; "/Resources"]);
            chain := xs
        | [] -> ()
      done;
      !font
  with
    _ -> Pdfe.log (Printf.sprintf "Not found: font %s on page %i\n" fontname pagenumber); Pdf.Null

(* Copy a font from [frompdf] with name [fontname] on page [fontpage] to [pdf] on all pages in [range] *)
let copy_font frompdf fontname fontpage range pdf =
  match Pdf.renumber_pdfs [frompdf; pdf] with
  | [] | [_] | _::_::_::_ -> assert false
  | [frompdf; pdf] ->
      (* Get font and name *)
      let fromfont = font_from_name frompdf fontname fontpage in
      let basefontname =
        match Pdf.lookup_direct frompdf "/BaseFont" fromfont with
        | Some (Pdf.Name n) -> n
        | _ -> "/CopyFontAddedNoName"
      in
      (* Get all objects forming font (except main /Font one) *)
      let objnumbers = Pdf.objects_referenced [] [] frompdf fromfont in
      (* Copy them to from frompdf to pdf. *)
      iter (function objnum -> Pdf.addobj_given_num pdf (objnum, Pdf.lookup_obj frompdf objnum)) objnumbers;
      (* Get pages from pdf *)
      let pdf_pages = Pdfpage.pages_of_pagetree pdf in
      (* Add the font to pages in range *)
      let pages' =
        map
        (function (page, pagenum) ->
           if mem pagenum range then
             let font =
               match Pdf.lookup_direct pdf "/Font" page.Pdfpage.resources with
               | Some f -> f
               | None -> Pdf.Dictionary []
             in
               let font' =
                 match font with
                 | (Pdf.Dictionary _) as d ->
                     Pdf.add_dict_entry d basefontname fromfont
                 | _ -> failwith "copy_font: error"
               in
                 let resources' =
                   Pdf.add_dict_entry page.Pdfpage.resources "/Font" font'
                 in
                   {page with
                      Pdfpage.resources = resources'}
             else page)
        (combine pdf_pages (indx pdf_pages));
      in
      (* Put the pages back into the pdf, and return *)
      let pdf, root = Pdfpage.add_pagetree pages' pdf in
        Pdfpage.add_root root [] pdf

(* Missing Fonts *)
let is_missing pdf dict =
  match Pdf.lookup_direct pdf "/Subtype" dict with
  | Some (Pdf.Name "/Type3") -> false
  | _ -> 
      match Pdf.lookup_direct pdf "/FontDescriptor" dict with
      | None -> true
      | Some d ->
          match Pdf.lookup_direct pdf "/FontFile" d with
          | Some _ -> false
          | None ->
              match Pdf.lookup_direct pdf "/FontFile2" d with
              | Some _ -> false
              | None ->
                  match Pdf.lookup_direct pdf "/FontFile3" d with
                  | Some _ -> false
                  | None -> true

let missing_font ?l pdf page (name, dict) =
  if is_missing pdf dict then
    let subtype =
      match Pdf.lookup_direct pdf "/Subtype" dict with
      | Some (Pdf.Name n) -> n
      | _ -> ""
    and basefont =
      match Pdf.lookup_direct pdf "/BaseFont" dict with
      | Some (Pdf.Name n) -> n
      | _ -> ""
    and encoding =
     match Pdf.lookup_direct pdf "/Encoding" dict with
      | Some (Pdf.Name n) -> n
      | _ -> "Built-in"
    in 
      match l with
      | None -> Printf.printf "%i, %s, %s, %s, %s\n" page name subtype basefont encoding
      | Some r -> r := (page, name, subtype, basefont, encoding)::!r

(* FIXME We must look at fonts in Form xobjects too. And process them only
   once. Plus, process fonts from pages only once too. So, introduce object
   numbers as the key (fonts can be direct too though! *)
let missing_fonts ?l pdf range =
  Cpdfpage.iter_pages
    (fun num page ->
       match Pdf.lookup_direct pdf "/Font" page.Pdfpage.resources with
       | Some (Pdf.Dictionary fontdict) ->
           (* Extract descendant fonts *)
           let name_dict_pairs =
             flatten
               (map
                  (fun (name, dict) ->
                     match Pdf.lookup_direct pdf "/DescendantFonts" dict with
                     | Some (Pdf.Array desc_fonts) -> map (fun d -> name, d) desc_fonts
                     | _ -> [(name, dict)])
                  fontdict)
           in
             iter (missing_font ?l pdf num) name_dict_pairs
       | _ -> ())
    pdf
    range

let missing_fonts_return pdf range =
  let l = ref [] in
    missing_fonts ~l pdf range;
    !l

let print_font_table pdf fontname pagenumber =
  let fontdict = font_from_name pdf fontname pagenumber in
  (* For each item in the fontdict, follow its value and find the basename. If it matches, return that font *)
  let font = ref (Some fontdict) in
    iter
      (fun (k, v) ->
         match Pdf.lookup_direct pdf "/BaseFont" v with
         | Some (Pdf.Name n) when n = fontname -> font := Some v
         | _ -> ())
      (match fontdict with Pdf.Dictionary d -> d | _ -> []);
  let font = match !font with Some f -> f | None -> failwith (Printf.sprintf "print_font_encoding: font %s not found" fontname) in
    let pdftextfont = Pdftext.read_font pdf font in
    let charset =
      match pdftextfont with
      | Pdftext.SimpleFont {Pdftext.fontdescriptor = Some {Pdftext.charset = Some cs}} -> Some cs
      | _ -> None
    in
    let extractor = Pdftext.text_extractor_of_font_real pdftextfont in
    let unicodedata = Cpdfunicodedata.unicodedata () in
    let unicodetable = Hashtbl.create 16000 in
     iter
      (fun x ->
         Hashtbl.add
           unicodetable
           (int_of_string ("0x" ^ x.Cpdfunicodedata.code_value))
           (x.Cpdfunicodedata.code_value,
            x.Cpdfunicodedata.general_category,
            x.Cpdfunicodedata.character_name,
            x.Cpdfunicodedata.iso_10646_comment_field))
      unicodedata;
      for x = 0 to 255 do
        let str =
            (if Pdftext.is_identity_h pdftextfont then "\000" else "")
          ^ string_of_char (char_of_int x)
        in
        let codepoints = Pdftext.codepoints_of_text extractor str in
        let unicodenumber, unicodename, is_control =
          match codepoints with
          | [c] ->
              begin try
                let codeval, category, character_name, comment = Hashtbl.find unicodetable c in
                  codeval, character_name, category = "Cc"
              with
                Not_found -> "", "", false
              end
          | _ -> "***multiple", "***multiple", false
        in
        let utf8 = if is_control then "<nonprintable>" else Pdftext.utf8_of_codepoints codepoints in
        let glyphnames = fold_left ( ^ ) "" (Pdftext.glyphnames_of_text extractor str) in
        let is_in_charset s = match charset with None -> true | Some cs -> mem s cs in
          if glyphnames <> ".notdef" && is_in_charset glyphnames then
            Printf.printf
              "%i = U+%s (%s - %s) = %s\n" x unicodenumber utf8 unicodename glyphnames
      done

let extract_fontfile pagenumber fontname filename pdf =
  match Pdftext.read_font pdf (font_from_name pdf fontname pagenumber) with
  | Pdftext.CIDKeyedFont (_, {Pdftext.cid_fontdescriptor = {Pdftext.fontfile = Some fontfile}}, _)
  | Pdftext.SimpleFont {Pdftext.fontdescriptor = Some {Pdftext.fontfile = Some fontfile}} ->
      begin let objnum =
        match fontfile with
        | Pdftext.FontFile i | Pdftext.FontFile2 i | Pdftext.FontFile3 i -> i
      in
        match Pdf.lookup_obj pdf objnum with
        | Pdf.Stream s as obj ->
            Pdfcodec.decode_pdfstream pdf obj;
            begin match s with
            | {contents = (_, Pdf.Got bytes)} ->
                 let fh = open_out_bin filename in
                   for x = 0 to bytes_size bytes - 1 do output_byte fh (bget bytes x) done;
                   close_out fh
            | _ -> failwith "extract_fontfile"
            end
        | _ -> failwith "extract_fontfile"
      end
  | _ -> failwith "unsupported or unfound font"

(* Remove Embedded fonts. This is done by removing the Font Descriptor. *)
let remove_fontdescriptor pdf = function
  | Pdf.Dictionary d as font ->
      begin match lookup "/Type" d with
      | Some (Pdf.Name "/Font") ->
         (match Pdf.lookup_direct pdf "/FontDescriptor" font with
         | Some fontdes ->
             let fontdescriptor' =
               Pdf.remove_dict_entry
                (Pdf.remove_dict_entry
                  (Pdf.remove_dict_entry fontdes "/FontFile")
                   "/FontFile2")
                 "/FontFile3"
             in
               Pdf.add_dict_entry font "/FontDescriptor" (Pdf.Indirect (Pdf.addobj pdf fontdescriptor'))
         | _ -> font)
      | _ -> font
      end
  | x -> x

let remove_fonts pdf =
  Pdf.objiter (fun k v -> ignore (Pdf.addobj_given_num pdf (k, remove_fontdescriptor pdf v))) pdf;
  pdf

(* List fonts *)
let list_font pdf page (name, dict) =
  let subtype =
    match Pdf.lookup_direct pdf "/Subtype" dict with
    | Some (Pdf.Name n) -> Pdfwrite.string_of_pdf (Pdf.Name n)
    | _ -> ""
  in let basefont =
    match Pdf.lookup_direct pdf "/BaseFont" dict with
    | Some (Pdf.Name n) -> Pdfwrite.string_of_pdf (Pdf.Name n)
    | _ -> ""
  in let encoding =
   match Pdf.lookup_direct pdf "/Encoding" dict with
    | Some (Pdf.Name n) -> Pdfwrite.string_of_pdf (Pdf.Name n)
    | _ -> ""
  in 
    (page, name, subtype, basefont, encoding)

(* List the fonts used in an xobject, and in any of the xobjects it has. Do not
   process an xobject twice. *)
let xobjs_processed = null_hash ()

let rec list_fonts_xobject pdf pagenum xobjname xobjnum =
  match Hashtbl.find_opt xobjs_processed xobjnum with
  | None ->
      let from_xobjs =
        match Pdf.lookup_direct pdf "/Resources" (Pdf.lookup_obj pdf xobjnum) with
        | Some r ->
            begin match Pdf.lookup_direct pdf "/XObject" r with
            | Some (Pdf.Dictionary xobjs) ->
                flatten (option_map (function (n, Pdf.Indirect i) -> Some (list_fonts_xobject pdf pagenum (xobjname ^ n) i) | _ -> None) xobjs)
            | _ -> []
            end
        | _ -> []
      in
        begin match Pdf.lookup_direct pdf "/Resources" (Pdf.lookup_obj pdf xobjnum) with
        | Some r ->
            begin match Pdf.lookup_direct pdf "/Font" r with
            | Some (Pdf.Dictionary fonts) -> map (list_font pdf pagenum) (map (function (n, f) -> (xobjname ^ n, f)) fonts) @ from_xobjs
            | _ -> from_xobjs
            end
        | None -> from_xobjs
        end
  | Some _ ->
      Hashtbl.add xobjs_processed xobjnum ();
      []
  
let list_fonts pdf range =
  Hashtbl.clear xobjs_processed;
  let pages = Pdfpage.pages_of_pagetree pdf in
    flatten
      (map
        (fun (num, page) ->
           if mem num range then
             let from_xobjs =
               match Pdf.lookup_direct pdf "/XObject" page.Pdfpage.resources with
               | Some (Pdf.Dictionary xobjs) ->
                   flatten (option_map (function (n, Pdf.Indirect i) -> Some (list_fonts_xobject pdf num n i) | _ -> None) xobjs)
               | _ -> []
             in
               begin match Pdf.lookup_direct pdf "/Font" page.Pdfpage.resources with
               | Some (Pdf.Dictionary fontdict) ->
                   map (list_font pdf num) fontdict @ from_xobjs
               | _ -> from_xobjs
               end
           else
             [])
        (combine (ilist 1 (length pages)) pages))

let string_of_font (p, n, s, b, e) =
  Printf.sprintf "%i %s %s %s %s\n" p n s b e

let json_of_font (pagenum, name, subtype, basefont, encoding) =
  `Assoc
    [("page", `Int pagenum);
     ("name", `String name);
     ("subtype", if subtype = "" then `Null else `String subtype);
     ("basefont", if basefont = "" then `Null else `String basefont);
     ("encoding", if encoding = "" then `Null else `String encoding)]

let json_fonts pdf range =
  `List (map json_of_font (list_fonts pdf range))

let print_fonts ?(json=false) pdf range =
  if json
    then flprint (Cpdfyojson.Safe.pretty_to_string (`List (map json_of_font (list_fonts pdf range))))
    else flprint (fold_left ( ^ ) "" (map string_of_font (list_fonts pdf range)))