XML-Generator-1.04/0000755000175600010010000000000011610033234013564 5ustar Ben HolzmanNoneXML-Generator-1.04/Changes0000644000175600010010000001523011610032134015056 0ustar Ben HolzmanNoneRevision history for Perl extension XML::Generator. 1.04 Fri Jul 15 08:35:00 2011 - Added the filter_invalid_chars option, which is turned on by default under strict mode. 1.03 Thu Jul 30 17:02:00 2009 - Version bump because somebody released an unauthorized XML-Generator-1.02 1.01 Tue Jul 8 11:45:00 2007 - Documentation cleanup. 1.0 Fri Jun 22 16:51:00 2007 - Fixed bug #23594, "Embedded escaping does not work as expected", reported by M. Zizka; clarified documentation and added 'even-entities' argument to 'escape' parameter. - As part of above fix, supplying an unexpected true argument to 'escape' parameter results in warning. - Fixed bug #18609, "cdata also pretty-printed", reported by Daniel Schroeer. - Fixed bug #18656, reported by Peter (Stig) Edwards; just removed single quotes around Tie::IxHash in require line. 0.99_02 Tue Oct 19 23:02:00 2004 - Fixed mistake in RDF example. 0.99_01 Tue Oct 19 22:58:00 2004 - Changed default behavior of 'use XML::Generator' to not attempt to export AUTOLOAD. Removed ':noimport' option. - Allowed more than two components in a namespace, to allow explicit xmlns: attributes to be output on demand. Introduced '#default' token. - Improved output aesthetics when there are lot of attributes and the generator was configured with the 'pretty' option. - Added allowedXMLTags (alias to allowed_xml_tags) and qualified_attributes (alias to qualifiedAttributes) to rationalize interface. 0.99 Tue Mar 23 11:17:00 2004 - Removed automatic prefixing of attribute names when using a namespace. - Added 'qualifiedAttributes' constructor option to emulate prior attribute prefixing behavior. - Always syntax check attribute names under strict conformance. - Add documentation on using Tie::IxHash to get predictable attribute ordering. - Allow tag 'AUTOLOAD'. - Fixed bug with default namespace. - More tests 0.98 Mon Mar 1 18:26:00 2004 - Fixed bug in DOM.t when XML::DOM not installed (caused by fix in 0.97) 0.97 Mon Mar 1 15:22:00 2004 - Fixed bugs in DOM.t reported by David Wheeler. 0.96 Sun Feb 29 23:00:00 2004 - More documentation fixups. - Only check for xml() subs under strict conformance. - Small performance optimizations. 0.95 Sun Feb 29 22:21:00 2004 - Enhanced STACKED AUTOLOAD feature to provide a default import() - Documentation fixups. 0.94 Sun Feb 29 14:21:00 2004 - FIXED IMPLEMENTATION OF NAMESPACES!! XML::Generator is now conformant. Note that the semantics of namespaces have changed! - Implemented AUTOLOAD exporting to simplify syntax. - Implement STACKED AUTOLOADs to simplify sub-classing. - Added "macro" options ':standard', ':std', ':strict' and ':pretty'. - Added new 'allowed_xml_tags' option to allow tags starting with 'xml' under strict conformance. - Documented the 'version', 'encoding' and 'dtd' options. - Added arguments to xmldecl() to allow more control. - Changed XML comment behavior when escaping '--' to escape both dashes. - Fixed memory leak in constructor. Bug #4513. - Fixed bug in t/DOM.t that caused it to fail when DOM.pm was installed. Bug #3220. 0.93 Wed Jan 22 10:41:00 2003 - Added 'high-bit' option to escape to allow escaping of upper ASCII. - Fixed a test bug that assumed the order of elements in a hash. 0.92 Tue Jan 21 13:12:00 2003 - Finally (after multiple bug reports) stopped requiring that XML::DOM be installed for the tests to pass. Sorry this took so long to get fixed. - Also fixed a bug in XML::Generator::DOM's POD that made it look strange on search.cpan.org (reported by Ken Williams). 0.91 Mon Dec 11 11:33:32 2000 - Added XML::Generator::DOM subclass for producing DOM trees instead of strings. - New choices for the 'empty' option: 'compact' and 'args'. - Changed the semantics of 'pretty' option; CDATA sections and Processing Instructions are no longer subject to the pretty printing rules. Thanks for the bug report from Murat Uenalan. - Using closures for tag generation, which seems to save a little bit of time. Might not be worth it in the long run, for maintainability's sake. - Fix for perl versions that can't use 'for' as a statement modifier (pre 5.005) courtesy of Neil Prockter (n.prockter@lse.ac.uk). - Some documentation fixups. 0.9 Sat Nov 18 11:13:24 2000 - Massive code reorganization to support subclassing, courtesy of Nathan Winger (nate@nateware.com) - New instantiation option, 'empty', to control how empty tags are rendered. - Improved internal representation for improved performance ( $gen->foo($gen->bar($gen->baz( $really_big_string ))) used to copy $really_big_string three times; as long as the 'pretty' option is not supplied, this is no longer the case. ) - Fixed xml() tag to allow comments and processing instructions before and/or after the xml document. - New special tag, xmldtd(), which used to be part of xmldecl(). 0.8 Wed Jul 12 17:10:12 2000 - Bug-fix for pretty-printing - New special tag, "xml" which takes a complete XML document and "finalizes" it, so it can't be further embedded. - Arguments passed as scalar refs will not be escaped, even if the XML::Generator object was constructed with the 'escape' => "always" option. 0.7 Mon Jun 13 09:14:32 2000 - Pretty-printing patch from Bron Gondwana - Undefined warnings patch from Bron Gondwana 0.6 Sun Jun 11 16:02:00 2000 - Cleaned-up, modularized rewrite courtesy of Bron Gondwana (perlcode@brong.net) - XML::Generator now returns objects blessed into XML::Generator::auto which contains only an AUTOLOAD that redirects requests to the proper method in XML::Generator. - A new option is available in the constructor to force stricter conformance to the XML specification ('conformance' => 'strict'). This also enables some special tags; "xmlpi", "xmlcmnt", "xmldecl" and "xmlcdata" that can be used to generate, respectively, processing instructions, comments, the XML declaration, and character data sections. 0.5 Thu Sep 08 11:12:04 1999 - Fixed one lingering definedness bug - Added escaping options to XMLify content - Added global namespace option - Fixed namespace support somewhat 0.4 Fri Jul 02 11:44:32 1999 - Fixed a few remarkably dumb bugs which I can't believe survived this long. Improved the documentation slightly. 0.3 Tue Apr 13 09:11:13 1999 - Fixed undefined variables warnings as reported by John Labovitz (johnl@meer.net) 0.2 Wed Feb 10 12:00:00 1999 - Added support for namespaces; bholzman - Allowed "new" as a tag name; bholzman 0.1 Wed Nov 11 20:39:11 1998 - first public version; bholzman 0.01 Wed Nov 11 20:17:39 1998 - original version; created by h2xs 1.18 XML-Generator-1.04/DOM.pm0000444000175600010010000001333310030055071014540 0ustar Ben HolzmanNonepackage XML::Generator::DOM; =head1 NAME XML::Generator::DOM - XML::Generator subclass for producing DOM trees instead of strings. =head1 SYNOPSIS use XML::Generator::DOM; my $dg = XML::Generator::DOM->new(); my $doc = $dg->xml($dg->xmlcmnt("Test document."), $dg->foo({'baz' => 'bam'}, 42)); print $doc->toString; yields: 42 =head1 DESCRIPTION XML::Generator::DOM subclasses XML::Generator in order to produce DOM trees instead of strings (see L and L). This module is still experimental and its semantics might change. Essentially, tag methods return XML::DOM::DocumentFragment objects, constructed either from a DOM document passed into the constructor or a default document that XML::Generator::DOM will automatically construct. Calling the xml() method will return this automatically constructed document and cause a fresh one to be constructed for future tag method calls. If you passed in your own document, you may not call the xml() method. Below, we just note the remaining differences in semantics between XML::Generator methods and XML::Generator::DOM methods. =cut use strict; use Carp; use XML::Generator (); use base 'XML::Generator'; use XML::DOM; use vars qw( $AUTOLOAD $VERSION ); $VERSION = '0.2'; =head1 CONSTRUCTOR These configuration options are accepted but have no effect on the semantics of the returned object: escape, pretty, conformance and empty. =head1 TAG METHODS Subsequently, tag method semantics are somewhat different for this module compared to XML::Generator. The primary difference is that tag method return XML::DOM::DocumentFragment objects. Namespace and attribute processing remains the same, but remaining arguments to tag methods must either be text or other XML::DOM::DocumentFragment objects. No escape processing, syntax checking, or output control is done; this is all left up to XML::DOM. =cut sub new { my $class = shift; my $dom; for (my $i = 0; $i < $#_; $i+=2) { if ($_[$i] eq 'dom_document') { $dom = $_[$i+1]; unless (UNIVERSAL::isa($dom, 'XML::DOM::Document')) { croak "argument to 'dom' option not an XML::DOM::Document object"; } splice @_, $i, 2; last; } } if (ref $class) { $AUTOLOAD = 'new'; return $class->AUTOLOAD(@_); } my $this = $class->SUPER::new(@_); $this->{'dom'} = $dom || XML::Generator::DOM::util::new_dom_root(); return $this; } =head1 SPECIAL TAGS All special tags are available by default with XML::Generator::DOM; you don't need to use 'conformance' => 'strict'. =head2 xmlpi(@args) Arguments will simply be concatenated and passed as the data to the XML::DOM::ProcessingInstruction object that is returned. =cut sub xmlpi { my $this = shift; my $root = $this->{dom}; my $tgt = shift; return $root->createProcessingInstruction($tgt, join '', @_); } =head2 xmlcmnt Escaping of '--' is done by XML::DOM::Comment, which replaces both hyphens with '-'. An XML::DOM::Comment object is returned. =cut sub xmlcmnt { my $this = shift; my $root = $this->{dom}; my $xml = join '', @_; return $root->createComment($xml); } my $config = 'XML::Generator::util::config'; =head2 xmldecl Returns an XML::DOM::XMLDecl object. Respects 'version', 'encoding' and 'dtd' settings in the object. =cut sub xmldecl { my $this = shift; my $root = $this->{dom}; my $version = $this->$config('version') || '1.0'; my $encoding = $this->$config('encoding') || undef; my $standalone = $this->xmldtd($this->$config('dtd')) ? "no" : "yes"; return $root->createXMLDecl($version, $encoding, $standalone) } =head2 xmldecl Returns an XML::DOM::DocumentType object. =cut sub xmldtd { my($this, $dtd) = @_; my $root = $this->{dom}; $dtd ||= $this->$config('dtd'); return unless $dtd && ref($dtd) eq "ARRAY"; return $root->createDocumentType(@{ $dtd }); } =head2 xmlcdata Returns an XML::DOM::CDATASection object. =cut sub xmlcdata { my $this = shift; my $data = join '', @_; my $root = $this->{dom}; return $root->createCDATASection($data); } =head2 xml As described above, xml() can only be used when dom_document was not set in the object. The automatically created document will have its XML Declaration set and the arguments to xml() will be appended to it. Then a new DOM document is automatically generated and the old one is returned. This is the only way to get a DOM document from this module. =cut sub xml { my $this = shift; my $root = $this->{dom}; if ($root != $XML::Generator::DOM::util::root) { croak "xml() method not allowed when dom_document option specified"; } $this->{dom} = XML::Generator::DOM::util::new_dom_root(); $root->setXMLDecl($this->xmldecl()); $root->appendChild($_) for @_; return $root; } sub AUTOLOAD { my $this = shift; (my $tag = $AUTOLOAD) =~ s/.*:://;; my $root = $this->{'dom'}; my($namespace, $attr, @args) = $this->XML::Generator::util::parse_args(@_); $namespace = $namespace->[1] ? $namespace->[1] . ':' : ''; my $xml = $root->createDocumentFragment(); my $node = $xml->appendChild($root->createElement("$namespace$tag")); if ($attr) { while (my($k, $v) = each %$attr) { unless ($k =~ /^[^:]+:/) { $k = "$namespace$k"; } $node->setAttribute($k, $v); } } for (@args) { if (UNIVERSAL::isa($_, 'XML::DOM::Node')) { $node->appendChild($_); } else { $node->appendChild($root->createTextNode($_)); } } return $xml; } package XML::Generator::DOM::util; use XML::DOM; use vars qw($root $parser); $parser = XML::DOM::Parser->new; sub new_dom_root { $root = $parser->parse('<_/>'); $root->removeChild($root->getFirstChild); return $root; } 1; XML-Generator-1.04/Generator.pm0000644000175600010010000013200711610033152016052 0ustar Ben HolzmanNonepackage XML::Generator; use strict; use Carp; use vars qw/$VERSION $AUTOLOAD/; $VERSION = '1.04'; =head1 NAME XML::Generator - Perl extension for generating XML =head1 SYNOPSIS use XML::Generator ':pretty'; print foo(bar({ baz => 3 }, bam()), bar([ 'qux' => 'http://qux.com/' ], "Hey there, world")); # OR require XML::Generator; my $X = XML::Generator->new(':pretty'); print $X->foo($X->bar({ baz => 3 }, $X->bam()), $X->bar([ 'qux' => 'http://qux.com/' ], "Hey there, world")); Either of the above yield: Hey there, world =head1 DESCRIPTION In general, once you have an XML::Generator object, you then simply call methods on that object named for each XML tag you wish to generate. XML::Generator can also arrange for undefined subroutines in the caller's package to generate the corresponding XML, by exporting an C subroutine to your package. Just supply an ':import' argument to your C call. If you already have an C defined then XML::Generator can be configured to cooperate with it. See L<"STACKABLE AUTOLOADs">. Say you want to generate this XML: Bob 34 Accountant Here's a snippet of code that does the job, complete with pretty printing: use XML::Generator; my $gen = XML::Generator->new(':pretty'); print $gen->person( $gen->name("Bob"), $gen->age(34), $gen->job("Accountant") ); The only problem with this is if you want to use a tag name that Perl's lexer won't understand as a method name, such as "shoe-size". Fortunately, since you can store the name of a method in a variable, there's a simple work-around: my $shoe_size = "shoe-size"; $xml = $gen->$shoe_size("12 1/2"); Which correctly generates: 12 1/2 You can use a hash ref as the first parameter if the tag should include atributes. Normally this means that the order of the attributes will be unpredictable, but if you have the L module, you can use it to get the order you want, like this: use Tie::IxHash; tie my %attr, 'Tie::IxHash'; %attr = (name => 'Bob', age => 34, job => 'Accountant', 'shoe-size' => '12 1/2'); print $gen->person(\%attr); This produces An array ref can also be supplied as the first argument to indicate a namespace for the element and the attributes. If there is one element in the array, it is considered the URI of the default namespace, and the tag will have an xmlns="URI" attribute added automatically. If there are two elements, the first should be the tag prefix to use for the namespace and the second element should be the URI. In this case, the prefix will be used for the tag and an xmlns:PREFIX attribute will be automatically added. Prior to version 0.99, this prefix was also automatically added to each attribute name. Now, the default behavior is to leave the attributes alone (although you may always explicitly add a prefix to an attribute name). If the prior behavior is desired, use the constructor option C. If you specify more than two elements, then each pair should correspond to a tag prefix and the corresponding URL. An xmlns:PREFIX attribute will be added for each pair, and the prefix from the first such pair will be used as the tag's namespace. If you wish to specify a default namespace, use '#default' for the prefix. If the default namespace is first, then the tag will use the default namespace itself. If you want to specify a namespace as well as attributes, you can make the second argument a hash ref. If you do it the other way around, the array ref will simply get stringified and included as part of the content of the tag. Here's an example to show how the attribute and namespace parameters work: $xml = $gen->account( $gen->open(['transaction'], 2000), $gen->deposit(['transaction'], { date => '1999.04.03'}, 1500) ); This generates: 2000 1500 Because default namespaces inherit, XML::Generator takes care to output the xmlns="URI" attribute as few times as strictly necessary. For example, $xml = $gen->account( $gen->open(['transaction'], 2000), $gen->deposit(['transaction'], { date => '1999.04.03'}, $gen->amount(['transaction'], 1500) ) ); This generates: 2000 1500 Notice how C was left out of the C<> tag. Here is an example that uses the two-argument form of the namespace: $xml = $gen->widget(['wru' => 'http://www.widgets-r-us.com/xml/'], {'id' => 123}, $gen->contents()); Here is an example that uses multiple namespaces. It generates the first example from the RDF primer (L). my $contactNS = [contact => "http://www.w3.org/2000/10/swap/pim/contact#"]; $xml = $gen->xml( $gen->RDF([ rdf => "http://www.w3.org/1999/02/22-rdf-syntax-ns#", @$contactNS ], $gen->Person($contactNS, { 'rdf:about' => "http://www.w3.org/People/EM/contact#me" }, $gen->fullName($contactNS, 'Eric Miller'), $gen->mailbox($contactNS, {'rdf:resource' => "mailto:em@w3.org"}), $gen->personalTitle($contactNS, 'Dr.')))); Eric Miller Dr. =head1 CONSTRUCTOR XML::Generator-Enew(':option', ...); XML::Generator-Enew(option => 'value', ...); (Both styles may be combined) The following options are available: =head2 :std, :standard Equivalent to escape => 'always', conformance => 'strict', =head2 :strict Equivalent to conformance => 'strict', =head2 :pretty[=N] Equivalent to escape => 'always', conformance => 'strict', pretty => N # N defaults to 2 =head2 namespace This value of this option must be an array reference containing one or two values. If the array contains one value, it should be a URI and will be the value of an 'xmlns' attribute in the top-level tag. If there are two or more elements, the first of each pair should be the namespace tag prefix and the second the URI of the namespace. This will enable behavior similar to the namespace behavior in previous versions; the tag prefix will be applied to each tag. In addition, an xmlns:NAME="URI" attribute will be added to the top-level tag. Prior to version 0.99, the tag prefix was also automatically added to each attribute name, unless overridden with an explicit prefix. Now, the attribute names are left alone, but if the prior behavior is desired, use the constructor option C. The value of this option is used as the global default namespace. For example, my $html = XML::Generator->new( pretty => 2, namespace => [HTML => "http://www.w3.org/TR/REC-html40"]); print $html->html( $html->body( $html->font({ face => 'Arial' }, "Hello, there"))); would yield Hello, there Here is the same example except without all the prefixes: my $html = XML::Generator->new( pretty => 2, namespace => ["http://www.w3.org/TR/REC-html40"]); print $html->html( $html->body( $html->font({ 'face' => 'Arial' }, "Hello, there"))); would yield Hello, there =head2 qualifiedAttributes, qualified_attributes Set this to a true value to emulate the attribute prefixing behavior of XML::Generator prior to version 0.99. Here is an example: my $foo = XML::Generator->new( namespace => [foo => "http://foo.com/"], qualifiedAttributes => 1); print $foo->bar({baz => 3}); yields =head2 escape The contents and the values of each attribute have any illegal XML characters escaped if this option is supplied. If the value is 'always', then &, < and > (and " within attribute values) will be converted into the corresponding XML entity, although & will not be converted if it looks like it could be part of a valid entity (but see below). If the value is 'unescaped', then the escaping will be turned off character-by- character if the character in question is preceded by a backslash, or for the entire string if it is supplied as a scalar reference. So, for example, use XML::Generator escape => 'always'; one('<'); # < two('\&'); # \& three(\'>'); # > (scalar refs always allowed) four('<'); # < (looks like an entity) five('"'); # " (looks like an entity) but use XML::Generator escape => 'unescaped'; one('<'); # < two('\&'); # & three(\'>'); # > (aiee!) four('<'); # &lt; (no special case for entities) By default, high-bit data will be passed through unmodified, so that UTF-8 data can be generated with pre-Unicode perls. If you know that your data is ASCII, use the value 'high-bit' for the escape option and bytes with the high bit set will be turned into numeric entities. You can combine this functionality with the other escape options by comma-separating the values: my $a = XML::Generator->new(escape => 'always,high-bit'); print $a->foo("<\242>"); yields <¢> Because XML::Generator always uses double quotes ("") around attribute values, it does not escape single quotes. If you want single quotes inside attribute values to be escaped, use the value 'apos' along with 'always' or 'unescaped' for the escape option. For example: my $gen = XML::Generator->new(escape => 'always,apos'); print $gen->foo({'bar' => "It's all good"}); If you actually want & to be converted to & even if it looks like it could be part of a valid entity, use the value 'even-entities' along with 'always'. Supplying 'even-entities' to the 'unescaped' option is meaningless as entities are already escaped with that option. =head2 pretty To have nice pretty printing of the output XML (great for config files that you might also want to edit by hand), supply an integer for the number of spaces per level of indenting, eg. my $gen = XML::Generator->new(pretty => 2); print $gen->foo($gen->bar('baz'), $gen->qux({ tricky => 'no'}, 'quux')); would yield baz quux You may also supply a non-numeric string as the argument to 'pretty', in which case the indents will consist of repetitions of that string. So if you want tabbed indents, you would use: my $gen = XML::Generator->new(pretty => "\t"); Pretty printing does not apply to CDATA sections or Processing Instructions. =head2 conformance If the value of this option is 'strict', a number of syntactic checks are performed to ensure that generated XML conforms to the formal XML specification. In addition, since entity names beginning with 'xml' are reserved by the W3C, inclusion of this option enables several special tag names: xmlpi, xmlcmnt, xmldecl, xmldtd, xmlcdata, and xml to allow generation of processing instructions, comments, XML declarations, DTD's, character data sections and "final" XML documents, respectively. Invalid characters (http://www.w3.org/TR/xml11/#charsets) will be filtered out. To disable this behavior, supply the 'filter_invalid_chars' option with the value 0. See L<"XML CONFORMANCE"> and L<"SPECIAL TAGS"> for more information. =head2 filterInvalidChars, filter_invalid_chars Set this to a 1 to enable filtering of invalid characters, or to 0 to disable the filtering. See http://www.w3.org/TR/xml11/#charsets for the set of valid characters. =head2 allowedXMLTags, allowed_xml_tags If you have specified 'conformance' => 'strict' but need to use tags that start with 'xml', you can supply a reference to an array containing those tags and they will be accepted without error. It is not an error to supply this option if 'conformance' => 'strict' is not supplied, but it will have no effect. =head2 empty There are 5 possible values for this option: self - create empty tags as (default) compact - create empty tags as close - close empty tags as ignore - don't do anything (non-compliant!) args - use count of arguments to decide between and Many web browsers like the 'self' form, but any one of the forms besides 'ignore' is acceptable under the XML standard. 'ignore' is intended for subclasses that deal with HTML and other SGML subsets which allow atomic tags. It is an error to specify both 'conformance' => 'strict' and 'empty' => 'ignore'. 'args' will produce if there are no arguments at all, or if there is just a single undef argument, and otherwise. =head2 version Sets the default XML version for use in XML declarations. See L<"xmldecl"> below. =head2 encoding Sets the default encoding for use in XML declarations. =head2 dtd Specify the dtd. The value should be an array reference with three values; the type, the name and the uri. =head1 IMPORT ARGUMENTS use XML::Generator ':option'; use XML::Generator option => 'value'; (Both styles may be combined) =head2 :import Cause C to export an C to your package that makes undefined subroutines generate XML tags corresponding to their name. Note that if you already have an C defined, it will be overwritten. =head2 :stacked Implies :import, but if there is already an C defined, the overriding C will still give it a chance to run. See L<"STACKED AUTOLOADs">. =head2 ANYTHING ELSE If you supply any other options, :import is implied and the XML::Generator object that is created to generate tags will be constructed with those options. =cut package XML::Generator; use strict; require Carp; # If no value is provided for these options, they will be set to '' my @optionsToInit = qw( allowed_xml_tags conformance dtd escape namespace pretty version empty qualified_attributes filter_invalid_chars ); my %tag_factory; sub import { my $type = shift; # check for attempt to use tag 'import' if (ref $type && defined $tag_factory{$type}) { unshift @_, $type, 'import'; goto &{ $tag_factory{$type} }; } my $pkg = caller; no strict 'refs'; # Let's get serious # should we import an AUTOLOAD? no warnings 'once'; if (@_) { my $STACKED; # are we supposed to call their AUTOLOAD first? if (grep /^:stacked$/, @_) { $STACKED = \&{"${pkg}::AUTOLOAD"}; } my $this = $type->new(@_); no warnings 'redefine'; # No, I mean SERIOUS *{"${pkg}::AUTOLOAD"} = sub { if ($STACKED) { ${"${pkg}::AUTOLOAD"} = our $AUTOLOAD; my @ret = $STACKED->(@_); return wantarray ? @ret : $ret[0] if @ret; } # The tag is whatever our sub name is. my($tag) = our $AUTOLOAD =~ /.*::(.*)/; # Special-case for xml... tags if ($tag =~ /^xml/ && $this->{'conformance'} eq 'strict') { if (my $func = $this->can($tag)) { unshift @_, $this; goto &$func; } } unshift @_, $this, $tag; goto &{ $tag_factory{$this} }; }; # convenience feature for stacked autoloads; give them # an import() that aliases AUTOLOAD. if ($STACKED && ! defined *{"${pkg}::import"}{CODE}) { *{"${pkg}::import"} = sub { my $p = caller; *{"${p}::AUTOLOAD"} = \&{"${pkg}::AUTOLOAD"}; }; } } return; } # The constructor method sub new { my $class = shift; # If we already have a ref in $class, this means that the # person wants to generate a tag! return $class->XML::Generator::util::tag('new', @_) if ref $class; my %options = map { /^:(std|standard) $/x ? ( escape => 'always', conformance => 'strict' ) : /^:strict $/x ? ( conformance => 'strict' ) : /^:pretty(?:=(.+))?$/x ? ( escape => 'always', conformance => 'strict', pretty => ( defined $1 ? $1 : 2 ) ) : /^:(import | stacked )$/x ? ( do { Carp::carp("Useless use of $_") unless (caller(1))[3] =~ /::import/; () } ) : /^allowedXMLTags$/ ? 'allowed_xml_tags' : /^qualifiedAttributes$/ ? 'qualified_attributes' : /^filterInvalidChars$/ ? 'filter_invalid_chars' : $_ } @_; # We used to only accept certain options, but unfortunately this # means that subclasses can't extend the list. As such, we now # just make sure our default options are defined. for (@optionsToInit) { if (not defined $options{$_}) { $options{$_} = ''; } } if ($options{'dtd'}) { $options{'dtdtree'} = $class->XML::Generator::util::parse_dtd($options{'dtd'}); } if ($options{'conformance'} eq 'strict' && $options{'empty'} eq 'ignore') { Carp::croak "option 'empty' => 'ignore' not allowed while 'conformance' => 'strict'"; } if ($options{'escape'}) { my $e = $options{'escape'}; $options{'escape'} = 0; while ($e =~ /([-\w]+),?/g) { if ($1 eq 'always') { $options{'escape'} |= XML::Generator::util::ESCAPE_ALWAYS() | XML::Generator::util::ESCAPE_GT(); } elsif ($1 eq 'high-bit') { $options{'escape'} |= XML::Generator::util::ESCAPE_HIGH_BIT(); } elsif ($1 eq 'apos') { $options{'escape'} |= XML::Generator::util::ESCAPE_APOS(); } elsif ($1 eq 'even-entities') { $options{'escape'} |= XML::Generator::util::ESCAPE_EVEN_ENTITIES(); } elsif ($1) { if ($1 ne 'unescaped') { Carp::carp "option 'escape' => '$1' deprecated; use 'escape' => 'unescaped'"; } $options{'escape'} |= XML::Generator::util::ESCAPE_TRUE() | XML::Generator::util::ESCAPE_GT(); } } } else { $options{'escape'} = 0; } if (ref $options{'namespace'} eq 'ARRAY') { if (@{ $options{'namespace'} } > 2 && (@{ $options{'namespace'} } % 2) != 0) { Carp::croak "odd number of arguments for namespace"; } } elsif ($options{'namespace'}) { Carp::croak "namespace must be an array reference"; } if ($options{'conformance'} eq 'strict' && $options{'filter_invalid_chars'} eq '') { $options{'filter_invalid_chars'} = 1; } my $this = bless \%options, $class; $tag_factory{$this} = XML::Generator::util::c_tag($this); return $this; } # We use AUTOLOAD as a front-end to TAG so that we can # create tags by name at will. sub AUTOLOAD { my $this = shift; # The tag is whatever our sub name is, or 'AUTOLOAD' my ($tag) = defined our $AUTOLOAD ? $AUTOLOAD =~ /.*::(.*)/ : 'AUTOLOAD'; undef $AUTOLOAD; # this ensures that future attempts to use tag 'AUTOLOAD' work. unshift @_, $this, $tag; goto &{ $tag_factory{$this} }; } # I wish there were a way to allow people to use tag 'DESTROY!' # hmm, maybe xmlDESTROY? sub DESTROY { delete $tag_factory{$_[0]} } =head1 XML CONFORMANCE When the 'conformance' => 'strict' option is supplied, a number of syntactic checks are enabled. All entity and attribute names are checked to conform to the XML specification, which states that they must begin with either an alphabetic character or an underscore and may then consist of any number of alphanumerics, underscores, periods or hyphens. Alphabetic and alphanumeric are interpreted according to the current locale if 'use locale' is in effect and according to the Unicode standard for Perl versions >= 5.6. Furthermore, entity or attribute names are not allowed to begin with 'xml' (in any case), although a number of special tags beginning with 'xml' are allowed (see L<"SPECIAL TAGS">). Note that you can also supply an explicit list of allowed tags with the 'allowed_xml_tags' option. Also, the filter_invalid_chars option is automatically set to 1 unless it is explicitly set to 0. =head1 SPECIAL TAGS The following special tags are available when running under strict conformance (otherwise they don't act special): =head2 xmlpi Processing instruction; first argument is target, remaining arguments are attribute, value pairs. Attribute names are syntax checked, values are escaped. =cut # We handle a few special tags, but only if the conformance # is 'strict'. If not, we just fall back to XML::Generator::util::tag. sub xmlpi { my $this = shift; return $this->XML::Generator::util::tag('xmlpi', @_) unless $this->{conformance} eq 'strict'; my $xml; my $tgt = shift; $this->XML::Generator::util::ck_syntax($tgt); $xml = "XML::Generator::util::ck_syntax($k); XML::Generator::util::escape($v, XML::Generator::util::ESCAPE_FILTER_INVALID_CHARS() | XML::Generator::util::ESCAPE_ATTR() | $this->{'escape'}); $xml .= qq{ $k="$v"}; } } $xml .= "?>"; return XML::Generator::pi->new([$xml]); } =head2 xmlcmnt Comment. Arguments are concatenated and placed inside comment delimiters. Any occurences of '--' in the concatenated arguments are converted to '--' =cut sub xmlcmnt { my $this = shift; return $this->XML::Generator::util::tag('xmlcmnt', @_) unless $this->{conformance} eq 'strict'; my $xml = join '', @_; # double dashes are illegal; change them to '--' $xml =~ s/--/--/g; XML::Generator::util::filter($xml); $xml = ""; return XML::Generator::comment->new([$xml]); } =head2 xmldecl(@args) Declaration. This can be used to specify the version, encoding, and other XML-related declarations (i.e., anything inside the tag). @args can be used to control what is output, as keyword-value pairs. By default, the version is set to the value specified in the constructor, or to 1.0 if it was not specified. This can be overridden by providing a 'version' key in @args. If you do not want the version at all, explicitly provide undef as the value in @args. By default, the encoding is set to the value specified in the constructor; if no value was specified, the encoding will be left out altogether. Provide an 'encoding' key in @args to override this. If a dtd was set in the constructor, the standalone attribute of the declaration will be set to 'no' and the doctype declaration will be appended to the XML declartion, otherwise the standalone attribute will be set to 'yes'. This can be overridden by providing a 'standalone' key in @args. If you do not want the standalone attribute to show up, explicitly provide undef as the value. =cut sub xmldecl { my($this, @args) = @_; return $this->XML::Generator::util::tag('xmldecl', @_) unless $this->{conformance} eq 'strict'; my $version = $this->{'version'} || '1.0'; # there's no explicit support for encodings yet, but at the # least we can know to put it in the declaration my $encoding = $this->{'encoding'}; # similarly, although we don't do anything with DTDs yet, we # recognize a 'dtd' => [ ... ] option to the constructor, and # use it to create a and to indicate that this # document can't stand alone. my $doctype = $this->xmldtd($this->{dtd}); my $standalone = $doctype ? "no" : "yes"; for (my $i = 0; $i < $#args; $i += 2) { if ($args[$i] eq 'version' ) { $version = $args[$i + 1]; } elsif ($args[$i] eq 'encoding' ) { $encoding = $args[$i + 1]; } elsif ($args[$i] eq 'standalone') { $standalone = $args[$i + 1]; } else { Carp::croak("Unrecognized argument '$args[$i]'"); } } $version = qq{ version="$version"} if defined $version; $encoding = qq{ encoding="$encoding"} if defined $encoding; $standalone = qq{ standalone="$standalone"} if defined $standalone; $encoding ||= ''; $version ||= ''; $standalone ||= ''; my $xml = ""; $xml .= "\n$doctype" if $doctype; $xml = "$xml\n"; return $xml; } =head2 xmldtd DTD tag creation. The format of this method is different from others. Since DTD's are global and cannot contain namespace information, the first argument should be a reference to an array; the elements are concatenated together to form the DTD: print $xml->xmldtd([ 'html', 'PUBLIC', $xhtml_w3c, $xhtml_dtd ]) This would produce the following declaration: Assuming that $xhtml_w3c and $xhtml_dtd had the correct values. Note that you can also specify a DTD on creation using the new() method's dtd option. =cut sub xmldtd { my $this = shift; my $dtd = shift || return undef; # return the appropriate thingy $dtd ? return(qq{}) : return(''); } =head2 xmlcdata Character data section; arguments are concatenated and placed inside character data section delimiters. Any occurences of ']]>' in the concatenated arguments are converted to ']]>'. =cut sub xmlcdata { my $this = shift; $this->XML::Generator::util::tag('xmlcdata', @_) unless $this->{conformance} eq 'strict'; my $xml = join '', @_; # ]]> is not allowed; change it to ]]> $xml =~ s/]]>/]]>/g; XML::Generator::util::filter($xml); $xml = ""; return XML::Generator::cdata->new([$xml]); } =head2 xml "Final" XML document. Must be called with one and exactly one XML::Generator-produced XML document. Any combination of XML::Generator-produced XML comments or processing instructions may also be supplied as arguments. Prepends an XML declaration, and re-blesses the argument into a "final" class that can't be embedded. =cut sub xml { my $this = shift; return $this->XML::Generator::util::tag('xml', @_) unless $this->{conformance} eq 'strict'; unless (@_) { Carp::croak "usage: object->xml( (COMMENT | PI)* XML (COMMENT | PI)* )"; } my $got_root = 0; foreach my $arg (@_) { next if UNIVERSAL::isa($arg, 'XML::Generator::comment') || UNIVERSAL::isa($arg, 'XML::Generator::pi'); if (UNIVERSAL::isa($arg, 'XML::Generator::overload')) { if ($got_root) { Carp::croak "arguments to xml() can contain only one XML document"; } $got_root = 1; } else { Carp::croak "arguments to xml() must be comments, processing instructions or XML documents"; } } return XML::Generator::final->new([$this->xmldecl(), @_]); } =head1 CREATING A SUBCLASS For a simpler way to implement subclass-like behavior, see L<"STACKABLE AUTOLOADs">. At times, you may find it desireable to subclass XML::Generator. For example, you might want to provide a more application-specific interface to the XML generation routines provided. Perhaps you have a custom database application and would really like to say: my $dbxml = new XML::Generator::MyDatabaseApp; print $dbxml->xml($dbxml->custom_tag_handler(@data)); Here, custom_tag_handler() may be a method that builds a recursive XML structure based on the contents of @data. In fact, it may even be named for a tag you want generated, such as authors(), whose behavior changes based on the contents (perhaps creating recursive definitions in the case of multiple elements). Creating a subclass of XML::Generator is actually relatively straightforward, there are just three things you have to remember: 1. All of the useful utilities are in XML::Generator::util. 2. To construct a tag you simply have to call SUPER::tagname, where "tagname" is the name of your tag. 3. You must fully-qualify the methods in XML::Generator::util. So, let's assume that we want to provide a custom HTML table() method: package XML::Generator::CustomHTML; use base 'XML::Generator'; sub table { my $self = shift; # parse our args to get namespace and attribute info my($namespace, $attr, @content) = $self->XML::Generator::util::parse_args(@_) # check for strict conformance if ( $self->XML::Generator::util::config('conformance') eq 'strict' ) { # ... special checks ... } # ... special formatting magic happens ... # construct our custom tags return $self->SUPER::table($attr, $self->tr($self->td(@content))); } That's pretty much all there is to it. We have to explicitly call SUPER::table() since we're inside the class's table() method. The others can simply be called directly, assuming that we don't have a tr() in the current package. If you want to explicitly create a specific tag by name, or just want a faster approach than AUTOLOAD provides, you can use the tag() method directly. So, we could replace that last line above with: # construct our custom tags return $self->XML::Generator::util::tag('table', $attr, ...); Here, we must explicitly call tag() with the tag name itself as its first argument so it knows what to generate. These are the methods that you might find useful: =over 4 =item XML::Generator::util::parse_args() This parses the argument list and returns the namespace (arrayref), attributes (hashref), and remaining content (array), in that order. =item XML::Generator::util::tag() This does the work of generating the appropriate tag. The first argument must be the name of the tag to generate. =item XML::Generator::util::config() This retrieves options as set via the new() method. =item XML::Generator::util::escape() This escapes any illegal XML characters. =back Remember that all of these methods must be fully-qualified with the XML::Generator::util package name. This is because AUTOLOAD is used by the main XML::Generator package to create tags. Simply calling parse_args() will result in a set of XML tags called . Finally, remember that since you are subclassing XML::Generator, you do not need to provide your own new() method. The one from XML::Generator is designed to allow you to properly subclass it. =head1 STACKABLE AUTOLOADs As a simpler alternative to traditional subclassing, the C that C exports can be configured to work with a pre-defined C with the ':stacked' option. Simply ensure that your C is defined before C executes. The C will get a chance to run first; the subroutine name will be in your C<$AUTOLOAD> as normal. Return an empty list to let the default XML::Generator C run or any other value to abort it. This value will be returned as the result of the original method call. If there is no C defined, XML::Generator will create one. All that this C does is export AUTOLOAD, but that lets your package be used as if it were a subclass of XML::Generator. An example will help: package MyGenerator; my %entities = ( copy => '©', nbsp => ' ', ... ); sub AUTOLOAD { my($tag) = our $AUTOLOAD =~ /.*::(.*)/; return $entities{$tag} if defined $entities{$tag}; return; } use XML::Generator qw(:pretty :stacked); This lets someone do: use MyGenerator; print html(head(title("My Title", copy()))); Producing: My Title© =cut package XML::Generator::util; # The ::util package space actually has all the utilities # that do all the work. It must be separate from the # main XML::Generator package space since named subs will # interfere with the workings of AUTOLOAD otherwise. use strict; use Carp; use constant ESCAPE_TRUE => 1; use constant ESCAPE_ALWAYS => 1<<1; use constant ESCAPE_HIGH_BIT => 1<<2; use constant ESCAPE_APOS => 1<<3; use constant ESCAPE_ATTR => 1<<4; use constant ESCAPE_GT => 1<<5; use constant ESCAPE_EVEN_ENTITIES => 1<<6; use constant ESCAPE_FILTER_INVALID_CHARS => 1<<7; sub parse_args { # this parses the args and returns a namespace and attr # if either were specified, with the remainer of the # arguments (the content of the tag) in @args. call as: # # ($namespace, $attr, @args) = parse_args(@args); my($this, @args) = @_; my($namespace); my($attr) = (''); # check for supplied namespace if (ref $args[0] eq 'ARRAY') { $namespace = [ map { defined $_ && $_ eq '#default' ? undef : $_ } @{shift @args} ]; if (@$namespace > 2 && (@$namespace % 2) != 0) { croak "odd number of arguments for namespace"; } } # get globally-set namespace (from new) unless ($namespace) { $namespace = [ map { defined $_ && $_ eq '#default' ? undef : $_ } @{ $this->{'namespace'} || [] } ]; } if (@$namespace == 1) { unshift @$namespace, undef } # check for supplied attributes if (ref $args[0] eq 'HASH') { $attr = shift @args; if ($this->{conformance} eq 'strict') { $this->XML::Generator::util::ck_syntax($_) for map split(/:/), keys %$attr; } } return ($namespace, $attr, @args); } # This routine is what handles all the automatic tag creation. # We maintain it as a separate method so that subclasses can # override individual tags and then call SUPER::tag() to create # the tag automatically. This is not possible if only AUTOLOAD # is used, since there is no way to then pass in the name of # the tag. sub tag { my $sub = XML::Generator::util::c_tag($_[0]); goto &{ $sub } if $sub; } # Generate a closure that encapsulates all the behavior to generate a tag sub c_tag { my $arg = shift; my $strict = $arg->{'conformance'} eq 'strict'; my $escape = $arg->{'escape'}; my $empty = $arg->{'empty'}; my $indent = $arg->{'pretty'} =~ /^[^0-9]/ ? $arg->{'pretty'} : $arg->{'pretty'} ? " " x $arg->{'pretty'} : ""; if ($arg->{'filter_invalid_chars'}) { $escape |= ESCAPE_FILTER_INVALID_CHARS; } my $blessClass = $indent ? 'XML::Generator::pretty' : 'XML::Generator::overload'; return sub { my $this = shift; my $tag = shift || return undef; # catch for bad usage # parse our argument list to check for hashref/arrayref properties my($namespace, $attr, @args) = $this->XML::Generator::util::parse_args(@_); $this->XML::Generator::util::ck_syntax($tag) if $strict; # check for attempt to embed "final" document for (@args) { if (UNIVERSAL::isa($_, 'XML::Generator::final')) { croak("cannot embed XML document"); } } # Deal with escaping if required if ($escape) { if ($attr) { foreach my $key (keys %{$attr}) { next unless defined($attr->{$key}); XML::Generator::util::escape($attr->{$key}, ESCAPE_ATTR() | $escape); } } for (@args) { next unless defined($_); # perform escaping, except on sub-documents or simple scalar refs if (ref $_ eq "SCALAR") { # un-ref it $_ = $$_; } elsif (! UNIVERSAL::isa($_, 'XML::Generator::overload') ) { XML::Generator::util::escape($_, $escape); } } } else { # un-ref simple scalar refs for (@args) { $_ = $$_ if ref $_ eq "SCALAR"; } } my $prefix = ''; $prefix = $namespace->[0] . ":" if $namespace && defined $namespace->[0]; my $xml = "<$prefix$tag"; if ($attr) { while (my($k, $v) = each %$attr) { next unless defined $k and defined $v; if ($strict) { # allow supplied namespace in attribute names if ($k =~ s/^([^:]+)://) { $this->XML::Generator::util::ck_syntax($k); $k = "$1:$k"; } elsif ($prefix && $this->{'qualified_attributes'}) { $this->XML::Generator::util::ck_syntax($k); $k = "$prefix$k"; } else { $this->XML::Generator::util::ck_syntax($k); } } elsif ($this->{'qualified_attributes'}) { if ($k !~ /^[^:]+:/) { $k = "$prefix$k"; } } $xml .= qq{ $k="$v"}; } } my @xml; if (@args || $empty eq 'close') { if ($empty eq 'args' && @args == 1 && ! defined $args[0]) { @xml = ($xml .= ' />'); } else { $xml .= '>'; if ($indent) { my $prettyend = ''; foreach my $arg (@args) { next unless defined $arg; if ( UNIVERSAL::isa($arg, 'XML::Generator::cdata' ) ) { my $copy = $xml; push @xml, $copy, $arg; $xml = ''; } else { if ( UNIVERSAL::isa($arg, 'XML::Generator::overload') && ! UNIVERSAL::isa($arg, 'XML::Generator::pi') ) { $xml .= "\n$indent"; $prettyend = "\n"; XML::Generator::util::_fixupNS($namespace, $arg) if ref $arg->[0]; my @cdata; for my $i (0..$#$arg) { if (UNIVERSAL::isa($arg->[$i], 'XML::Generator::cdata')) { push @cdata, $arg->[$i]; $arg->[$i] = "\001"; } } $arg =~ s/\n/\n$indent/gs; if (@cdata) { my @pieces = split "\001", $arg; my $copy = $xml; push @xml, $copy; $xml = ''; $arg = ''; for my $i (0..$#pieces) { if (defined $cdata[$i]) { push @xml, $pieces[$i], $cdata[$i]; } else { push @xml, $pieces[$i]; } } } } $xml .= "$arg"; } } $xml .= $prettyend; push @xml, ($xml, ""); } else { @xml = $xml; foreach my $arg (grep defined, @args) { if ( UNIVERSAL::isa($arg, 'XML::Generator::overload') && (! ( UNIVERSAL::isa($arg, 'XML::Generator::cdata' ) || UNIVERSAL::isa($arg, 'XML::Generator::pi' )))) { XML::Generator::util::_fixupNS($namespace, $arg) if ref $arg->[0]; } push @xml, $arg; } push @xml, ""; } } } elsif ($empty eq 'ignore') { @xml = ($xml .= '>'); } elsif ($empty eq 'compact') { @xml = ($xml .= '/>'); } else { @xml = ($xml .= ' />'); } unshift @xml, $namespace if $namespace; return $blessClass->new(\@xml); }; } sub _fixupNS { # remove namespaces # if prefix # if prefix and uri match one we have, remove them from child # if prefix does not match one we have, remove it and uri # from child and add them to us # no prefix # if we have an explicit default namespace and the child has the # same one, remove it from the child # if we have an explicit default namespace and the child has a # different one, leave it alone # if we have an explicit default namespace and the child has none, # add an empty default namespace to child my($namespace, $o) = @_; my @n = @{$o->[0]}; my $sawDefault = 0; for (my $i = 0; $i < $#n; $i+=2) { if (defined $n[$i]) { # namespace w/ prefix my $flag = 0; for (my $j = 0; $j < $#$namespace; $j+=2) { next unless defined $namespace->[$j]; if ($namespace->[$j] eq $n[$i]) { $flag = 1; if ($namespace->[$j+1] ne $n[$i+1]) { $flag = 2; } last; } } if (!$flag) { push @$namespace, splice @n, $i, 2; $i-=2; } elsif ($flag == 1) { splice @n, $i, 2; $i-=2; } } elsif (defined $n[$i+1]) { # default namespace $sawDefault = 1; for (my $j = 0; $j < $#$namespace; $j+=2) { next if defined $namespace->[$j]; if ($namespace->[$j+1] eq $n[$i+1]) { splice @n, $i, 2; $i-=2; } } } } # check to see if we need to add explicit default namespace of "" to child if (! @{ $o->[0] } && ! $sawDefault && grep { defined $namespace->[$_ * 2 + 1] && ! defined $namespace->[$_ * 2 ] } 0..($#$namespace/2)) { push @n, undef, ""; } if (@n) { $o->[0] = [@n]; } else { splice @$o, 0, 1; } } # Fetch and store config values (those set via new()) # This is only here for subclasses sub config { my $this = shift; my $key = shift || return undef; @_ ? $this->{$key} = $_[0] : $this->{$key}; } # Collect all escaping into one place sub escape { # $_[0] is the argument, $_[1] are the flags return unless defined $_[0]; my $f = $_[1]; if ($f & ESCAPE_ALWAYS) { if ($f & ESCAPE_EVEN_ENTITIES) { $_[0] =~ s/&/&/g; } else { $_[0] =~ s/&(?!(?:#[0-9]+|#x[0-9a-fA-F]+|\w+);)/&/g; } $_[0] =~ s//>/g if $f & ESCAPE_GT; $_[0] =~ s/"/"/g if $f & ESCAPE_ATTR; $_[0] =~ s/'/'/g if $f & ESCAPE_ATTR && $f & ESCAPE_APOS; } else { $_[0] =~ s/([^\\]|^)&/$1&/g; $_[0] =~ s/\\&/&/g; $_[0] =~ s/([^\\]|^)/$1>/g; $_[0] =~ s/\\>/>/g; } if ($f & ESCAPE_ATTR) { $_[0] =~ s/([^\\]|^)"/$1"/g; $_[0] =~ s/\\"/"/g; if ($f & ESCAPE_APOS) { $_[0] =~ s/([^\\]|^)'/$1'/g; $_[0] =~ s/\\'/'/g; } } } if ($f & ESCAPE_HIGH_BIT) { $_[0] =~ s/([\200-\377])/'&#'.ord($1).';'/ge; } if ($f & ESCAPE_FILTER_INVALID_CHARS) { filter($_[0]); } } sub filter { $_[0] =~ tr/\x00\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0E\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F\x7F\x80\x81\x82\x83\x84\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F//d } # verify syntax of supplied name; croak if it's not valid. # rules: 1. name must begin with a letter or an underscore # 2. name may contain any number of letters, numbers, hyphens, # periods or underscores # 3. name cannot begin with "xml" in any case sub ck_syntax { my($this, $name) = @_; # use \w and \d so that everything works under "use locale" and # "use utf8" if ($name =~ /^\w[\w\-\.]*$/) { if ($name =~ /^\d/) { croak "name [$name] may not begin with a number"; } } else { croak "name [$name] contains illegal character(s)"; } if ($name =~ /^xml/i) { if (!$this->{'allowed_xml_tags'} || ! grep { $_ eq $name } @{ $this->{'allowed_xml_tags'} }) { croak "names beginning with 'xml' are reserved by the W3C"; } } } my %DTDs; my $DTD; sub parse_dtd { my $this = shift; my($dtd) = @_; my($root, $type, $name, $uri); croak "DTD must be supplied as an array ref" unless (ref $dtd eq 'ARRAY'); croak "DTD must have at least 3 elements" unless (@{$dtd} >= 3); ($root, $type) = @{$dtd}[0,1]; if ($type eq 'PUBLIC') { ($name, $uri) = @{$dtd}[2,3]; } elsif ($type eq 'SYSTEM') { $uri = $dtd->[2]; } else { croak "unknown dtd type [$type]"; } return $DTDs{$uri} if $DTDs{$uri}; # parse DTD into $DTD (not implemented yet) my $dtd_text = get_dtd($uri); return $DTDs{$uri} = $DTD; } sub get_dtd { my($uri) = @_; return; } # This package is needed so that embedded tags are correctly # interpreted as such and handled properly. Otherwise, you'd # get "<inner />" package XML::Generator::overload; use overload '""' => sub { $_[0]->stringify }, '0+' => sub { $_[0]->stringify }, 'bool' => sub { $_[0]->stringify }, 'eq' => sub { (ref $_[0] ? $_[0]->stringify : $_[0]) eq (ref $_[1] ? $_[1]->stringify : $_[1])}; sub new { my($class, $xml) = @_; return bless $xml, $class; } sub stringify { return $_[0] unless UNIVERSAL::isa($_[0], 'XML::Generator::overload'); if (ref($_[0]->[0])) { # namespace my $n = shift @{$_[0]}; for (my $i = ($#$n - 1); $i >= 0; $i-=2) { my($prefix, $uri) = @$n[$i,$i+1]; XML::Generator::util::escape($uri, XML::Generator::util::ESCAPE_ATTR | XML::Generator::util::ESCAPE_ALWAYS| XML::Generator::util::ESCAPE_GT); if (defined $prefix) { $_[0]->[0] =~ s/^([^ \/>]+)/$1 xmlns:$prefix="$uri"/; } else { $uri ||= ''; $_[0]->[0] =~ s/^([^ \/>]+)/$1 xmlns="$uri"/; } } } join $, || "", @{$_[0]} } sub DESTROY { } package XML::Generator::pretty; use base 'XML::Generator::overload'; sub stringify { my $this = shift; my $string = $this->SUPER::stringify(); $string =~ s{^((\s*<(?:\w+:)?\w[-.\w]* )[^ "]+"[^"]+")( .{40,})} { my($a,$b,$c) = ($1, $2, $3); $c =~ s{ ((?:\w+:)?\w+="[^\"]+")}{"\n" . (' 'x(length $b)) . $1}ge; "$a$c" }gem; return $string; } package XML::Generator::final; use base 'XML::Generator::overload'; package XML::Generator::comment; use base 'XML::Generator::overload'; package XML::Generator::pi; use base 'XML::Generator::overload'; package XML::Generator::cdata; use base 'XML::Generator::overload'; 1; __END__ =head1 AUTHORS =over 4 =item Benjamin Holzman Original author and maintainer =item Bron Gondwana First modular version =item Nathan Wiger Modular rewrite to enable subclassing =back =head1 SEE ALSO =over 4 =item The XML::Writer module http://search.cpan.org/search?mode=module&query=XML::Writer =back =cut XML-Generator-1.04/Makefile.PL0000644000175600010010000000077610030055103015542 0ustar Ben HolzmanNoneuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'XML::Generator', 'PM' => { 'Generator.pm' => '$(INST_LIBDIR)/Generator.pm', 'DOM.pm' => '$(INST_LIBDIR)/Generator/DOM.pm' }, 'MAN3PODS' => { 'Generator.pm' => '$(INST_MAN3DIR)/XML::Generator.3', 'DOM.pm' => '$(INST_MAN3DIR)/XML::Generator::DOM.3' }, 'VERSION_FROM' => 'Generator.pm', # finds $VERSION ); XML-Generator-1.04/MANIFEST0000644000175600010010000000023510637032666014735 0ustar Ben HolzmanNoneChanges Generator.pm DOM.pm MANIFEST Makefile.PL t/Generator.t t/DOM.t README META.yml Module meta-data (added by MakeMaker) XML-Generator-1.04/META.yml0000644000175600010010000000073211610033234015037 0ustar Ben HolzmanNone--- #YAML:1.0 name: XML-Generator version: 1.04 abstract: ~ author: [] license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.55_02 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 XML-Generator-1.04/README0000644000175600010010000000115011610032225014440 0ustar Ben HolzmanNoneXML::Generator - A module to help in generating XML documents SYNOPSIS -------- Lets you do this: use XML::Generator ':pretty'; print this(is(a(document()))); To get this: RECENT CHANGES ------ ------- 1.04 Fri Jul 15 08:35:00 2011 - Added the filter_invalid_chars option, which is turned on by default under strict mode. COPYRIGHT --------- Copyright 1999-2011 Benjamin Holzman. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. XML-Generator-1.04/t/0000755000175600010010000000000011610033233014026 5ustar Ben HolzmanNoneXML-Generator-1.04/t/DOM.t0000644000175600010010000000620710030055070014635 0ustar Ben HolzmanNone#!/usr/bin/perl -w use Test; unless (eval "use XML::DOM; 1;") { print "1..0 # Skipped: XML::DOM not installed\n"; exit; } plan tests => 35; require XML::Generator::DOM; my $x = new XML::Generator::DOM; ok($x); my $xml = $x->foo(); ok($xml->toString, ''); $xml = $x->bar(42); ok($xml->toString, '42'); $xml = $x->baz({'foo'=>3}); ok($xml->toString, ''); $xml = $x->bam({'bar'=>42},$x->foo(),"qux"); ok($xml->toString, 'qux'); $xml = $x->new(3); ok($xml->toString, '3'); $xml = $x->foo(['baz']); ok($xml->toString, ''); $xml = $x->foo(['baz'],{'bar'=>42},3); ok($xml->toString, '3'); $xml = $x->foo({'id' => 4}, 3, 5); ok($xml->toString, '35'); $xml = $x->foo({'id' => 4}, 0, 5); ok($xml->toString, '05'); $xml = $x->foo({'id' => 4}, 3, 0); ok($xml->toString, '30'); my $foo_bar = "foo-bar"; $xml = $x->$foo_bar(42); ok($xml->toString, '42'); $x = new XML::Generator::DOM 'namespace' => ['A']; $xml = $x->foo({'bar' => 42}, $x->bar(['B'], {'bar' => 54})); ok($xml->toString, ''); $xml = $x->xmldecl(); ok(UNIVERSAL::isa($xml, 'XML::DOM::XMLDecl')); ok($xml->getVersion, '1.0'); ok($xml->getStandalone, 'yes'); $xml = $x->xmlcmnt("test"); ok(UNIVERSAL::isa($xml, 'XML::DOM::Comment')); ok($xml->getData, 'test'); $x = new XML::Generator::DOM 'version' => '1.1', 'encoding' => 'iso-8859-2'; $xml = $x->xmldecl(); ok($xml->getVersion, '1.1'); ok($xml->getEncoding, 'iso-8859-2'); $xml = $x->xmlpi("target", 'option="value"'); ok(UNIVERSAL::isa($xml, 'XML::DOM::ProcessingInstruction')); ok($xml->getTarget, 'target'); ok($xml->getData, 'option="value"'); eval { my $t = "42"; $x->$t(); }; ok(UNIVERSAL::isa($@, 'XML::DOM::DOMException')); $xml = $x->foo(['bar'], {'baz:foo' => 'qux', 'fob' => 'gux'}); ok($xml->toString eq '' || $xml->toString eq ''); $x = new XML::Generator::DOM 'dtd' => [ 'foo', 'SYSTEM', '"http://foo.com/foo"' ]; $xml = $x->xmldecl(); ok($xml->getStandalone, 'no'); $xml = $x->xmlcdata("test"); ok(UNIVERSAL::isa($xml, 'XML::DOM::CDATASection')); ok($xml->getData, 'test'); $x = new XML::Generator::DOM; $xml = $x->foo($x->xmlcdata("bar"), $x->xmlpi("baz", "bam")); ok($xml->toString, ''); $xml = $x->foo(42); $xml = $x->xml($xml); ok($xml->toString, ' 42 '); eval { $xml = $x->bar($xml); }; ok($@); ok($@->getName, 'WRONG_DOCUMENT_ERR'); $xml = $x->foo(); $cmnt = $x->xmlcmnt("comment"); $pi = $x->xmlpi("foo", "bar"); $xml = $x->xml($cmnt, $xml, $pi); ok($xml->toString, ' '); require XML::DOM; $doc = XML::DOM::Parser->new->parse(''); $x = XML::Generator::DOM->new( dom_document => $doc ); $doc->getFirstChild->appendChild($x->foo(42)); ok($doc->toString, '42 '); eval { $xml = $x->xml($x->bar(12)); }; ok($@ =~ /method not allowed/); XML-Generator-1.04/t/Generator.t0000644000175600010010000003404711610032306016151 0ustar Ben HolzmanNone#!/usr/bin/perl -w use Test; BEGIN { $| = 1; plan tests => 100; } use XML::Generator (); ok(1); my $x = XML::Generator->new(); ok($x); my $xml = $x->foo(); ok($xml, ''); $xml = $x->bar(42); ok($xml, '42'); $xml = $x->baz({'foo'=>3}); ok($xml, ''); $xml = $x->bam({'bar'=>42},$x->foo(),"qux"); ok($xml, 'qux'); eval { require Tie::IxHash; }; if ($@) { skip('Tie::IxHash not installed', 1); } else { tie %h, 'Tie::IxHash'; @h{'a'..'z'} = 1..26; $xml = $x->foo(\%h); ok($xml, ''); } $xml = $x->new(3); ok($xml, '3'); $xml = $x->import(3); ok($xml, '3'); $xml = $x->foo(['baz']); ok($xml, ''); $xml = $x->foo(['baz','bam']); ok($xml, ''); $xml = $x->foo(['baz'],{'bar'=>42},3); ok($xml, '3'); $xml = $x->foo(['baz','bam'],{'bar'=>42},3); ok($xml, '3'); $xml = $x->foo({'id' => 4}, 3, 5); ok($xml, '35'); $xml = $x->foo({'id' => 4}, 0, 5); ok($xml, '05'); $xml = $x->foo({'id' => 4}, 3, 0); ok($xml, '30'); my $foo_bar = "foo-bar"; $xml = $x->$foo_bar(42); ok($xml, '42'); $x = new XML::Generator 'escape' => 'always'; $xml = $x->foo({'bar' => '4"4'}, '<&>"\<', \"<>"); ok($xml, '<&>"\<<>'); $x = new XML::Generator 'escape' => 'unescaped'; $xml = $x->foo({'bar' => '4\"4'}, '<&>"\<', \"&& 6 < 5"); ok($xml, '<&>"<&& 6 < 5'); $x = new XML::Generator 'namespace' => ['A']; $xml = $x->foo({'bar' => 42}, $x->bar(['B'], {'bar' => 54})); ok($xml, ''); $x = new XML::Generator 'conformance' => 'strict'; $xml = $x->xmldecl(); ok($xml, qq(\n)); $xml = $x->xmlcmnt("test"); ok($xml, ''); $x = new XML::Generator 'conformance' => 'strict', 'version' => '1.1', 'encoding' => 'iso-8859-2'; $xml = $x->xmldecl(); ok($xml, qq(\n)); $xml = $x->xmldecl(version => undef, encoding => undef, standalone => undef); ok($xml, qq(\n)); $xml = $x->xmldecl(version => '1.0', encoding => 'utf8', standalone => 'no'); ok($xml, qq(\n)); $xml = $x->xmlpi("target", "option" => "value"); ok($xml, ''); eval { $x->xmlfoo(); }; ok($@, qr{names beginning with 'xml' are reserved by the W3C}); eval { $x->foo({xmlfoo => 4}); }; ok($@, qr{names beginning with 'xml' are reserved by the W3C}); eval { my $t = "42"; $x->$t(); }; ok($@, qr{name \[42] may not begin with a number}); eval { $x->q({42=>'the answer'}); }; ok($@, qr{name \[42] may not begin with a number}); eval { my $t = "g:"; $x->$t(); }; ok($@, qr{name \[g:] contains illegal character\(s\)}); $xml = $x->foo(['bar'], {'baz:foo' => 'qux', 'fob' => 'gux'}); ok($xml eq '' || $xml eq '', 1, $xml); $xml = $x->foo(['bar' => 'bam'], {'baz:foo' => 'qux', 'fob' => 'gux'}); ok($xml eq '' || $xml eq '', 1, $xml); $x = new XML::Generator; $xml = $x->xml(); ok($xml, ''); $x = new XML::Generator 'conformance' => 'strict', 'dtd' => [ 'foo', 'SYSTEM', '"http://foo.com/foo"' ]; $xml = $x->xmldecl(); ok($xml, ' '); $xml = $x->xmlcdata("test"); ok($xml, ''); $x = new XML::Generator 'pretty' => 2, 'conformance' => 'strict'; $xml = $x->foo($x->bar()); ok($xml, ' '); $xml = $x->foo($x->xmlcdata("bar"), $x->xmlpi("baz")); ok($xml, ''); # test that cdata is not intended when pretty printing is on $xml = $x->foo($x->bam($x->xmlcdata("bar\nbar"))); ok($xml, ' '); $x = new XML::Generator 'conformance' => 'strict'; $xml = $x->foo(42); $xml = $x->xml($xml); ok($xml, ' 42'); eval { $x->xml(); }; ok($@ =~ /usage/, 1); eval { $x->xml(3); }; ok($@ =~ /arguments to xml/, 1); eval { $xml = $x->bar($xml); }; ok($@ =~ /cannot embed/, 1); $x = new XML::Generator 'pretty' => 2; $xml = $x->foo($x->bar($x->baz())); ok($xml, ' '); $xml = $x->foo("\n"); ok($xml, ' '); $x = new XML::Generator 'empty' => 'close'; $xml = $x->foo(); ok($xml, ''); $x = new XML::Generator 'empty' => 'ignore'; $xml = $x->foo(); ok($xml, ''); eval { $x = new XML::Generator 'empty' => 'ignore', 'conformance' => 'strict'; }; ok($@ =~ /not allowed/, 1); $x = new XML::Generator 'conformance' => 'strict'; $xml = $x->foo(); $cmnt = $x->xmlcmnt("comment"); $pi = $x->xmlpi("foo"); $xml = $x->xml($cmnt, $xml, $pi); ok($xml, ' '); $x = new XML::Generator 'empty' => 'compact'; $xml = $x->foo(); ok($xml, ''); $x = new XML::Generator 'empty' => 'args'; $xml = $x->foo(1); ok($xml, '1'); $xml = $x->foo(''); ok($xml, ''); $xml = $x->foo(); ok($xml, ''); $xml = $x->foo(undef); ok($xml, ''); $x = XML::Generator->new(escape => 'always,high-bit'); $xml = $x->foo("<\242>"); ok($xml, '<¢>'); # check :options $x = XML::Generator->new(':standard'); $xml = $x->foo('<', $x->xmlcmnt('c')); ok($xml, '<'); $x = XML::Generator->new(':pretty'); $xml = $x->foo('<', $x->bar($x->xmlcmnt('c'))); ok($xml, '< '); $x = XML::Generator->new(':strict', escape => 'high-bit'); $xml = $x->foo("\\<\242", $x->xmlpi('g')); ok($xml, ''); { my $w; local $SIG{__WARN__} = sub { $w .= $_[0] }; $x = XML::Generator->new(':import'); ok($w =~ /Useless use of/, 1); $w = ''; } # test AUTOLOAD package Test1; use XML::Generator ':import'; ::ok(foo(), ''); package Test2; use XML::Generator ':pretty'; ::ok(foo(bar()), ' '); package Test3; sub AUTOLOAD { return "foo" if our $AUTOLOAD =~ /bar/; return; } use XML::Generator; ::ok(barnyard(), 'foo'); ::ok(foo(), undef); package Test6; sub AUTOLOAD { return "foo" if our $AUTOLOAD =~ /bar/; return; } use XML::Generator qw(:import); ::ok(barnyard(), ''); ::ok(foo(), ''); package Test7; sub AUTOLOAD { return "foo" if our $AUTOLOAD =~ /bar/; return; } use XML::Generator qw(:stacked); ::ok(barnyard(), 'foo'); ::ok(foo(), ''); ::ok(foo(barnyard()), 'foo'); # misc package main; $x = XML::Generator->new(':strict', allowed_xml_tags => ['xmlfoo']); $xml = $x->xmlfoo('biznatch'); ok($xml, 'biznatch'); $xml = $x->xmlcmnt('--'); ok($xml, ''); $A = XML::Generator->new(namespace => ['A']); $B = XML::Generator->new(namespace => ['B' => 'bee']); $xml = $A->foo($B->bar($A->baz())); ok($xml, ''); $xml = $A->foo($A->bar($B->baz())); ok($xml, ''); $xml = $A->foo($B->bar($B->baz())); ok($xml, ''); $C = XML::Generator->new(namespace => [undef]); $xml = $A->foo($C->bar($B->baz())); ok($xml, ''); $D = XML::Generator->new(); $xml = $D->foo(['A'],$D->bar([undef],$D->baz(['B'=>'bee']))); ok($xml, ''); $E = XML::Generator->new(); $xml = $E->foo(['A'],$E->bar([undef],$E->baz(['B'=>'bee'], $E->bum(['A'])))); ok($xml, ''); package MyGenerator; sub AUTOLOAD { my($tag) = our $AUTOLOAD =~ /.*::(.*)/; return '©' if $tag eq 'copy'; return; } use XML::Generator qw(:pretty :stacked); package Test8; MyGenerator->import(); $xml = html(title("My Title",copy())); ::ok($xml, ' My Title© '); package TestDoc1_1; use XML::Generator ':pretty'; $prt = foo(bar({ baz => 3 }, bam()), bar([ 'qux' => 'http://qux.com/' ], "Hey there, world")); ::ok($prt, ' Hey there, world '); package TestDoc1_2; use XML::Generator (); my $X = XML::Generator->new(':pretty'); $prt = $X->foo($X->bar({ baz => 3 }, $X->bam()), $X->bar([ 'qux' => 'http://qux.com/' ], "Hey there, world")); ::ok($prt, ' Hey there, world '); package TestDoc2; use XML::Generator; my $gen = XML::Generator->new(':pretty'); $prt = $gen->person( $gen->name("Bob"), $gen->age(34), $gen->job("Accountant") ); ::ok($prt, ' Bob 34 Accountant '); my $shoe_size = "shoe-size"; $xml = $gen->$shoe_size("12 1/2"); ::ok($xml, '12 1/2'); $xml = $gen->account( $gen->open(['transaction'], 2000), $gen->deposit(['transaction'], { date => '1999.04.03'}, 1500) ); ::ok($xml, ' 2000 1500 '); $xml = $gen->account( $gen->open(['transaction'], 2000), $gen->deposit(['transaction'], { date => '1999.04.03'}, $gen->amount(['transaction'], 1500) ) ); ::ok($xml, ' 2000 1500 '); $xml = $gen->widget(['wru' => 'http://www.widgets-r-us.com/xml/'], {'id' => 123}, $gen->contents()); ::ok($xml, ' '); package TestDoc3; my $html = XML::Generator->new( pretty => 2, namespace => [HTML => "http://www.w3.org/TR/REC-html40"]); $pt = $html->html( $html->body( $html->font({ face => 'Arial' }, "Hello, there"))); ::ok($pt, ' Hello, there '); $html = XML::Generator->new( pretty => 2, namespace => ["http://www.w3.org/TR/REC-html40"]); $pt = $html->html( $html->body( $html->font({ 'face' => 'Arial' }, "Hello, there"))); ::ok($pt, ' Hello, there '); my $a = XML::Generator->new(escape => 'always,high-bit'); $pt = $a->foo("<\242>"); ::ok($pt, '<¢>'); $gen = XML::Generator->new(escape => 'always,apos'); $pt = $gen->foo({'bar' => "It's all good"}); ::ok($pt, ''); $gen = XML::Generator->new(pretty => 2); $pt = $gen->foo($gen->bar('baz'), $gen->qux({ tricky => 'no'}, 'quux')); ::ok($pt, ' baz quux '); $gen = XML::Generator->new(namespace => [foo => "http://foo.com/"], qualifiedAttributes => 1); $pt = $gen->bar({baz => 3}); ::ok($pt, ''); $pt = $gen->bar({'wow:baz' => 3}); ::ok($pt, ''); package TestMult; $gen = XML::Generator->new(namespace => ['foo' => 'foo uri', 'bar' => 'bar uri']); $pt = $gen->baz(); ::ok($pt, ''); $pt = $gen->bam(['#default' => 'default uri']); ::ok($pt, ''); $pt = $gen->bam(['#default' => 'default uri', 'foo' => 'foo uri']); ::ok($pt, ''); $pt = $gen->bam(['foo' => 'foo uri', '#default' => 'default uri']); ::ok($pt, ''); package TestRDF; my @contact = (contact => "http://www.w3.org/2000/10/swap/pim/contact#"); $gen = XML::Generator->new(':pretty'); $pt = $gen->xml( $gen->RDF([ rdf => "http://www.w3.org/1999/02/22-rdf-syntax-ns#", @contact ], $gen->Person(\@contact, { 'rdf:about' => "http://www.w3.org/People/EM/contact#me" }, $gen->fullName(\@contact, 'Eric Miller'), $gen->mailbox(\@contact, {'rdf:resource' => "mailto:em\@w3.org"}), $gen->personalTitle(\@contact, 'Dr.')))); ::ok($pt, ' Eric Miller Dr. '); package TestEscapingEntities; use XML::Generator escape => 'always,even-entities', conformance => 'strict', pretty => 2; ::ok(tag(">"), '&gt;'); package TestInvalidChars1; use XML::Generator filter_invalid_chars => '1'; ::ok(tag(map chr, 0, 0x1, 0x8, 0xB, 0xC, 0xE..0x1F, 0x7F..0x84, 0x86..0x9F), ''); package TestInvalidCharsUnderStrict; use XML::Generator ':strict'; ::ok(tag("\0"), ''); package TestInvalidCharsUnderStrict2; use XML::Generator ':strict', 'filter_invalid_chars' => 0; ::ok(tag("\0"), "\0");