File Coverage

blib/lib/RDF/Sesame/TableResult.pm

Criterion	Covered	Total	%
statement	12	136	8.8
branch	0	74	0.0
condition			n/a
subroutine	4	11	36.3
pod	5	5	100.0
total	21	226	9.2

package RDF::Sesame::TableResult;

use strict;
use warnings;

use base qw( Data::Table );

use Carp;

our $VERSION = '0.17';

#
# The $response parameter is an RDF::Sesame::Response object.
#
# This method is only intended to be called from RDF::Sesame::Repository
#
sub new {
    my ($class, $r, %opts) = @_;

    # set our 'strip_' values
    my $strip_literals = 0;
    my $strip_uris     = 0;
    $strip_literals = $opts{strip} =~ /^literals|all$/;
    $strip_uris     = $opts{strip} =~ /^urirefs|all$/;

    my ( $content, $parser )
        = $r->is_xml()            ? ( $r->parsed_xml(), \&_parse_xml )
        : $r->is_binary_results() ? ( $r->content(),    \&_parse_bin )
        :                           croak "TableResults: Bad response format"
        ;
    my ($column_names, $tuples) = $parser->(
        $content,
        $strip_literals,
        $strip_uris,
    );

    my $self = $class->SUPER::new($tuples, $column_names, 0);
    $self->{coming} = 0;  # the number of the next row for each()

    # rebless ourselves and return
    return bless $self, $class;
}

# Converts the binary RDF table results format from Sesame into an array of
# arrays with column names.  The binary results format is described at
# http://www.openrdf.org/doc/sesame/api/org/openrdf/sesame/query/BinaryTableResultConstants.html
sub _parse_bin {
    my ($bin, $strip_literals, $strip_uris) = @_;

    # validate the header
    my ( $magic, $version, $column_count ) = unpack( 'A4 N N', $bin );
    die "Not an Binary RDF Table Result" if $magic ne 'BRTR';
    die "Version $version is higher than 1" if $version > 1;
    substr( $bin, 0, 12, q{} );

    # collect the column names
    my @column_names;
    for ( 1 .. $column_count ) {
        my ( $byte_count, $column_name ) = unpack( 'n X2 n/A*', $bin );
        substr( $bin, 0, 2 + $byte_count, q{} );
        push @column_names, $column_name;
    }

    # parse the results table from the binary representation
    my @row;
    my @rows;
    my $prev_row;
    my @namespaces;
    ROW:
    while (1) {
        my $column_value;
        my $column_i = 0;
        @row = ();

        COLUMN:
        while ( $column_i < $column_count ) {
            my ($record_type) = unpack( 'c', $bin );
            substr( $bin, 0, 1, q{} );

            if ( $record_type == 0 ) {       # NULL
                $column_value = undef;
            }
            elsif ( $record_type == 1 ) {    # REPEAT
                $column_value = $prev_row->[$column_i];
            }
            elsif ( $record_type == 2 ) {    # NAMESPACE
                my ( $ns_id, $ns_len, $ns ) = unpack( 'N n X2 n/A*', $bin );
                substr( $bin, 0, 6 + $ns_len, q{} );
                $namespaces[$ns_id] = $ns;
                redo COLUMN;
            }
            elsif ( $record_type == 3 ) {    # QNAME
                my ( $ns_id, $local_len, $local )
                    = unpack( 'N n X2 n/A*', $bin );
                substr( $bin, 0, 6 + $local_len, q{} );
                my $ns = $namespaces[$ns_id];
                $column_value = $strip_uris ? "$ns$local" : "<$ns$local>";
            }
            elsif ( $record_type == 4 ) {    # URI
                my ( $uri_len, $uri ) = unpack( 'n X2 n/A*', $bin );
                substr( $bin, 0, 2 + $uri_len, q{} );
                $column_value = $strip_uris ? $uri : "<$uri>";
            }
            elsif ( $record_type == 5 ) {    # BNODE
                my ( $bnode_len, $bnode ) = unpack( 'n X2 n/A*', $bin );
                substr( $bin, 0, 2 + $bnode_len, q{} );
                $column_value = "_:$bnode";
            }
            elsif ( $record_type == 6 ) {    # PLAIN LITERAL
                my ( $lit_len, $lit ) = unpack( 'n X2 n/A*', $bin );
                substr( $bin, 0, 2 + $lit_len, q{} );
                $column_value = $strip_literals ? $lit : qq{"$lit"};
            }
            elsif ( $record_type == 7 ) {    # LANG LITERAL
                my ( $lit_len, $lit, $lang_len, $lang )
                    = unpack( 'n X2 n/A* n X2 n/A*', $bin );
                substr( $bin, 0, 4 + $lit_len + $lang_len, q{} );
                $column_value = $strip_literals ? $lit : qq{"$lit"\@$lang};
            }
            elsif ( $record_type == 8 ) {    # DATATYPE LITERAL
                my ( $lit_len, $lit, $record_type )
                    = unpack( 'n X2 n/A* c', $bin );
                substr( $bin, 0, 3 + $lit_len, q{} );

                my $datatype;
                if ( $record_type == 3 ) {    # embedded QNAME
                    my ( $ns_id, $local_len, $local )
                        = unpack( 'N n X2 n/A*', $bin );
                    substr( $bin, 0, 6 + $local_len, q{} );
                    my $ns = $namespaces[$ns_id];
                    $datatype = $ns . $local;
                }
                elsif ( $record_type == 4 ) {    # embedded URI
                    my ( $uri_len, $uri ) = unpack( 'n X2 n/A*', $bin );
                    substr( $bin, 0, 2 + $uri_len, q{} );
                    $datatype = $uri;
                }
                else {
                    die "Bad record type $record_type after typed literal";
                }

                $column_value = $strip_literals ? $lit : qq{"$lit"^^<$datatype>};
            }
            elsif ( $record_type == 126 ) {   # ERROR
                my ( $error_type, $error_len, $error )
                    = unpack( 'c n X2 n/A*', $bin );
                substr( $bin, 0, 3 + $error_len, q{} );
                die "$error_type: $error";
            }
            elsif ( $record_type == 127 ) {   # END OF RESULTS
                last ROW;
            }
            else {
                die "Unknown record type: $record_type";
            }
        }
        continue {
            push @row, $column_value;
            $column_i++;
        }

    }
    continue {
        my $row_copy = [ @row ];
        push @rows, $row_copy;
        $prev_row = $row_copy;
    }

    push @rows, \@row if @row;

    return ( \@column_names, \@rows );
}

# Converts the XML parse tree from RDF::Sesame::Response into
# an array of arrays with column names
sub _parse_xml {
    my ( $parsed_xml, $strip_literals, $strip_uris ) = @_;

    # make a copy of the header info for ourselves
    my @head = @{ $parsed_xml->{header}{columnName} };

    # convert the tuples into our internal representation
    my @tuples;
    foreach my $t ( @{ $parsed_xml->{tuple} } ) {
        my @row = ();
        foreach my $a ( @{ $t->{attribute} } ) {
            my $content = $a->{content};

            # encode each type according to N-Triples syntax
            if( $a->{type} eq 'bNode' ) {
                push(@row, "_:$content");
            } elsif( $a->{type} eq 'uri' ) {
                if( $strip_uris ) {
                    push(@row, $content);
                } else {
                    push(@row, "<$content>");
                }
            } elsif( $a->{type} eq 'literal' ) {
                if( $strip_literals ) {
                    push(@row, $content);
                } elsif( $a->{'xml:lang'} ) {
                    push(@row, "\"$content\"\@" . $a->{'xml:lang'} );
                } elsif( $a->{datatype} ) {
                    push(@row, "\"$content\"^^<" . $a->{datatype} . ">" );
                } else {
                    push(@row, "\"$content\"" );
                }
            } else {
                # type must be 'null'
                push(@row, undef);
            }
        }

        push(@tuples, \@row);
    }

    return ( \@head, \@tuples );
}

sub has_rows {
    my $self = shift;

    return $self->nofRow > 0;
}

sub sort {
    my ($self, @ps) = @_;

    my $i = 1;
    while( $i < $#_ ) {

        # munge the type parameter
        if( defined $ps[$i] ) {
            if( $ps[$i] eq 'numeric' ) {
                $ps[$i] = 0;
            } elsif( $ps[$i] eq 'non-numeric' ) {
                $ps[$i] = 1;
            }
        }

        $i++;

        # munge the order parameter
        if( defined $ps[$i] ) {
            if( $ps[$i] eq 'asc' ) {
                $ps[$i] = 0;
            } elsif( $ps[$i] eq 'desc' ) {
                $ps[$i] = 1;
            }
        }

        $i += 2;  # skip the next colID parameter
    }

    $self->SUPER::sort(@ps);
}

sub each {
    my ($self) = @_;

    # have we passed the last row?
    if( $self->{coming} >= $self->nofRow ) {
        $self->{coming} = 0;
        return ();
    }

    # nope, so return the current row and increment our pointer
    return @{ $self->rowRef($self->{coming}++) };
}

sub reset {
    $_[0]->{coming} = 0;
}


1;

__END__