Data::XML::Variant::Build - Data::XML::Variant "build" class.

Data-XML-Variant documentation Contained in the Data-XML-Variant distribution.

Index

Code Index:

NAME

Top

Data::XML::Variant::Build - Data::XML::Variant "build" class.

VERSION

Top

Version 0.01

SYNOPSIS

Top

Do not use this class directly. Data::XML::Variant will return an instance of this class and autogenerate the requested tag methods.

EXPORT

Top

None.

METHODS

Top

New

  my $build = Data::XML::Variant::Build->New;

Returns a new Data::XML::Variant::Build object. Takes no arguments.

Add

 $xml->Add($tag);
 $xml->Add($tag, $method);

This method will create three tag methods for you for the start tag, end tag, and just "tag". For example:

 $xml->Add('foo');
 print $xml->start_foo;      # <foo>
 print $xml->foo('message'); # <foo>message</foo>
 print $xml->end_foo;        # </foo>

The base name of the methods defaults to to tag name, but a second argument will allow you to specify a different method base name name if the tag name is not a legal method name.

For example:

 $xml->Add('foo');
 $xml->Add('florp:bar', 'bar');
 print $xml->start_bar([ id => 3 ]), #attributes to 'bar'
       $xml->foo('message'),
       $xml->end_bar;

 # or
 print $xml->bar( [ id => 3 ], $xml->foo('message') ); # same thing

That should output:

 <florp:bar id="3"><foo>message</foo></florp:bar>

Method names must be legal for Perl and must begin with a lower-case letter. The latter restriction ensures no collision with the pre-existing methods in this class, all of which begin with an upper-case letter.

This method will croak if the method already exists in this class or if you attempt to override a method in UNIVERSAL.

Any arguments passed to the end_$tag method will cause that method to croak.

Note: because this method adds new methods directly into this namespace, all instances of this object will have access to the same methods. See the Remove and Methods methods to see how to manage them. This may change in the future.

See ATTRIBUTES for information about how attributes are handled.

Encode

  $xml->Encode($sub_ref);

Don't like how the XML is encoded? Supply a subref which handles the encoding for you. The first argument to the subref will be the Data::XML::Variant::Build object and the second argument will be the string to be encoded. For example, to eliminate all encoding:

 $xml->Encode(sub {
    my ($self, $string) = @_;
    return $string;
 });

By default, data is encoded with HTML::Entities::encode_entities with no arguments other than the data string.

Closing

  my $closing = $xml->Closing;
  $xml->Closing(' /');

This getter/setter determines how self-closing tags terminate. Generally there should not be a space prior to the trailing slash:

 print $xml->foo; # <foo/>

Some XML/HTML parsers do not like this and require a space before the trailing slash. Use this method to provide this (or any other closing).

 $xml->Closing(' /');
 print $xml->foo; # <foo />

Quote

  my $quote = $xml->Quote;
  $xml->Quote("'"); # use single quotes

Getter/setter for attribute quote character

Methods

  my @methods = $xml->Methods;

Returns a list of tag methods which have been added.

Remove

  $xml->Remove('foo'); # remove the foo tag methods
  $xml->Remove;        # remove all tag methods

This method allows you to remove undesired methods from Data::XML::Build namespace. Specifying a tag name will remove the corresponding start, end, and tag methods. Calling without arguments will remove all methods.

Warns if the tag name is not found.

Return true on success.

Cdata

  my $Cdata = $xml->Cdata($string);

Returns a CDATA section for XML. Does not escape data.

Raw

  print $xml->some_tag($xml->Raw($string));

This method allows you to insert raw, unescaped data into your output.

Use with caution.

Decl

  print $xml->Decl;
  # <?xml version="1.0"?>
  print $xml->Decl([version => '1.0', encoding => "utf-8", standalone => "yes");

This method returns an XML declaration with a version of '1.0'. If you desire additional attributes, you may specify an attribute list. version must be explicitly specified if you have attributes.

PI

  $xml->PI( 
    'xml-stylesheet', 
    [ type => 'text/xsl', href => 'http://www.example.com' ] 
  );
  # <?xml-stylesheet type="text/xsl" href="http://www.example.com"?>

Returns a process instruction.

Comment

  $xml->Comment('this is a > comment');
  # <!-- this is a &gt; comment -->

Returns an XML comment. Comment is padded with one space before and after the $comment string.

ATTRIBUTES

Top

Attribute handling is an annoying problem. Many tools require XML attributes to appear in a particular order even though this is not required. We handle this by allowing you to specify attributes in three different ways.

Array references

This is the preferred method. Pass an array reference for attributes and the attributes will be added in the correct order:

 print $xml->foo( [ id => 2, class => 'none' ] );
 # <foo id="2" class="none"/>
Hash references

This is the traditional method. Pass a hash reference for attributes and the attributes will be added, but the order is not guaranteed:

 print $xml->foo( { id => 2, class => 'none' } );
 # <foo id="2" class="none"/>
 # <foo class="none" id="2"/>
Scalar references

If you are forced to work with an XML variant which has unusual attribute requirements, you may pass a scalar reference and the attributes will be added to the tag exactly as you have passed them (but there will still be a space after the tag name):

 my $attributes = "id=2 selected";
 print $xml->foo( \$attributes );
 # <foo id=2 selected/>

NEWLINES

Top

Many people don't like their XML running on the same line. Because the goal of this module is to give you fine-grained control over how you need to produce your XML variant, it will not attempt to second guess where you want newlines. You will have to insert them yourself.

Here's an example. Note how the individual method calls are joined on newlines but method calls inside other method calls have newlines inserted between them.

 my $xml = Data::XML::Variant->new(
     {
         'ns:foo'  => 'foo',
         'bar'     => 'bar',
         'ns2:baz' => 'baz',
     }
 );
 my $xslt_url = 'http://www.example.com/xslt/';
 my $url      = 'http://www.example.com/url/';

 print join "\n" => $xml->Decl, # joining outer elements in \n 
   $xml->PI( 'xml-stylesheet', [ type => 'text/xsl', href => "$xslt_url" ] ),
   $xml->foo(
     [ id => 3, 'xmlns:ns2' => $url ],                      "\n",
     $xml->bar('silly'),                                    "\n",
     $xml->Comment('this is a > comment'),                  "\n",
     $xml->baz( [ 'asdf:some_attr' => 'value' ], 'whee!' ), "\n"
   );

That will print the following:

 <?xml version="1.0"?>
 <?xml-stylesheet type="text/xsl" href="$xslt_url"?>
 <ns:foo id="3" xmlns:ns2="$url">
 <bar>silly</bar>
 <!-- this is a &gt; comment -->
 <ns2:baz asdf:some_attr="value">whee!</ns2:baz>
 </ns:foo>

Yes, there are an unbound prefixes in that example. This was deliberate.

AUTHOR

Top

Curtis "Ovid" Poe, <ovid@cpan.org>

BUGS

Top

Please report any bugs or feature requests to bug-data-xml-variant@rt.cpan.org, or through the web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Data-XML-Variant. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

COPYRIGHT & LICENSE

Top

Copyright 2005 Curtis "Ovid" Poe, all rights reserved.

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

Data-XML-Variant documentation Contained in the Data-XML-Variant distribution. 
package Data::XML::Variant::Build;

use warnings;
use strict;
use HTML::Entities ();
use aliased 'Data::XML::Variant::Output';

# cache for all tag methods added
my %METHOD_CACHE;


our $VERSION = '0.01';


##############################################################################


sub New { bless {}, shift }

##############################################################################


sub Add {
    my ( $self, $tag, $method_name ) = @_;
    $method_name ||= $tag;
    if ( UNIVERSAL->can($method_name) ) {
        $self->_croak('Cannot override UNIVERSAL methods');
    }
    unless ( $method_name =~ /^[[:lower:]]/ ) {
        $self->_croak(
            "Added methods must begin with a lower-case letter ($method_name)");
    }
    if ( $self->can($method_name) ) {
        $self->_croak("Method ($method_name) already added");
    }

    no strict 'refs';
    my ( $start, $method, $end ) = $self->_tag_methods($method_name);
    $METHOD_CACHE{$method} = 1;
    *$start = sub {
        my ( $self, $attributes ) = @_;
        if ( $attributes && !$self->_has_attributes($attributes) ) {
            $self->_croak(
                "Argument to start_$method must be an array ref or hash ref");
        }
        my $result = "<$tag";
        if ($attributes) {
            $result .= $self->_attributes($attributes);
        }
        $result .= ">";
        return Output->new($result);
    };

    *$method = sub {
        my ( $self, @data ) = @_;
        my $result;
        $result =
          $self->_has_attributes( $data[0] )
          ? $self->$start( shift @data )
          : $self->$start;
        unless (@data) {
            my $closing = $self->Closing;
            $result =~ s{>$}{$closing>};
            return Output->new($result);
        }

        foreach my $data (@data) {
            $result .=
              Output eq ref $data ? $data->output : $self->_encode($data);
        }
        $result .= $self->$end;
        return Output->new($result);
    };

    *$end = sub {
        my $self = shift;
        if (@_) {
            $self->_croak("end_$method does not take any arguments");
        }
        my $result = "</$tag>";
        return Output->new($result);
    };
}


sub Encode {
    my ( $self, $sub ) = shift;
    unless ( 'CODE' eq ref $sub ) {
        $self->_croak("Argument to Encode() must be a subroutine reference.");
    }
    *_encode = $sub;
}

sub _encode {
    my $self = shift;
    HTML::Entities::encode_entities(shift);
}

sub _croak {
    my ( $self, @error ) = @_;
    require Carp;
    Carp::croak(@error);
}

##############################################################################


sub Closing {
    my $self = shift;
    return $self->{closing} || '/' unless @_;
    $self->{closing} = shift;
    return $self;
}

##############################################################################


sub Quote {
    my $self = shift;
    return $self->{quote} || '"' unless @_;
    $self->{quote} = shift;
    return $self;
}

##############################################################################


sub Methods {
    my $self = shift;

    return map { $self->_tag_methods($_) }
      sort keys %METHOD_CACHE;
}

##############################################################################


sub Remove {
    my ( $self, $tag ) = @_;
    my @remove;
    if ( defined $tag ) {
        unless (exists $METHOD_CACHE{$tag}) {
            require Carp;
            Carp::carp("Tried to remove unknown tag ($tag)");
            return;
        }
        @remove = $tag;
    }
    else {
        @remove = keys %METHOD_CACHE;
    }
    foreach my $remove (@remove) {
        foreach my $method ($self->_tag_methods($remove)) {
            no strict 'refs';

            # we need to wipe out the entire glob because "undef &$method"
            # will result in a weird "Not a CODE reference" error if the
            # method is later called because the other glob slots will still
            # exist.  This is arguably a bug in Perl.
            undef *$method; 
            delete $METHOD_CACHE{$method};
        }
    }
    return 1;
}

##############################################################################


sub Cdata {
    my ( $self, $data ) = @_;

    # need to deal with the END marker
    return Output->new( '<![CDATA[' . $data . ']]>' );
}

##############################################################################


sub Raw {
    my ( $self, $string ) = @_;
    return Output->new($string);
}

##############################################################################


sub Decl {
    my ( $self, $attributes ) = @_;
    if ( defined $attributes && !$self->_has_attributes($attributes) ) {
        $self->_croak('You must supply valid attributes to Decl()');
    }
    $attributes ||= [ version => '1.0' ];
    return Output->new( '<?xml' . $self->_attributes($attributes) . '?>' );
}

##############################################################################


sub PI {
    my ( $self, $pi, $attributes ) = @_;
    if ( defined $attributes && !$self->_has_attributes($attributes) ) {
        $self->_croak('You must supply valid attributes to Decl()');
    }
    return Output->new( "<?$pi" . $self->_attributes($attributes) . '?>' );
}

##############################################################################


sub Comment {
    my ($self, $comment) = @_;
    return Output->new('<!-- '.$self->_encode($comment).' -->');
}

sub _has_attributes {
    my ( $self, $data ) = @_;
    return unless defined $data && ref $data;

    # we're reaching into UNIVERSAL because they data may be a string,
    # a normal reference or a blessed reference
    return !UNIVERSAL::isa( $data, Output )
      && ( UNIVERSAL::isa( $data, 'ARRAY' )
        || UNIVERSAL::isa( $data, 'HASH' )
        || UNIVERSAL::isa( $data, 'SCALAR' ) );
}

sub _attributes {
    my ( $self, $attrs ) = @_;
    return '' unless $attrs;
    if ( ref $attrs && UNIVERSAL::isa( $attrs, 'SCALAR' ) ) {
        return ' ' . $$attrs;
    }
    my @attributes = UNIVERSAL::isa( $attrs, 'HASH' ) ? %$attrs : @$attrs;
    return '' unless @attributes;
    my $result = '';
    my $quote  = $self->Quote;
    for ( my $i = 0 ; $i < @attributes ; $i += 2 ) {
        my ( $attr, $value ) = @attributes[ $i, $i + 1 ];
        $value = $self->_encode($value);
        $result .= qq{ $attr=$quote$value$quote};
    }
    return $result;
}

sub _tag_methods {
    my ( $self, $tag ) = @_;
    return ( "start_$tag", $tag, "end_$tag" );
}


1;