XML-Generator
10 results

 view release on metacpan or  search on metacpan

lib/XML/Generator.pm  view on Meta::CPAN 

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

  <foo>&lt;&#162;&gt;</foo>

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"});

    <foo bar="It&apos;s all good" />

If you actually want & to be converted to &amp; 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

   <foo>
     <bar>baz</bar>
     <qux tricky="no">quux</qux>
   </foo>

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 <tag />  (default)
   compact -  create empty tags as <tag/>
   close   -  close empty tags as <tag></tag>
   ignore  -  don't do anything (non-compliant!)
   args    -  use count of arguments to decide between <x /> and <x></x>

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 <x /> if there are no arguments at all, or if there
is just a single undef argument, and <x></x> 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.

=head2 xml

lib/XML/Generator.pm  view on Meta::CPAN 

  # document can't stand alone.
  my $doctype = $this->xmldtd($this->{xml}{dtd} // $this->{dtd});
  my $standalone;

  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]'");
    }
  }

  $standalone = "no" if $doctype;;
  $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$version$encoding$standalone?>");
  push(@xml, $doctype) if $doctype;
  return join("\n", @xml, "");
}

=head2 xmldtd

DTD <!DOCTYPE> 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:

   <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
        "DTD/xhtml1-transitional.dtd">

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 <!DOCTYPE> thingy
  $dtd ? return(qq{<!DOCTYPE } . (join ' ', @{$dtd}) . q{>})
       : return('');
}

=head2 xmlcdata

Character data section; arguments are concatenated and placed inside
<![CDATA[ ... ]]> character data section delimiters.  Any occurences of
']]>' in the concatenated arguments are converted to ']]&gt;'.

=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 ]]&gt;
  $xml =~ s/]]>/]]&gt;/g;
  XML::Generator::util::filter($xml);
  $xml = "<![CDATA[$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->_allow_xml_cmd;

  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:

lib/XML/Generator.pm  view on Meta::CPAN 

	}
      }
      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) if $escape ;
	  XML::Generator::util::filter($_) if $filter;
	}
      }
    } 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, "</$prefix$tag>");
	} 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, "</$prefix$tag>";
	}
      }
    } 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;

lib/XML/Generator.pm  view on Meta::CPAN 

             '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 <bholzman@earthlink.net>

Original author and maintainer

=item Bron Gondwana <perlcode@brong.net>

First modular version

=item Nathan Wiger <nate@nateware.com>

Modular rewrite to enable subclassing

=back

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

=over 4

=item The XML::Writer module

http://search.cpan.org/search?mode=module&query=XML::Writer

=back

=cut



( run in 0.564 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )