#!/usr/bin/perl


# OpenOffice Font Printer
#
# Every time OpenOffice runs, it looks through paths on your
# system for possible fonts.  The found fonts are stored (with
# formatting information) to the pspfontcache file in your
# home directory.
#
# This script parses the pspfontcache file and creates a very
# basic oowriter file (.sxw) that displays all of the fonts
# in a single document.
#
# See http://www.openoffice.org/FAQs/fontguide.html for
# helpful information about font handling in OO.
#
# Usage: (in Linux)
# Run from command line under your own account
# perl gen.pl
#
# Written by Richard Still http://www.oakbox.com
# Discuss on PerlMonks.org http://www.perlmonks.org/?node_id=476398
# (c) Perl Artistic License

my $homedir = $ENV{'HOME'};
my $outfile = "fonttest.sxw";
my $psp =".openoffice"; # this is the standard location

# find the user directory, or the highest OO version
# user directory
my $seek_user = $homedir . "/" . $psp;
   opendir DIR, $seek_user || die $!;
my @directories = readdir DIR;
my $pspfonts;

my @possibilities;
foreach my $listing (@directories){
  if($listing eq "." || $listing eq ".."){ next; }
  if($listing eq "user"){ $pspfonts = "$psp/user/psprint/pspfontcache"
+; last;}
  push(@possibilities, $listing);
}

if($pspfonts eq ""){
  my @sorted = reverse sort @possibilities;
  $pspfonts = "$psp/$sorted[0]/user/psprint/pspfontcache";
}

# Attempt to open pspfontcache file
open(READ,"<$homedir/$pspfonts") || die "$homedir/$pspfonts $!\n";
my @READ = <READ>;
close(READ);

print "Using configuration file $pspfonts\n";

# Parse pspfontcache file
my $fontlist;

while(@READ){
  my $var = shift @READ;
  chomp $var;
  # many simple regex's
  if($var =~ /File/  ){ next; }
  if($var =~ /Font/  ){ next; }
  if($var =~ /Empty/ ){ next; }
  if($var =~ /[0-3]\;/ ){ next; }
  if($var eq "" ){ next; }
  $fontlist->{$var} = 1;
}

# This is the opening stuff in content.xml
my $data = q|<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE office:document-content PUBLIC "-//OpenOffice.org//DTD Offic
+eDocument 1.0//EN" "office.dtd">
<office:document-content 
xmlns:office="http://openoffice.org/2000/office" 
xmlns:style="http://openoffice.org/2000/style" 
xmlns:text="http://openoffice.org/2000/text" 
xmlns:table="http://openoffice.org/2000/table" 
xmlns:draw="http://openoffice.org/2000/drawing" 
xmlns:fo="http://www.w3.org/1999/XSL/Format" 
xmlns:xlink="http://www.w3.org/1999/xlink" 
xmlns:number="http://openoffice.org/2000/datastyle" 
xmlns:svg="http://www.w3.org/2000/svg" 
xmlns:chart="http://openoffice.org/2000/chart" 
xmlns:dr3d="http://openoffice.org/2000/dr3d" 
xmlns:math="http://www.w3.org/1998/Math/MathML" 
xmlns:form="http://openoffice.org/2000/form" 
xmlns:script="http://openoffice.org/2000/script" 
office:class="text" office:version="1.0">
<office:script/>
<office:font-decls>|;

# fonts are defined here.  I'm lying to OO, 
# I don't know what 'font-family-generic' *really* should be
# and the 'font-pitch' setting is iffy.  Well, it's not 
# perfect, but you have to make some compromises

foreach my $fontname (sort keys %{$fontlist}){
   $data .= qq|<style:font-decl style:name="$fontname" 
fo:font-family="$fontname" 
style:font-family-generic="swiss" style:font-pitch="variable"/>|;
}

$data .= qq|</office:font-decls>
<office:automatic-styles>|;

# Make a definition for different paragraph types.  
# Each paragraph style gets a different font.

my $pnum;
foreach my $fontname (sort keys %{$fontlist}){
   $pnum++;
   $fontlist->{$fontname} = $pnum;
   $data .= qq|<style:style style:name="P$pnum" style:family="paragrap
+h" style:parent-style-name="Standard">
<style:properties style:font-name="$fontname"/>
</style:style>|;
} 

   $data .= qq|</office:automatic-styles>
<office:body>
<text:sequence-decls>
<text:sequence-decl text:display-outline-level="0" text:name="Illustra
+tion"/>
<text:sequence-decl text:display-outline-level="0" text:name="Table"/>
<text:sequence-decl text:display-outline-level="0" text:name="Text"/>
<text:sequence-decl text:display-outline-level="0" text:name="Drawing"
+/>
</text:sequence-decls>|;

# Actually insert the text with the different 
# definitions driving the formatting
foreach my $fontname (sort keys %{$fontlist}){
   $data .= qq|<text:p text:style-name="P$fontlist->{$fontname}">$font
+name 
ABCDEFGHIJKLMNOPQRSTUVWXYZ 
abcdefghijklmnopqrstuvwxyz 
0123456789,.:;/?"'!#$%
</text:p>
<text:p text:style-name="P$fontlist->{$fontname}" />
|;
 } 

# close it all up
   $data .= qq|
</office:body>
</office:document-content>
|;

open(WRT,">content.xml");
print WRT $data;
close (WRT);

# Yes, you can have a complete .sxw file using
# ONLY the content.xml file.  Cool!

my @args = ("zip", "$outfile", "content.xml");
   system(@args) == 0
        or die "Boom!  Zip operation failed : $?";

print "'oowriter $outfile' should bring up the file\n";

1;
[download]