package DBIx::Class::LibXMLdoc;

use warnings;
use strict;
use base qw/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';

__PACKAGE__->mk_classdata( '_libXMLdoc_columns' );

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);
            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 {
    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 || "\n"; # mabye...?

    my $parser = XML::LibXML->new();
    $parser->line_numbers(1);

    my $wrapper = $self->table . $col;
    $wrapper =~ s/[^[:alpha:]]//g; # namespaces might be better...?
    my ( $doc, $out );
    eval {
        HTML::Entities::_decode_entities($content, \%Charmap);
        $doc = $parser->parse_string
            ("<$wrapper>$content</$wrapper>");
        $doc->setEncoding("utf-8") if $self->can("utf8_columns")
            and $self->utf8_columns->{$col};
        $self->$_colDoc($doc->documentElement);
    };

    if ( $@ )
    {
        $self->throw_exception("$wrapper " . $self->id . " failed to parse:\n$@");
    }
    $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 (alpha-software).

=head1 VERSION

0.03

=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->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"?>
 <thingybody>
 <h1>Gullah</h1>
 <p>
 Ain't no doubt Jesus see us<br/>
 Acting foolishly on American Bandstand
 </p></thingybody>

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 ONLY METHOD

=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.

=head1 BUGS AND LIMITATIONS

This is brand new. I find it very useful for what I'm doing but I know
the code is not as complete or robust as it could be so I would love
feedback and especially test and code contributions. Until the "alpha"
notice is pulled from the description, anything can be changed if
it's a good idea, including the module name.

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>.

=head1 AUTHOR

Ashley Pond V C<< <ashley@cpan.org> >>. Code stubs/flow were taken
from Daisuke Murase's L<DBIx::Class::UTF8Columns>.

=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 LICENCE AND COPYRIGHT

Copyright (c) 2006, Ashley Pond V C<< <ashley@cpan.org> >>. All rights
reserved.

This module is free software; you can redistribute it and/or
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/OR 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 AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, 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
