src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/XMLparse.pm

   1 package Font::TTF::XMLparse;
   2
   3 =head1 NAME
   4
   5 Font::TTF::XMLparse - provides support for XML parsing. Requires Expat module XML::Parser::Expat
   6
   7 =head1 SYNOPSIS
   8
   9     use Font::TTF::Font;
  10     use Font::TTF::XMLparse;
  11
  12     $f = Font::TTF::Font->new;
  13     read_xml($f, $ARGV[0]);
  14     $f->out($ARGV[1]);
  15
  16 =head1 DESCRIPTION
  17
  18 This module contains the support routines for parsing XML and generating the
  19 Truetype font structures as a result. The module has been separated from the rest
  20 of the package in order to reduce the dependency that this would bring, of the
  21 whole package on XML::Parser. This way, people without the XML::Parser can still
  22 use the rest of the package.
  23
  24 The package interacts with another package through the use of a context containing
  25 and element 'receiver' which is an object which can possibly receive one of the
  26 following messages:
  27
  28 =over 4
  29
  30 =item XML_start
  31
  32 This message is called when an open tag occurs. It is called with the context,
  33 tag name and the attributes. The return value has no meaning.
  34
  35 =item XML_end
  36
  37 This messages is called when a close tag occurs. It is called with the context,
  38 tag name and attributes (held over from when the tag was opened). There are 3
  39 possible return values from such a message:
  40
  41 =over 8
  42
  43 =item undef
  44
  45 This is the default return value indicating that default processing should
  46 occur in which either the current element on the tree, or the text of this element
  47 should be stored in the parent object.
  48
  49 =item $context
  50
  51 This magic value marks that the element should be deleted from the parent.
  52 Nothing is stored in the parent. (This rather than '' is used to allow 0 returns.)
  53
  54 =item anything
  55
  56 Anything else is taken as the element content to be stored in the parent.
  57
  58 =back 4
  59
  60 =back 4
  61
  62 In addition, the context hash passed to these messages contains the following
  63 keys:
  64
  65 =over 4
  66
  67 =item xml
  68
  69 This is the expat xml object. The context is also available as
  70 $context->{'xml'}{' mycontext'}. But that is a long winded way of not saying much!
  71
  72 =item font
  73
  74 This is the base object that was passed in for XML parsing.
  75
  76 =item receiver
  77
  78 This holds the current receiver of parsing events. It may be set in associated
  79 application to adjust which objects should receive messages when. It is also stored
  80 in the parsing stack to ensure that where an object changes it during XML_start, that
  81 that same object that received XML_start will receive the corresponding XML_end
  82
  83 =item stack
  84
  85 This is the parsing stack, used internally to hold the current receiver and attributes
  86 for each element open, as a complete hierarchy back to the root element.
  87
  88 =item tree
  89
  90 This element contains the storage tree corresponding to the parent of each element
  91 in the stack. The default action is to push undef onto this stack during XML_start
  92 and then to resolve this, either in the associated application (by changing
  93 $context->{'tree'}[-1]) or during XML_end of a child element, by which time we know
  94 whether we are dealing with an array or a hash or what.
  95
  96 =item text
  97
  98 Character processing is to insert all the characters into the text element of the
  99 context for available use later.
 100
 101 =back 4
 102
 103 =head1 METHODS
 104
 105 =cut
 106
 107 use XML::Parser::Expat;
 108 require Exporter;
 109
 110 use strict;
 111 use vars qw(@ISA @EXPORT);
 112
 113 @ISA = qw(Exporter);
 114 @EXPORT = qw(read_xml);
 115
 116 sub read_xml
 117 {
 118     my ($font, $fname) = @_;
 119
 120     my ($xml) = XML::Parser::Expat->new;
 121     my ($context) = {'xml' => $xml, 'font' => $font};
 122
 123     $xml->setHandlers('Start' => sub {
 124             my ($x, $tag, %attrs) = @_;
 125             my ($context) = $x->{' mycontext'};
 126             my ($fn) = $context->{'receiver'}->can('XML_start');
 127
 128             push(@{$context->{'tree'}}, undef);
 129             push(@{$context->{'stack'}}, [$context->{'receiver'}, {%attrs}]);
 130             &{$fn}($context->{'receiver'}, $context, $tag, %attrs) if defined $fn;
 131         },
 132         'End' => sub {
 133             my ($x, $tag) = @_;
 134             my ($context) = $x->{' mycontext'};
 135             my ($fn) = $context->{'receiver'}->can('XML_end');
 136             my ($stackinfo) = pop(@{$context->{'stack'}});
 137             my ($current, $res);
 138
 139             $context->{'receiver'} = $stackinfo->[0];
 140             $context->{'text'} =~ s/^\s*(.*?)\s*$/$1/o;
 141             $res = &{$fn}($context->{'receiver'}, $context, $tag, %{$stackinfo->[1]}) if defined $fn;
 142             $current = pop(@{$context->{'tree'}});
 143             $current = $context->{'text'} unless (defined $current);
 144             $context->{'text'} = '';
 145
 146             if (defined $res)
 147             {
 148                 return if ($res eq $context);
 149                 $current = $res;
 150             }
 151             return unless $#{$context->{'tree'}} >= 0;
 152             if ($tag eq 'elem')
 153             {
 154                 $context->{'tree'}[-1] = [] unless defined $context->{'tree'}[-1];
 155                 push (@{$context->{'tree'}[-1]}, $current);
 156             } else
 157             {
 158                 $context->{'tree'}[-1] = {} unless defined $context->{'tree'}[-1];
 159                 $context->{'tree'}[-1]{$tag} = $current;
 160             }
 161         },
 162         'Char' => sub {
 163             my ($x, $str) = @_;
 164             $x->{' mycontext'}{'text'} .= $str;
 165         });
 166
 167     $xml->{' mycontext'} = $context;
 168
 169     $context->{'receiver'} = $font;
 170     if (ref $fname)
 171     { return $xml->parse($fname); }
 172     else
 173     { return $xml->parsefile($fname); }
 174 }
 175
 176