X-Git-Url: https://git.mdrn.pl/librarian.git/blobdiff_plain/2ada86c7bb585d419b95c95ce42d5b7a9fa45475..fefdce4e24f9e397df5538fe6e7f54b5ece4d841:/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/XMLparse.pm

diff --git a/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/XMLparse.pm b/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/XMLparse.pm
new file mode 100644
index 0000000..7b2b571
--- /dev/null
+++ b/src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/XMLparse.pm
@@ -0,0 +1,176 @@
+package Font::TTF::XMLparse;
+
+=head1 NAME
+
+Font::TTF::XMLparse - provides support for XML parsing. Requires Expat module XML::Parser::Expat
+
+=head1 SYNOPSIS
+
+    use Font::TTF::Font;
+    use Font::TTF::XMLparse;
+
+    $f = Font::TTF::Font->new;
+    read_xml($f, $ARGV[0]);
+    $f->out($ARGV[1]);
+
+=head1 DESCRIPTION
+
+This module contains the support routines for parsing XML and generating the
+Truetype font structures as a result. The module has been separated from the rest
+of the package in order to reduce the dependency that this would bring, of the
+whole package on XML::Parser. This way, people without the XML::Parser can still
+use the rest of the package.
+
+The package interacts with another package through the use of a context containing
+and element 'receiver' which is an object which can possibly receive one of the
+following messages:
+
+=over 4
+
+=item XML_start
+
+This message is called when an open tag occurs. It is called with the context,
+tag name and the attributes. The return value has no meaning.
+
+=item XML_end
+
+This messages is called when a close tag occurs. It is called with the context,
+tag name and attributes (held over from when the tag was opened). There are 3
+possible return values from such a message:
+
+=over 8
+
+=item undef
+
+This is the default return value indicating that default processing should
+occur in which either the current element on the tree, or the text of this element
+should be stored in the parent object.
+
+=item $context
+
+This magic value marks that the element should be deleted from the parent.
+Nothing is stored in the parent. (This rather than '' is used to allow 0 returns.)
+
+=item anything
+
+Anything else is taken as the element content to be stored in the parent.
+
+=back 4
+
+=back 4
+
+In addition, the context hash passed to these messages contains the following
+keys:
+
+=over 4
+
+=item xml
+
+This is the expat xml object. The context is also available as
+$context->{'xml'}{' mycontext'}. But that is a long winded way of not saying much!
+
+=item font
+
+This is the base object that was passed in for XML parsing.
+
+=item receiver
+
+This holds the current receiver of parsing events. It may be set in associated
+application to adjust which objects should receive messages when. It is also stored
+in the parsing stack to ensure that where an object changes it during XML_start, that
+that same object that received XML_start will receive the corresponding XML_end
+
+=item stack
+
+This is the parsing stack, used internally to hold the current receiver and attributes
+for each element open, as a complete hierarchy back to the root element.
+
+=item tree
+
+This element contains the storage tree corresponding to the parent of each element
+in the stack. The default action is to push undef onto this stack during XML_start
+and then to resolve this, either in the associated application (by changing
+$context->{'tree'}[-1]) or during XML_end of a child element, by which time we know
+whether we are dealing with an array or a hash or what.
+
+=item text
+
+Character processing is to insert all the characters into the text element of the
+context for available use later.
+
+=back 4
+
+=head1 METHODS
+
+=cut
+
+use XML::Parser::Expat;
+require Exporter;
+
+use strict;
+use vars qw(@ISA @EXPORT);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(read_xml);
+
+sub read_xml
+{
+    my ($font, $fname) = @_;
+
+    my ($xml) = XML::Parser::Expat->new;
+    my ($context) = {'xml' => $xml, 'font' => $font};
+
+    $xml->setHandlers('Start' => sub {
+            my ($x, $tag, %attrs) = @_;
+            my ($context) = $x->{' mycontext'};
+            my ($fn) = $context->{'receiver'}->can('XML_start');
+
+            push(@{$context->{'tree'}}, undef);
+            push(@{$context->{'stack'}}, [$context->{'receiver'}, {%attrs}]);
+            &{$fn}($context->{'receiver'}, $context, $tag, %attrs) if defined $fn;
+        },
+        'End' => sub {
+            my ($x, $tag) = @_;
+            my ($context) = $x->{' mycontext'};
+            my ($fn) = $context->{'receiver'}->can('XML_end');
+            my ($stackinfo) = pop(@{$context->{'stack'}});
+            my ($current, $res);
+
+            $context->{'receiver'} = $stackinfo->[0];
+            $context->{'text'} =~ s/^\s*(.*?)\s*$/$1/o;
+            $res = &{$fn}($context->{'receiver'}, $context, $tag, %{$stackinfo->[1]}) if defined $fn;
+            $current = pop(@{$context->{'tree'}});
+            $current = $context->{'text'} unless (defined $current);
+            $context->{'text'} = '';
+
+            if (defined $res)
+            {
+                return if ($res eq $context);
+                $current = $res;
+            }
+            return unless $#{$context->{'tree'}} >= 0;
+            if ($tag eq 'elem')
+            {
+                $context->{'tree'}[-1] = [] unless defined $context->{'tree'}[-1];
+                push (@{$context->{'tree'}[-1]}, $current);
+            } else
+            {
+                $context->{'tree'}[-1] = {} unless defined $context->{'tree'}[-1];
+                $context->{'tree'}[-1]{$tag} = $current;
+            }
+        },
+        'Char' => sub {
+            my ($x, $str) = @_;
+            $x->{' mycontext'}{'text'} .= $str;
+        });
+
+    $xml->{' mycontext'} = $context;
+
+    $context->{'receiver'} = $font;
+    if (ref $fname)
+    { return $xml->parse($fname); }
+    else
+    { return $xml->parsefile($fname); }
+}
+
+