increased word spacing in WL XML
[librarian.git] / 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