File Coverage

blib/lib/Devel/TraceSAX.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Devel::TraceSAX;

=head1 NAME

Devel::TraceSAX - Trace SAX events

=head1 SYNOPSIS

  ## From the command line:
    perl -d:TraceSAX           script.pl
    perl -d:TraceSAX=-dump_all script.pl

  ## procedural:
    use Devel::TraceSAX;

    trace_SAX $obj1;

  ## Emitting additional messages
    use Devel::TraceSAX qw( emit_trace_SAX_message );

    emit_trace_SAX_message "this is a test";

=head1 DESCRIPTION

B: alpha code alert!!! This module and its API subject to change,
possibly radically :).

Traces SAX events in a program.  Works by applying Devel::TraceCalls to
a tracer on the desired classes for all known SAX event types (according to
XML::SAX::EventMethodMaker and XML::SAX::Machines).

=head2 Emitting messages if and only if Devel::TraceCalls is loaded

    use constant _tracing => defined $Devel::TraceSAX::VERSION;

    BEGIN {
        eval "use Devel::TraceCalls qw( emit_trace_SAX_message )"
            if _tracing;
    }

    emit_trace_SAX_message( "hi!" ) if _tracing;

Using the constant C<_tracing> allows expressions like

    emit_trace_SAX_message(...) if _tracing;

to be optimized away at compile time, resulting in little or no
performance penalty.

=cut

$VERSION=0.021;

@EXPORT = qw( trace_SAX emit_trace_SAX_message );
%EXPORT_TAGS = ( all => \@EXPORT_OK );

## TODO: Can't recall why this class isn't an exporter, need to try that.
@ISA = qw( Devel::TraceCalls );

use strict;
use Devel::TraceCalls qw( trace_calls );
use XML::SAX::EventMethodMaker qw( sax_event_names );
use UNIVERSAL;
use Exporter;

use vars qw( @methods );

sub empty($) { ! defined $_[0] || ! length $_[0] }

## When outputting strings, we usually use this to make invisible
## characters visible and to keep trace messages all on the same line.
## This does not put the quotation marks on the string because lots of
## things like PIs and comments don't use them.  This will yield some
## non-XMLish looking strings, but that's ok, we're going for
## readability for a perl programmer, not w3c compliance.
sub _esc {
    ## Some of these should never occur in XML.  But this isn't
    ## XML, it's SAX events and anything can happen (sometimes event
    ## legitamately, esp. with non XML data sources).
    local $_ = $_[0];
    s/\\/\\\\/g;
    s/\n/\\n/g;
    s/"/"/g;
    s/([\000-\037])/sprintf "&#%02x;", $1/ge;
    return $_;
}


sub _dqify {
    local $_ = $_[0];
    s/\\/\\\\/g;
    $_ = _esc $_;
    return qq{"$_"};
}


@methods = (
    qw(
        new
        set_handler
        set_handlers
        set_aggregator
        start_manifold_document
        end_manifold_document
    ),
    sax_event_names "Handler", "ParseMethods"
);

##
## WARNING: UGLY CODE AHEAD. I'm still debugging this.
##

## Note that we ignore some common words in methods.
my @scan_methods = grep !/set_handler|warning|error|parse/, sort @methods;
my $methods = join "|", map quotemeta, @scan_methods;
$methods = qr/^(?:$methods)(?!\n)$/;

##
## -d:TraceSAX and -MDevel::TraceSAX support
##
my $always_dump;

sub import {
    my $self = shift;

    if ( ! (caller(0))[2] ) {
        require Devel::TraceSAX::DB;
        for ( @_ ) {
            if ( $_ eq "-dump_all" ) {
                $always_dump = 1;
            }
            else {
                warn "Devel::TraceSAX: unknown parameter '$_'\n";
            }
        }
        return;
    }

    my $meth = Exporter->can( "export_to_level" );
    $meth->( __PACKAGE__, 1, @_ );
}


## External API to add a SAX object instance
sub trace_SAX {
    my ( $processor, $id ) = @_;
    trace_calls {
        Objects      => [ $processor ],
        ObjectId     => $id,
        Subs         => \@methods,
        LogFormatter => \&log_formatter,
    };
}


## External API to add a SAX object instance
sub emit_trace_SAX_message {
    goto &Devel::TraceCalls::emit_trace_message;
}


sub log_formatter {
    my ( $tp, $r, $params ) = @_;

#warn Data::Dumper::Dumper( $tp, $r );

    my $short_sub_name = $r->{Name};
    $short_sub_name =~ s/.*://;

    if ( ! $always_dump
        && ( my $meth = __PACKAGE__->can( "format_$short_sub_name" ) )
    ) {
        return $meth->( @_ );
    }
    else {
        return undef;
    }

    return "FOO\n";
}


##
## Parser formatters
##
my %builtin_types = map { ( $_ => undef ) } qw(
    SCALAR
    ARRAY
    Regexp
    REF
    HASH
    CODE
);

sub _stringify_blessed_refs {
    my $s = shift;
    my $type = ref $s;

    return $s if ! $type || $type eq "Regexp" ;

    if ( $type eq "HASH" ) {
        $s = {
            map {
                ( $_  => _stringify_blessed_refs( $s->{$_} ) );
            } keys %$s
        };
    }
    elsif ( $type eq "ARRAY" ) {
        $s = [ map _stringify_blessed_refs( $_ ), @$s ];
    }
    elsif( $type eq "Regexp" ) {
        $s = "$s";
    }
    elsif ( !exists $builtin_types{$type} ) {
        ## A blessed ref...
        $s = $type;
    }

    return $s;
}


sub format_set_handler {
    my ( $tp, $r, $params ) = @_;

    return {
        Args => [
        ],
    };
}


sub format_start_element {
    my ( $tp, $r, $params ) = @_;

    return undef if @$params != 2;
    my $elt = $params->[1];
    return undef if ! defined( $elt ) || ref $elt ne "HASH";

    for ( keys %$elt ) {
        next if $_ eq "Name"
            || $_ eq "LocalName"
            || $_ eq "Prefix"
            || $_ eq "Attributes";
        return undef unless empty $elt->{$_};
    }

    return {
        Args => join( "",
            ": <",
            (
                (
                   defined $elt
                && ref $elt eq "HASH"
                && exists $elt->{Name}
                && defined $elt->{Name}
                )
                    ? ( defined $elt->{Name} ? _esc $elt->{Name} : "???" )
                    : "???"
            ),
            exists $elt->{Attributes} && defined $elt->{Attributes}
                ? map {
                    " " . _esc( $_->{Name} ) . "=" . _dqify $_->{Value} ;
                } values %{$elt->{Attributes}}
                : (),
            ">"
        ),
    };
}


sub format_end_element {
    my ( $tp, $r, $params ) = @_;

    return undef if @$params != 2;
    my $elt = $params->[1];
    return undef if ! defined( $elt ) || ref $elt ne "HASH";

    for ( keys %$elt ) {
        next if $_ eq "Name"
            || $_ eq "LocalName"
            || $_ eq "Prefix"
            || $_ eq "Attributes";
        return undef unless empty $elt->{$_};
    }

    return {
        Args => join( "",
            ":
            (
                (
                   defined $elt
                && ref $elt eq "HASH"
                && exists $elt->{Name}
                && defined $elt->{Name}
                )
                    ? ( defined $elt->{Name} ? _esc $elt->{Name} : "???" )
                    : "???"
            ),
            ">"
        ),
    };
}

sub format_characters {
    my ( $tp, $r, $params ) = @_;

    return undef if @$params != 2;
    my $data = $params->[1];
    return undef if ! defined( $data ) || ref $data ne "HASH";
    return undef if ! exists $data->{Data} || ! defined $data->{Data};


    for ( keys %$data ) {
        next if $_ eq "Data";
        return undef;
    }

    return { Args => ": " . _dqify( $data->{Data} ) . "\n" };
}


sub format_comment {
    my ( $tp, $r, $params ) = @_;

    return undef if @$params != 2;
    my $data = $params->[1];
    return undef if ! defined( $data ) || ref $data ne "HASH";
    return undef if ! exists $data->{Data} || ! defined $data->{Data};

    for ( keys %$data ) {
        next if $_ eq "Data";
        return undef;
    }

    return { Args => ": \n" };
}


sub format_processing_instruction {
    my ( $tp, $r, $params ) = @_;

    return undef if @$params != 2;
    my $data = $params->[1];
    return undef if ! defined( $data ) || ref $data ne "HASH";
    return undef if ! exists $data->{Target} || ! defined $data->{Target};

    for ( keys %$data ) {
        next if $_ eq "Target";
        next if $_ eq "Data";
        return undef;
    }

    my $pi = $data->{Target};
    $pi .= " $data->{Data}"
        if exists $data->{Data} && ! empty $data->{Data};

    return { Args => ": \n" };
}


sub format_parse {
    my ( $tp, $r, $params ) = @_;

    return undef if @$params != 2 || ref $params->[1] ne "HASH" ;

    return {
        Args => [
            $params->[0],
            _stringify_blessed_refs $params->[1],
        ]
    };
}

=head1 TODO

Add a lot more formatting clean-up.

=head1 LIMITATIONS

This module overloads CORE::GLOBAL::require when used from the command
line via -d: or -M.  For some reason this causes spurious warnings like

   Unquoted string "fields" may clash with future reserved word at /usr/local/lib/perl5/5.6.1/base.pm line 87.

That line looks like "require fields;", so it looks like the (*) prototype
on our CORE::GLOBAL::require = sub (*) {...} isn't having it's desired
effect.  It would be nice to clean these up.

=head1 AUTHOR

    Barrie Slaymaker

=head1 LICENSE

You may use this under the terms of either the Artistic License or any
version of the BSD or GPL licenses :).

=cut

1;