XML::LibXSLT registered functions: a preliminary fix

Using the CVS versions of XML::LibXML and XML::LibXSLT, this script 
apparently works as expected:

======================================================
use strict;
use warnings;

use XML::LibXML ();
use XML::LibXSLT ();

my $libxml  = XML::LibXML->new;
my $libxslt = XML::LibXSLT->new;

XML::LibXSLT->register_function( 'urn:bar','func',sub { $_[0] } );

my $dom = $libxml->parse_string( "<empty/>" );

my $xslt = $libxml->parse_string( <<'EOD' );
<xsl:stylesheet version="1.0"
 xmlns:xsl="http://www.w3.org/1999/XSL/Transform";
 xmlns:foo="urn:bar"
 exclude-result-prefixes="foo"
>
<xsl:output omit-xml-declaration="yes"/>
<xsl:template match="/">

<xsl:variable name="foo"><foo type="zoo">bar</foo></xsl:variable>
<xsl:copy-of select="foo:func( $foo )"/>

</xsl:template>
</xsl:stylesheet>
EOD

my $stylesheet = $libxslt->parse_stylesheet( $xslt );

my $newdom = $stylesheet->transform( $dom );

print $stylesheet->output_string( $newdom ); # should print "<foo 
type="zoo">bar</foo>"
======================================================

but when run under valgrind, reveals that Very Bad Things (R) are 
happening (I've removed the not important and repetetive parts from 
this listing):

======================================================
==31755== Using valgrind-2.0.0, a program supervision framework for x86-linux.
==31755== Invalid read of size 4
==31755==    at 0x427789DD: PmmREFCNT_dec (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x4276C8D9: XS_XML__LibXML__Node_DESTROY (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x80B3FF6: Perl_pp_entersub (in 
/usr/local/bin/perl5.8.2-unthreaded)
==31755==    by 0x80616E7: S_call_body (in /usr/local/bin/perl5.8.2-unthreaded)
==31755==    Address 0x41B752F0 is 0 bytes inside a block of size 80 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FC8651: xmlFreeDoc (tree.c:1063)
==31755==    by 0x41FCAA58: xmlFreeNodeList (tree.c:3132)
==31755==    by 0x41FF1C0B: xmlXPathFreeObject (xpath.c:3248)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x4277890C: PmmFreeNode (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x42778A30: PmmREFCNT_dec (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x4276C8D9: XS_XML__LibXML__Node_DESTROY (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x80B3FF6: Perl_pp_entersub (in 
/usr/local/bin/perl5.8.2-unthreaded)
==31755==    Address 0x41B752F4 is 4 bytes inside a block of size 80 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FC8651: xmlFreeDoc (tree.c:1063)
==31755==    by 0x41FCAA58: xmlFreeNodeList (tree.c:3132)
==31755==    by 0x41FF1C0B: xmlXPathFreeObject (xpath.c:3248)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x41FC859C: xmlFreeDoc (tree.c:1037)
==31755==    by 0x42778934: PmmFreeNode (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x42778A30: PmmREFCNT_dec (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x4276C8D9: XS_XML__LibXML__Node_DESTROY (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    Address 0x41B75330 is 64 bytes inside a block of size 80 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FC8651: xmlFreeDoc (tree.c:1063)
==31755==    by 0x41FCAA58: xmlFreeNodeList (tree.c:3132)
==31755==    by 0x41FF1C0B: xmlXPathFreeObject (xpath.c:3248)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x41FCA878: xmlFreeNodeList (tree.c:3123)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    by 0x42778934: PmmFreeNode (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    by 0x42778A30: PmmREFCNT_dec (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    Address 0x41D5C228 is 4 bytes inside a block of size 52 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FCA97F: xmlFreeNodeList (tree.c:3188)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    by 0x41FCAA58: xmlFreeNodeList (tree.c:3132)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x41FCA8BF: xmlFreeNodeList (tree.c:3143)
==31755==    by 0x41FCA8D3: xmlFreeNodeList (tree.c:3145)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    by 0x42778934: PmmFreeNode (in 
/usr/local/lib/perl5/site_perl/5.8.2/i686-linux/auto/XML/LibXML/LibXML.so)
==31755==    Address 0x41D5C354 is 12 bytes inside a block of size 52 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FCA97F: xmlFreeNodeList (tree.c:3188)
==31755==    by 0x41FCA8D3: xmlFreeNodeList (tree.c:3145)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==
==31755== Invalid free() / delete / delete[]
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FCA9FB: xmlFreeNodeList (tree.c:3161)
==31755==    by 0x41FCA8D3: xmlFreeNodeList (tree.c:3145)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    Address 0x41B75454 is 0 bytes inside a block of size 4 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FCA9FB: xmlFreeNodeList (tree.c:3161)
==31755==    by 0x41FCA8D3: xmlFreeNodeList (tree.c:3145)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x41FC9598: xmlFreeProp (tree.c:1878)
==31755==    by 0x41FC955F: xmlFreePropList (tree.c:1853)
==31755==    by 0x41FCAA1B: xmlFreeNodeList (tree.c:3150)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    Address 0x41D5C29C is 20 bytes inside a block of size 44 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FC95E1: xmlFreeProp (tree.c:1886)
==31755==    by 0x41FC955F: xmlFreePropList (tree.c:1853)
==31755==    by 0x41FCAA1B: xmlFreeNodeList (tree.c:3150)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x41FC959F: xmlFreeProp (tree.c:1878)
==31755==    by 0x41FC955F: xmlFreePropList (tree.c:1853)
==31755==    by 0x41FCAA1B: xmlFreeNodeList (tree.c:3150)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    Address 0x41D5C244 is 32 bytes inside a block of size 52 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FCA97F: xmlFreeNodeList (tree.c:3188)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    by 0x41FCAA58: xmlFreeNodeList (tree.c:3132)
==31755==
==31755== Invalid read of size 4
==31755==    at 0x41FC95A6: xmlFreeProp (tree.c:1878)
==31755==    by 0x41FC955F: xmlFreePropList (tree.c:1853)
==31755==    by 0x41FCAA1B: xmlFreeNodeList (tree.c:3150)
==31755==    by 0x41FC86C4: xmlFreeDoc (tree.c:1064)
==31755==    Address 0x41B7531C is 44 bytes inside a block of size 80 free'd
==31755==    at 0x40029961: free (vg_replace_malloc.c:231)
==31755==    by 0x41FC8651: xmlFreeDoc (tree.c:1063)
==31755==    by 0x41FCAA58: xmlFreeNodeList (tree.c:3132)
==31755==    by 0x41FF1C0B: xmlXPathFreeObject (xpath.c:3248)
==31755==
==31755== More than 50 errors detected.  Subsequent errors
==31755== will still be recorded, but in less detail than before.
==31755==
==31755== ERROR SUMMARY: 120 errors from 62 contexts (suppressed: 18 from 1)
==31755== malloc/free: in use at exit: 1216009 bytes in 26074 blocks.
==31755== malloc/free: 46061 allocs, 19998 frees, 13942764 bytes allocated.
==31755== For a detailed leak analysis,  rerun with: --leak-check=yes
==31755== For counts of detected errors, rerun with: -v
======================================================

I've traced this problem to DESTROY being called on the node that is 
passed as a parameter to the function.  Since the node is part of the 
stylesheet, the DESTROY starts deleting parts of the stylesheet when 
it shouldn't.

I figured that this problem can be easily circumvented.  I therefore 
created the following module:

======================================================
package XML::LibXSLT::Functions;

# Set version information
# Make sure we do everything by the book from now on
# And warn for odd things

$VERSION = '0.01';
use strict;
use warnings;

# Get the necessary modules

use Scalar::Util qw(blessed refaddr);

# Hash containing refaddrs of objects that shouldn't be DESTROYed

my %DONTDESTROY;

# At compile time
#  Make sure that the necessary modules are loaded in time

BEGIN {
    require XML::LibXML;
    require XML::LibXSLT;

#  Allow for redefinitions without warnnings

    no warnings 'redefine';

#  Obtain the reference of the registering function
#  Replace it with our own registering function which
#   Obtains the code reference of the function
#   And calls the original registering function with a sub that
#    Checks all the input parameters
#    And calls the originally specified subroutine

    my $register = \&XML::LibXSLT::register_function;
    *XML::LibXSLT::register_function = sub {
        my $coderef = _name2coderef( pop,scalar caller );
        $register->( @_,sub {
            _dontdestroy( @_ );
            goto &$coderef;
        } );
    };

#  Obtain the reference to the DESTROY method
#  Replace it with our own DESTROY method which
#   Calls the original DESTROY if the object was not registered

    my $destroy = \&XML::LibXML::Node::DESTROY;
    *XML::LibXML::Node::DESTROY = sub {
        goto &$destroy unless delete $DONTDESTROY{refaddr $_[0]};
    };
} #BEGIN

# Satisfy -require-

1;

#-------------------------------------------------------------------------
# _dontdestroy
#
# Check all parameters for objects that shouldn't be destroyed
#
#  IN: 1..N parameters to check

sub _dontdestroy {

# For all the parameters passed
#  Reloop if not a blessed object
#  If it inherits from XML::LibXML::Node
#   Mark object as not to be destroyed
#  Elseif it is a nodelist
#   Call ourself with all of the elements

    foreach (@_) {
        next unless blessed $_;
        if ($_->isa( 'XML::LibXML::Node' )) {
            $DONTDESTROY{refaddr $_} = 1;
        } elsif ($_->isa( 'XML::LibXML::NodeList' )) {
            _dontdestroy( @{$_} );
        }
    }
} #_dontdestroy

#-------------------------------------------------------------------------
# _name2coderef
#
# Convert a subroutine name to a code reference.  If it is already a code
# reference, return that.
#
#  IN: 1 subroutine name
#      2 package name to prefix if not fully qualified
# OUT: 1 code reference

sub _name2coderef {

# Return now if it already a code reference (assume a ref is a code ref)

    return $_[0] if ref $_[0];

# Obtain parameters
# Make subroutine name fully qualified
# Return the reference to it

    my ($subname,$package) = @_;
    $subname = $package.'::'.$subname unless $subname =~ m#::#;
    \&{$subname};
} #_name2coderef

#-------------------------------------------------------------------------

__END__

=head1 NAME

XML::LibXSLT::Functions - reliable registered Perl functions in XSLT

=head1 SYNOPSIS

 use XML::LibXML;
 use XML::LibXSLT;
 use XML::LibXSLT::Functions;

=head1 DESCRIPTION

This module acts as a stopgap measure for earlier versions of XML::LibXML
and XML::LibXSLT to fix problems with so-called LibXSLT "registered functions".

=head1 THEORY OF OPERATION

This module steals two subroutines:

=over 2

=item XML::LibXSLT::register_function

This subroutine is replaced by a subroutine that adds a wrapper 
subroutine around the Perl subroutine specified.  This wrapper 
subroutine checks whether any of the parameters are in fact 
XML::LibXML::Node (inherited) objects, and if so, records the address 
of the object.  These objects should B<not> have (the real) DESTROY 
method called on them.

=item XML::LibXML::Node::DESTROY

The object destruction object method for XML::LibXML::Node objects. 
Installed is a wrapper subroutine which checks whether the object is 
registered as being an object that should B<not> be destroyed.  If 
the object is not registered,
then the original DESTROY object method is called.

=back

=head1 AUTHOR

Elizabeth Mattijsen, <liz@xxxxxxxxxx>.

Please report bugs to <perlbugs@xxxxxxxxxx>.

=head1 COPYRIGHT

Copyright (c) 2003 Elizabeth Mattijsen <liz@xxxxxxxxxx>. All rights
reserved.  This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<XML::LibXML>, L<XML::LibXSLT>

=cut
======================================================

This serves my purposes for the time being.  But I wonder whether 
this is the right thing to do.  On the one hand, you would only use 
this module if you're actually using registered functions.  On the 
other hand, I feel this should be in integral part of XML:::LibXML 
and XML::LibXSLT.  But that would mean an overhead to the destruction 
of XML::LibXML::Node objects that is not generally needed.


If the consensus is that this should be built into XML::LibXML::Node 
and XML::LibXSLT, then I'll supply patches to that effect.


Liz
_______________________________________________
Perl-XML mailing list
Perl-XML@xxxxxxxxxxxxxxxxxxxxxxxx
To unsubscribe: http://listserv.ActiveState.com/mailman/mysubs