XML-API

 view release on metacpan or  search on metacpan

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

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {
        attrs    => {},
        contents => [],
        @_
    };

    if ( $self->{comment} ) {
        $self->{comment} =~ s/--/- -/go;
    }

    weaken( $self->{parent} ) if ( exists $self->{parent} );

    bless( $self, $class );
    return $self;
}

sub parent {
    my $self = shift;
    return $self->{parent};
}

sub inline {
    my $self = shift;
    return $self->{inline};
}

sub attrs_as_string {
    my $self = shift;
    my @strings;

    foreach my $key ( sort keys %{ $self->{attrs} } ) {
        my $val = $self->{attrs}->{$key};
        if ( !defined($val) ) {
            warn "Attribute '$key' (element '$self->{element}') is undefined";
            $val = '*undef*';
        }
        push( @strings, $key . '="' . $val . '"' );
    }

    return '' unless (@strings);
    return ' ' . join( ' ', @strings );
}

sub add {
    my $self = shift;
    push( @{ $self->{contents} }, @_ );
}

sub as_string {
    my $self       = shift;
    my $indent     = shift || '';
    my $growindent = shift || '';

    if ( $self->{comment} ) {
        return $indent . '<!-- ' . $self->{comment} . ' -->';
    }

    if ( $self->{cdata} ) {
        return $indent . '<![CDATA[' . $self->{cdata} . ']]>';
    }

    if ( !@{ $self->{contents} } ) {
        return
            $indent . '<'
          . ( $self->{ns} ? $self->{ns} . ':' : '' )
          . $self->{element}
          . $self->attrs_as_string . ' />';
    }

    my $str =
        $indent . '<'
      . ( $self->{ns} ? $self->{ns} . ':' : '' )
      . $self->{element}
      . $self->attrs_as_string . '>';
    my $complex = 0;

    foreach my $c ( @{ $self->{contents} } ) {
        if ( eval { $c->isa(__PACKAGE__) and !$c->inline } ) {
            $complex = 1;
            $str .= "\n" . $c->as_string( $indent . $growindent, $growindent );
        }
        elsif ( eval { $c->isa('XML::API') } ) {    # assume it is complex?
            $str .= "\n"
              . join( "\n",
                map { $_->as_string( $indent . $growindent, $growindent ) }
                  $c->_elements );
        }
        else {
            $str .= $c if ( defined($c) );
        }
    }

    if ($complex) {
        $str .= "\n" . $indent;
    }
    $str .=
      '</' . ( $self->{ns} ? $self->{ns} . ':' : '' ) . $self->{element} . '>';
    return $str;
}

sub fast_string {
    my $self = shift;

    $self->{comment} && return '';
    $self->{cdata}   && return '<![CDATA[' . $self->{cdata} . ']]>';

    return
        '<'
      . ( $self->{ns} ? $self->{ns} . ':' : '' )
      . $self->{element}
      . $self->attrs_as_string . ' />'
      unless @{ $self->{contents} };

    return
        '<'
      . ( $self->{ns} ? $self->{ns} . ':' : '' )
      . $self->{element}
      . $self->attrs_as_string . '>'
      . join(
        '',
        map {
            eval { $_->isa(__PACKAGE__) } ? $_->fast_string
              : (
                eval { $_->isa('XML::API') }
                ? join( '', map { $_->fast_string } $_->_elements )
                : $_
              )
        } @{ $self->{contents} }
      )
      . '</'
      . ( $self->{ns} ? $self->{ns} . ':' : '' )
      . $self->{element} . '>';
}

# Private package (not to be used outside XML::API)
package XML::API::SAXHandler;
use strict;
use warnings;
use base qw(XML::SAX::Base);

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {
        xmlapi => undef,
        @_,
    };
    bless( $self, $class );
    return $self;
}

sub start_element {
    my $self = shift;
    my $hash = shift;
    if ( $hash->{Name} eq '_xml_api_ignore' ) {
        $self->{xml_api_ignore} = 1;
        return;
    }
    $self->{xml_api_ignore} = 0;

    my $attrs = {};
    foreach my $val ( values %{ $hash->{Attributes} } ) {
        $attrs->{ $val->{Name} } = $val->{Value};
    }

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

            $self->_element( $e, $val );
            next;
        }

        my $attr     = {};
        my @contents = ();

        if ( ref($val) and ref($val) eq 'ARRAY' ) {
            my @val = @$val;

            foreach my $i ( 1 .. int( scalar(@val) / 2 ) ) {
                my ( $arg, $arg2 ) = splice( @val, 0, 2 );

                if ( $arg =~ s/^-(.+)/$1/o ) {
                    $attr->{$arg} = $arg2;
                }
                elsif ( ref($arg2) and ref($arg2) eq 'ARRAY' ) {
                    push( @contents, [ $arg, $arg2 ] );
                }
                else {
                    push( @contents, { $arg => $arg2 } );
                }
            }

            push( @contents, @val ) if (@val);
        }
        else {
            push( @contents, $val );
        }
        $self->_open( $e, $attr );

        foreach my $c (@contents) {
            if ( ref($c) and ref($c) eq 'ARRAY' ) {
                $self->_ast(@$c);
            }
            elsif ( ref($c) and ref($c) eq 'HASH' ) {
                my ( $k, $v ) = each %$c;
                $self->_open($k);
                $self->_add($v);
                $self->_close($k);
            }
            else {
                $self->_add($c);
            }
        }

        $self->_close($e);
    }

    return;
}

sub _comment {
    my $self = shift;

    # FIXME: should escape?
    $self->_raw( XML::API::Element->new( comment => join( '', @_ ) ) );
    return;
}

sub _cdata {
    my $self = shift;
    $self->_raw( XML::API::Element->new( cdata => join( '', @_ ) ) );
    return;
}

sub _css {
    my $self    = shift;
    my $content = shift;
    if ( $content =~ /\n/s ) {
        $self->_raw( '/*<![CDATA[*/' . "\n" . $content . '/*]]>*/' );
    }
    else {
        $self->_raw( '/*<![CDATA[*/ ' . $content . ' /*]]>*/' );
    }
    return;
}

sub _javascript {
    my $self = shift;
    $self->script_open( -type => 'text/javascript' );
    $self->_raw( '// -------- JavaScript Begin -------- <![CDATA[' . "\n" );
    $self->_raw(@_);
    $self->_raw('// --------- JavaScript End --------- ]]>');
    $self->script_close;
    return;
}

sub _parse {
    my $self    = shift;
    my $current = $self->{current};

    foreach (@_) {
        next unless ( defined($_) and $_ ne '' );
        local $XML::SAX::ParserPackage = 'XML::LibXML::SAX';
        my $parser =
          XML::SAX::ParserFactory->parser(
            Handler => XML::API::SAXHandler->new( xmlapi => $self ), );

        # remove leading and trailing space, otherwise SAX barfs at us.
        ( my $t = $_ ) =~ s/(^\s+)|(\s+$)//go;

        # escape '&' as well
        $t =~ s/\&(\w+\;)/__AMP__$1/go;

        # escape '&' in urls
        $t =~ s/\&(\w+=)/__AMP__amp;$1/go;
        $parser->parse_string(
            '<_xml_api_ignore>' . $t . '</_xml_api_ignore>' );
    }

    # always make sure that we finish where we started
    $self->{current} = $current;
}

sub _parse_chunk {
    my $self    = shift;
    my $current = $self->{current};

    foreach (@_) {
        next unless ( defined($_) and $_ ne '' );
        local $XML::SAX::ParserPackage = 'XML::LibXML::SAX';
        my $parser =

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

element the same. Returns a reference (private data type) to the new
element which can be used in the _goto function below.

This is effectively the same as the following:

    $x->element_open(-attribute => $value, -attr2=>'val2');
    $x->_add($content);
    $x->element_close;

If $content is not given (or never added with the _add method) for an
element then it will be rendered as empty. Ie, $x->br() produces:

    <br />

=head2 $x->_element('element',...)

The generic implementation of $x->element. Useful if your element names
are not suitable as Perl method calls, or are otherwise funny (eg
starting with '_').

=head2 $x->element_raw('raw content',...)

Adds unescaped content inside an element named 'element'. This is a
shortcut for the case where you find yourself doing the following:

    $x->element_open();
    $x->_raw($content);
    $x->element_close();

=head2 $x->ns__element_open(...)

Same as $x->element_open but prefixed with an XML namespace. Equivalent
to the following.

  $x->_ns('ns');
  $x->element_open(...);
  ...
  $x->element_close;
  $x->_ns(undef);

=head2 $x->ns__element(...)

Same as $x->element but prefixed with an XML namespace. Equivalent to
the following.

  $x->_ns('ns');
  $x->element(...);
  $x->_ns(undef);

=head2 $x->_comment($comment)

Add an XML comment to $x. Is almost the same as this:

    $x->_raw("\n<!--");
    $x->_raw($content);
    $x->_raw('-->')

Except that indentation is correct. Any occurences of '--' in $content
will be replaced with '- -'.

=head2 $x->_cdata($content)

A shortcut for $x->_raw("\n<![CDATA[", $content, " ]]>");

=head2 $x->_css($content )

Adds $content inside a pair of CDATA tags which are encapsulated inside
CSS comments. Similar to:

 $x->_raw('/*<![CDATA[*/ '. $content .' /*]]>*/');

=head2 $x->_javascript($script )

A shortcut for adding $script inside a pair of <script
type="text/javascript"> elements and a _CDATA tag.

=head2 $x->_parse(@content)

Adds content to the current element, but will parse it for xml elements
and add them as method calls. Regardless of $content (missing end tags
etc) the current element will remain the same. Relies on XML::SAX to do
the parsing using the "parse_string" method. In this case XML::SAX
requires that the content is a complete xml document.

=head2 $x->_parse_chunk(@content)

Adds content to the current element, but will parse it for xml elements
and add them as method calls. Regardless of $content (missing end tags
etc) the current element will remain the same. Relies on XML::SAX to do
the parsing, but using the "parse_chunk" method. This method is
suitable for parsing xml fragments which are not necessarily complete.

=head2 $x->_ast(@content)

Sometimes you may want to just build some kind of abstract syntax tree
structure and just feed it to XML::API without having to make all the
method calls yourself. This method lets you do just that.

The following input:

  p => [
      label => 'Body',
      textarea => [
          -rows  => 10,
          -cols  => 50,
          -name  => 'body',
          'the body',
      ],
  ],

results in the following xml:

  <p>
    <label>Body</label>
    <textarea cols="50" name="body" rows="10">the body</textarea>
  </p>


=head2 $x->_attrs( )

Allows you to get/set the attributes of the current element. Accepts