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.05';
__PACKAGE__->mk_classdata( '_libXMLdoc_columns' );
__PACKAGE__->mk_classdata("libXMLdoc_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->libXMLdoc_parser_settings } )
{
my $ok = eval { $self->{_parser}->$method( $self->libXMLdoc_parser_settings->{$method} ); 1 };
$self->throw_exception("Error calling method $method on parser with argument $self->libXMLdoc_parser_settings->{$method}: " . $@ )
unless $ok;
}
}
my ( $doc, $out );
eval {
HTML::Entities::_decode_entities($content, \%Charmap);
$doc = $self->{_parser}->parse_string
("$content");
$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("version", $VERSION);
$self->$_colDoc($doc->documentElement);
};
if ( $@ )
{
$self->throw_exception($self->ID . "|column=$col:\n$@");
}
return $self->$_colDoc;
}
1;
__END__
=head1 NAME
DBIx::Class::LibXMLdoc - Create an adjunct "[column]Doc" accessor of a column's data which is automatically parsed into a LibXML documentElement (beta-software).
=head1 VERSION
0.05
=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 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 = <<";
Ain't no doubt Jesus see us
Acting foolishly on American Bandstand
my $thingy = $schema->resultset("thingy")
->create({ title => "Gullah",
body => $xhtml });
my $root = $thingy->bodyDoc;
print $root->toString, $/;
# gives us ----------------
Ain't no doubt Jesus see us
Acting foolishly on American Bandstand
The returned item, C<$root> above, is the CdocumentElement> of
a L. It returns the C 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. 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) ------
Gullah
Ain't no doubt Jesus see us
Acting foolishly on American Bandstand
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 to set the columns you want available. If the columns contain anything which isn't valid XML, an exception will be thrown.
=head2 libXMLdoc_parser_settings
This is a hash ref of methods and their arguments which are passed to the L parser when it is created.
The only pair passed by default is C =E C<1>. Which is added to the parser like so-
$parser->line_numbers(1)
You can set any C =E C pairs you like. See what is possible in the L docs. Any mistaken method names or illegal arguments 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.
__PACKAGE__->libXMLdoc_parser_settings({ recover => 1,
recover_silently => 1 });
=head1 TO DO
There are basically no live tests right now. This is very bad but L was tough to get going and I haven't had time to fix it or roll something minimal like it. Since the code's been running in production without problems I've been slow off the blocks. I'll try to remedy that soon.
Allow a switch for parse_html...?
=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, or through the web interface at L.
=head1 SEE ALSO
L, L, L, L, and L.
L and L.
=head1 AUTHOR
Ashley Pond V C<< >>.
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2008, Ashley Pond V C<< >>.
This module is free software; you can redistribute it and modify it under the same terms as Perl itself. See L.
=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