serializer.pm

一个论文管理系统

	$self->_print ("<rdf:Description$idAboutAttr>\n");
    }
    $self->{_recursionlvl}++;
    $description->[1] = 1;
}
sub _descriptionOpen_old {
    my ($self,$description) = @_;
    my $subjectID = $description->[0]->getURI;
    my $idAboutAttr;
    #Anonymous subject can be serialized as anonymous if it's an object of one or zero statements
    #and the referencing statement's subject has already been opened
    my $InlineURI = "_:";
    my $baseURI = $self->getOptions->{BaseURI};
    if ($subjectID =~ /^$InlineURI/i) {
	my $cnt = $self->countStatements(undef,undef,$description->[0]);
	if (!$cnt || ($self->{_recursionlvl} && $cnt < 2)){
	    $idAboutAttr = '';
	} else {
	    #deanonymize resource
	    my $idNew = $self->getOptions->{InlinePrefix}.$self->{idAttr}++;
	    $idAboutAttr = " ID=\"$idNew\"";
	    carp "Giving attribute $idAboutAttr to blank node $subjectID.";
	    #store its ID to reference it in other statements
	    $self->{_anonym}->{$subjectID} = '#'.$idNew;
	}
    } elsif ($baseURI && $subjectID =~ /^$baseURI/i) {
	#relative URI - choose whether idAttr or aboutAttr should be produced
	#suggestion - produce aboutAttr every time
	#TODO-synchronize this with isuue rdfms-difference-between-ID-and-about
	my $id = $';   #' (close quote for dumb editors)
#	$id =~ s/^#//
#	  if $baseURI !~ /#$/;
	$idAboutAttr = " rdf:about=\"$'\"";
    } else {
	#absolute URI - produce aboutAttr
	$idAboutAttr = " rdf:about=\"$subjectID\"";
    }
    $self->_print ("<rdf:Description$idAboutAttr>\n");
    $self->{_recursionlvl}++;
    $description->[1] = 1;
}
sub _descriptionClose {
    my ($self,$description) = @_;
    $self->{_recursionlvl}--;
    my $subjectTYPE;
    eval {
	my $subjectTYPE_enum = $self->getStatements($description->[0],new RDF::Core::Resource(+RDF_NS.'type'),undef) or die 'cannot find subject type (no enum)';
	my $subjectTYPE_enum_first = $subjectTYPE_enum->getFirst or die 'cannot find subject type (no first)';
	$subjectTYPE = $subjectTYPE_enum_first->getObject or die 'cannot find subject type (no object)';
    };
    # subjectTYPE will be, for example: http://purl.org/rss/1.0/item
    $self->_printindent;
    if ($subjectTYPE) {
	$self->_print('</'.$self->_tag($subjectTYPE->getNamespace,$subjectTYPE->getLocalValue).">\n");
    }
    else {
	$self->_print ("</rdf:Description>\n");
    }
    $description->[2] = 1;
}

sub _descriptionClose_old {
    my ($self,$description) = @_;
    $self->{_recursionlvl}--;
    $self->_print ("</rdf:Description>\n");
    $description->[2] = 1;
}
sub _predicateOpen {
    my ($self,$statement,$inline) = @_; #inline says that nested resource should be scripted inline, not referenced
    my $propName = $self->_tag($statement->getPredicate->getNamespace, $statement->getPredicate->getLocalValue);
    return if ($propName eq 'rdf:type' and $self->{'_notype'}->{$statement->getSubject->getURI});
    #return if $propName eq 'rdf:type' and $statement->getObject->getLocalValue =~ /^(channel|item)$/;
    if ($propName =~ /^rdf:_\d+$/) {
	if (my $rdfSeq = $statement->getSubject) {
	    if (my $enumerator = $self->getStatements(undef,undef,$rdfSeq)) {
		if (my $stmt = $enumerator->getFirst) {
		    if ($stmt->getPredicate->getLocalValue eq 'items') {
			$propName = 'rdf:li';
		    }
		}
	    }
	}
    }
    #$propName =~ s/^rdf:_\d+$/rdf:li/;  # convert _# to li
    my $propertyElt;
    if ($statement->getObject->isLiteral) {
	#don't express xml:lang if not necessary
	my $lang = $statement->getObject->getLang ? 
	  " xml:lang=\"".($statement->getObject->getLang)."\"" : "";
	my $datatype = $statement->getObject->getDatatype ? 
	  " rdf:datatype=\"".$statement->getObject->getDatatype."\"" : "";
	$propertyElt="<${propName}${lang}${datatype}>";
    } else {
	if ($inline) {
	    $propertyElt="<$propName>\n";
	} else {
	    my $objectURI = $statement->getObject->getURI;
	    $objectURI = $self->{_anonym}->{$objectURI}
	      if exists  $self->{_anonym}->{$objectURI};
	    push @{$self->{_resources}}, [$statement->getSubject->getURI, $objectURI];
	    $objectURI =~ s/&/&amp;/g;
	    $propertyElt="<$propName rdf:resource=\"".$self->_cutBaseURI($objectURI)."\"/>\n";
	}
    }
    $self->_printindent;
    $self->_print ($propertyElt);
}
sub _predicateOpen_old {
    my ($self,$statement,$inline) = @_; #inline says that nested resource should be scripted inline, not referenced
    my $prefix = $self->{_namespaces}->{$statement->getPredicate->getNamespace};
    my $propName = $prefix . ":".$statement->getPredicate->getLocalValue;
    my $propertyElt;
    if ($statement->getObject->isLiteral) {
	#don't express xml:lang if not necessary
	my $lang = $statement->getObject->getLang ? 
	  " xml:lang=\"".($statement->getObject->getLang)."\"" : "";
	my $datatype = $statement->getObject->getDatatype ? 
	  " rdf:datatype=\"".$statement->getObject->getDatatype."\"" : "";
	$propertyElt="<${propName}${lang}${datatype}>";
    } else {
	if ($inline) {
	    $propertyElt="<$propName>\n";
	} else {
	    my $objectURI = $statement->getObject->getURI;
	    $objectURI = $self->{_anonym}->{$objectURI}
	      if exists  $self->{_anonym}->{$objectURI};
	    $propertyElt="<$propName rdf:resource=\"".$self->_cutBaseURI($objectURI)."\"/>\n";
	}
    }
    $self->_print ($propertyElt);
}
sub _predicateClose {
    my ($self,$statement,$inline) = @_;
    my $propName = $self->_tag($statement->getPredicate->getNamespace, $statement->getPredicate->getLocalValue);
    my $propertyElt;
    if ($inline || $statement->getObject->isLiteral) {
	$propertyElt="</$propName>\n";
    } else {
	$propertyElt="";
    }
    $self->_printindent if $inline;
    $self->_print ($propertyElt);
}
sub _predicateClose_old {
    my ($self,$statement,$inline) = @_;
    my $prefix = $self->{_namespaces}->{$statement->getPredicate->getNamespace};
    my $propName = $prefix . ":".$statement->getPredicate->getLocalValue;
    my $propertyElt;
    if ($inline || $statement->getObject->isLiteral) {
	$propertyElt="</$propName>\n";
    } else {
	$propertyElt="";
    }
    $self->_print ($propertyElt);
}
sub _descriptionData {
    my ($self,$statement) = @_;
    my $RDF_NS = +RDF_NS;
    if (!$statement->getObject->isLiteral && #object is resource
	defined $self->getSubjects->{$statement->getObject->getURI} && #and statement about the resource exists
	!$self->getSubjects->{$statement->getObject->getURI}->[1] &&
	!grep($statement->getPredicate->getURI eq $_, map('http://purl.org/rss/1.0/'.$_, ('item', 'image', 'textinput'))) &&
	$statement->getPredicate->getURI !~ /^$RDF_NS(_\d+|li)$/
	) { #and is opened not yet
        $self->_predicateOpen($statement,1);
	$self->_descriptionProcess($self->getSubjects->{$statement->getObject->getURI});
	$self->_predicateClose($statement,1);
    } else {
	$self->_predicateOpen($statement,0);
	if ($statement->getObject->isLiteral) {
	    my $literal = $statement->getObject->getValue;
	    $literal =~ s/\&/\&amp;/g;
	    $literal =~ s/([^[:ascii:]])/sprintf('&#x%X;', ord($1))/ge;
	    $literal =~ s/\</\&lt;/g;
	    $literal =~ s/\>/\&gt;/g;
	    $self->_print($literal);
	}
	$self->_predicateClose($statement,0);

    }
}
sub _descriptionData_old {
    my ($self,$statement) = @_;
    if (!$statement->getObject->isLiteral && #object is resource
	defined $self->getSubjects->{$statement->getObject->getURI} && #and statement about the resource exists
	!$self->getSubjects->{$statement->getObject->getURI}->[1]) { #and is opened not yet
        $self->_predicateOpen($statement,1);
	$self->_descriptionProcess($self->getSubjects->{$statement->getObject->getURI});
	$self->_predicateClose($statement,1);
    } else {
	$self->_predicateOpen($statement,0);
	if ($statement->getObject->isLiteral) {
	    my $literal = $statement->getObject->getValue;
	    $literal =~ s/\&/\&amp;/g;
	    $literal =~ s/\</\&lt;/g;
	    $self->_print($literal);
	}
	$self->_predicateClose($statement,0);

    }
}
sub _printindent {
  my ($self) = @_;
  $self->_print('  ' x $self->{_recursionlvl});
}
sub _print {
    my ($self,@params) = @_;
    if (ref($self->{_options}->{Output}) eq 'SCALAR') {
	${$self->getOptions->{Output}} .= join('', @params);
    } elsif (ref($self->{_options}->{Output}) =~ /^GLOB|^FileHandle/) {
	print {$self->getOptions->{Output}} @params;
    }

}
sub _outputdone {
    my ($self) = @_;
    # repack as Unicode
    if (ref($self->{_options}->{Output}) eq 'SCALAR') {
	${$self->getOptions->{Output}} = decode_utf8(${$self->getOptions->{Output}})
	    unless is_utf8(${$self->getOptions->{Output}});
    }
}
sub _cutBaseURI {
    my ($self, $uriRef) = @_;
    my $baseURI = $self->getOptions->{BaseURI};
    if ($baseURI) {
	$uriRef =~ s/^$baseURI//i;
    }
    return $uriRef;
}

1;
__END__

=head1 NAME

RDF::Core::Serializer - produce XML code for RDF model

=head1 SYNOPSIS

  require RDF::Core::Serializer;

  my %options = (getSubjects => \&getSubjectsHandler,
                 getNamespaces => \&getNamespacesHandler,
                 getStatements => \&getStatementsHandler,
                 existsStatement => \&existsStatementHandler,
                 BaseURI => 'http://www.foo.com/',
                );
  my $serializer = new RDF::Core::Serializer(%options);
  $serializer->serialize;

=head1 DESCRIPTION

Serializer takes RDF data provided by handlers and generates a XML document. Besides the trivial job of generating one description for one statement the serializer attempts to group statements with common subject into one description and makes referenced descriptions nested into referencing ones. Using baseURI option helps to keep relative resources instead of making them absolute. Blank nodes are preserved where possible, though the new rdf:nodeID attribute production is not implemented yet.

=head2 Interface

=over 4

=item * new(%options)

Available options are:

=over 4

=item * getSubjects

A reference to a subroutine that provides all distinct subjects in serialized model.

=item * getNamespaces

A reference to a subroutine that provides all predicates' namespaces.

=item * getStatements($subject, $predicate, $object)

A reference to a subroutine that provides all statements conforming given mask.

=item * existsStatement($subject, $predicate, $object)

A reference to a subroutine that returns true if a statement exists conforming the mask.

=item * Output

Output can be assigned a filehandle reference (a reference to a typeglob or FileHandle object), or a reference to a scalar variable. If a filehendle is set, serializer assumes it's open and valid, just prints there and doesn't close it. If a variable is set, XML is appended to it.
Serializer writes to STDOUT with default settings.

=item * BaseURI

A base URI of a document that is created. If a subject of a statement matches the URI, about attribute with relative URI is generated. No ID attributes are produced until corresponding RDF issue is closed. (See rdfms-difference-between-ID-and-about at http://www.w3.org/2000/03/rdf-tracking/)

=item * InlineURI

Deprecated.

=item * InlinePrefix

If an anonymous description is to be generated and need is to give it ID attribute, the attribute will be InlinePrefix concatenated with unique number. Unique is ment in the scope of the document. Default prefix is 'genid'. This is wrong practice and will be replaced by rdf:nodeID usage in next versions. Warning is generated when this occurs.

=back

=item * serialize

Does the job.

=back

=head2 Handlers

B<getSubjects> should return an array of references, each reference pointing to an array of one item ($subject), where $subject is a reference to RDF::Core::Resource. (I.e. C<$subject = $returnValue-E<gt>[$someElementOfArray]-E<gt>[0]>)

B<getNamespaces> should return a hash reference where keys are namespaces and values are namespace prefixes. There must be a rdf namespace present with value 'rdf'

B<getStatements($subject, $predicate, $object)> should return all statements that match given mask. That is the statements' subject is equal to $subject or $subject is not defined and the same for predicate and subject. Return value is a reference to RDF::Core::Enumerator object.

B<getStatements($subject, $predicate, $object)> should return number of statements that match given mask.

B<existsStatement($subject, $predicate, $object)> should return true if exists statement that matches given mask and false otherwise.

=head1 LICENSE

This package is subject to the MPL (or the GPL alternatively).

=head1 AUTHOR

Ginger Alliance, [e-mail]

=head1 SEE ALSO

 FileHandle, RDF::Core::Model::Serializer, RDF::Core::Enumerator

=cut