package DBIx::Class::LibXMLdoc;

use warnings;
use strict;
use parent "DBIx::Class";

use XML::LibXML;
use HTML::Entities;
our %Charmap = %HTML::Entities::entity2char;
delete @Charmap{qw( amp lt gt quot apos )};

our $VERSION = '0.03_a';

__PACKAGE__->mk_classdata( '_libXMLdoc_columns' );
__PACKAGE__->mk_classdata("parser_settings" => {
                                                line_numbers => 1
                                               }
                         );

sub libXMLdoc_columns {
    my $self = shift;
    if ( @_ )
    {
        my $class = ref($self) || $self;
        for my $col (@_)
        {
            $self->throw_exception("column $col doesn't exist")
                unless $self->has_column($col);
            $self->throw_exception("column ${col}Doc is a real column")
                if $self->has_column($col."Doc");
            no strict 'refs';
            my $method = "${col}Doc";
            *{"${class}::$method"} = sub { $_[0]->_toDoc($col) };
            __PACKAGE__->mk_classdata("_$method");
        }
        return $self->_libXMLdoc_columns({ map { $_ => 1 } @_ });
    }
    else
    {
        return $self->_libXMLdoc_columns;
    }
}

sub _toDoc : method {
    my $self = shift;
    my $col = shift;
    my $colDoc = "${col}Doc";
    my $_colDoc = "_${col}Doc";

    $self->throw_exception("No such method: $colDoc")
        unless $self->_libXMLdoc_columns->{$col};

    $self->throw_exception("$colDoc is readonly")
        if @_;

    return $self->$_colDoc if $self->$_colDoc # save a parser run if possible
        and not $self->is_changed;

    my $content = $self->$col || "";

    unless ( $self->{_parser} )
    {
        $self->{_parser} = XML::LibXML->new;
        for my $method ( keys %{ $self->parser_settings } )
        {
            my $ok = eval { $self->{_parser}->$method( $self->parser_settings->{$method} ); 1 };

            $self->throw_exception("Error calling method $method on parser with argument $self->parser_settings->{$method}: " . $@ )
                unless $ok;
        }
    }

    my ( $doc, $out );
    eval {
        HTML::Entities::_decode_entities($content, \%Charmap);
        $doc = $self->{_parser}->parse_string
            ("<doc>$content</doc>");
        $doc->setEncoding("utf-8") if $self->can("utf8_columns")
            and $self->utf8_columns->{$col};
        $doc->documentElement->setAttribute("table", $self->table);
        $doc->documentElement->setAttribute("column", $col);
        $doc->documentElement->setAttribute("docversion", $VERSION);
        $self->$_colDoc($doc->documentElement);
    };

    if ( $@ )
    {
        $self->throw_exception("$col data for id " . $self->id . " failed to parse:\n$@");
    }
    return $self->$_colDoc;
}

1;

__END__

=head1 NAME

DBIx::Class::LibXMLdoc - Create an adjunct "Doc" accessor of a column's data which is automatically parsed into a LibXML documentElement (beta-software, dev release).

=head1 VERSION

0.03_a

=head1 SYNOPSIS

 package My::DB::thingy;

 __PACKAGE__->load_components(qw/ PK::Auto LibXMLdoc Core /);

 __PACKAGE__->table('thingy');

 __PACKAGE__->add_columns(qw/ id title body created owner whatever /);
 __PACKAGE__->set_primary_key('id');

 __PACKAGE__->libXMLdoc_columns(qw/ body /);

 package main;
 use My::DB;

 my $schema = My::DB->connect(...);
 my $thingy = $schema->resultset("thingy")->find(153);
 print $thingy->bodyDoc->toString, "\n\n";
 print $thingy->bodyDoc->textContent, "\n";

=head1 DESCRIPTION

This L<DBIx::Class> component does not alter your data in any way. It
takes column names to get the value from the column, parse it into XML
with LibXML and make the documentElement object available via an
autogenerated accessor named by affixing the column with "Doc."

The XML parsing is on demand so it doesn't waste time doing it to data
you don't use or by doing it more than once to data that is unchanged.

A wrapper XML tag for the mini-document is auto-generated from the
table + column name. So-

 my $xhmlt = <<";
<p>
Ain't no doubt Jesus see us<br/>
Acting foolishly on American Bandstand
</p>

 my $thingy = $schema->resultset("thingy")
               ->create({ title => "Gullah",
                          body  => $xhtml });

 my $root = $thingy->bodyDoc;

 print $root->toString, $/;

 # gives us ----------------
 <thingybody><p>
 Ain't no doubt Jesus see us<br/>
 Acting foolishly on American Bandstand
 </p></thingybody>

The returned item, C<$root> above, is the C<doc-E<gt>documentElement> of
a L<XML::LibXML::Document>. It returns the C<documentElement> instead
of the document object itself because the document object is less
frequently/directly useful and in the cases you might want it, e.g. to
modify the document with new nodes, you can still get it with
C<ownerDocument>. E.g.-

 my $doc = $root->ownerDocument;
 my $title = $doc->createElement("h1");
 my $text = $doc->createTextNode($thingy->title);
 $title->appendChild($text);

 $root->insertBefore($title, $root->firstChild);

 print $root->ownerDocument->toString, $/;

 # NOW gives us (spacing added) ------
 <?xml version="1.0" encoding="utf-8"?>
 <doc table="thingy" column="body" version="0.03_a">
 <h1>Gullah</h1>
 <p>
 Ain't no doubt Jesus see us<br/>
 Acting foolishly on American Bandstand
 </p>
 </doc>

The encoding, as utf-8 above, is only set if the UTF8Columns component
is also being used on the column. I believe this means load order
matters. I.e. it should be-

 __PACKAGE__->load_components(qw/ UTF8Columns LibXMLdoc Core /);

When you're using both.

=head1 METHODS

=head2 libXMLdoc_columns

Use C<libXMLdoc_columns> to set the columns you want available. If the columns contain anything which isn't valid XML, an exception will be thrown.

=head2 parser_settings

This is a hash ref of methods and their arugments which are passed to the L<XML::LibXML> parser when it is created.

The only pair passed by default is C<line_numbers> =E<gt> C<1>. Which is added to the parser like so-

  $parser->line_numbers(1)

You can set any C<method> =E<gt> C<argument> pairs you like. See what is possible in the L<XML::LibXML::Parser> docs. Any mistaken method names or illegal arugments will cause an error. It is mostly included so you can do the following if you know your content is junk; since parsing errors throw exceptions.

 __PAKCAGE__->parser_settings({ recover => 1 })

=head1 TO DO

There are basically no live tests right now. This is very bad but since it's been running in produciton without problems I've been slow off the blocks. I'll try to remedy that in the next real release.

=head1 BUGS AND LIMITATIONS

This is no longer brand new and it's been used quite robustly in production since November of 2006. There are no known bugs. I love good feedback and bug reports.

Please report any bugs or feature requests to C<bug-dbix-class-libxmldoc@rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class-LibXMLdoc>.

=head1 SEE ALSO

L<XML::LibXML::Document>, L<XML::LibXML::Node>, L<XML::LibXML::Element>, L<XML::LibXML::Text>, and L<XML::LibXML::Attr>.

L<HTML::Entities> and L<DBIx::Class>.

=head1 AUTHOR

Ashley Pond V C<< <ashley@cpan.org> >>.

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2008, Ashley Pond V C<< <ashley@cpan.org> >>.

This module is free software; you can redistribute it and modify it under the same terms as Perl itself. See L<perlartistic>.

=head1 DISCLAIMER OF WARRANTY

Because this software is licensed free of charge, there is no warranty for the software, to the extent permitted by applicable law. Except when otherwise stated in writing the copyright holders and other parties provide the software "as is" without warranty of any kind, either expressed or implied, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose. The entire risk as to the quality and performance of the software is with you. Should the software prove defective, you assume the cost of all necessary servicing, repair, or correction.

In no event unless required by applicable law or agreed to in writing will any copyright holder, or any other party who may modify or redistribute the software as permitted by the above license, be liable to you for damages, including any general, special, incidental, or consequential damages arising out of the use or inability to use the software (including but not limited to loss of data or data being rendered inaccurate or losses sustained by you or third parties or a failure of the software to operate with any other software), even if such holder or other party has been advised of the possibility of such damages.

=cut
