Include Schema information in XML Writer (#39)

gbv · Mar 19, 2018 · fec287a · fec287a
1 parent fd67d3b
commit fec287a
Show file tree

Hide file tree

Showing 2 changed files with 51 additions and 13 deletions.
diff --git a/lib/PICA/Writer/XML.pm b/lib/PICA/Writer/XML.pm
@@ -23,6 +23,7 @@ sub write_record {
     $record = $record->{record} if reftype $record eq 'HASH';
 
     my $writer = $self->{writer};
+    my $schema = $self->{schema} // { field => { } };
 
     my $i = 0;
     my $pica_sort = sub {
@@ -35,15 +36,35 @@ sub write_record {
     @$record = map $_->[1], sort { $a->[0] cmp $b->[0] } map { $pica_sort->($_) } @$record;
     $writer->startTag('record');
     foreach my $field (@$record) {
+        my $id = $field->[0];
+        my @attr = (tag => $field->[0]);
         if ( defined $field->[1] && $field->[1] ne '') {
-            $writer->startTag('datafield', tag => $field->[0], occurrence => $field->[1] );
+            push @attr, occurrence => $field->[1];
+            $id = "$id/".$field->[1];
         }
-        else {
-            $writer->startTag('datafield', tag => $field->[0]);
+        my $fielddef = $schema->{fields}{$id};
+        my $sfdef;
+        if ($fielddef) {
+            foreach (qw(label url pica3)) {
+                if (defined $fielddef->{$_}) {
+                    push @attr, $_ => $fielddef->{$_};
+                }
+            }
+            $sfdef = $fielddef->{subfields};
         }
+        $writer->startTag('datafield', @attr );
         for (my $i=2; $i<scalar @$field; $i+=2) {
+            my $code = $field->[$i];
             my $value = $field->[$i+1];
-            $writer->dataElement('subfield', $value, code => $field->[$i]);
+            my @attr = (code => $code);
+            if ($sfdef && $sfdef->{$code}) {
+                foreach (qw(label url pica3)) {
+                    if (defined $sfdef->{$code}{$_}) {
+                        push @attr, $_ => $sfdef->{$code}{$_};
+                    }
+                }
+            }
+            $writer->dataElement('subfield', $value, @attr);
         } 
         $writer->endTag('datafield');
     }
@@ -65,7 +86,11 @@ PICA::Writer::XML - PICA+ XML format serializer
 
 =head2 DESCRIPTION
 
-See L<PICA::Writer::Base> for synopsis and details.
+See L<PICA::Writer::Base> for synopsis and details. In addition a
+L<PICA::Schema> can be provided to include schema information in the XML
+records for human-readable documentation:
+
+    my $writer = PICA::Writer::XML->new( fh => $file, schema => $schema );
 
 The counterpart of this module is L<PICA::Parser::XML>.
 

diff --git a/t/30-writer.t b/t/30-writer.t
@@ -50,7 +50,7 @@ note 'PICA::Writer::Plain';
 PLAIN
 
     my $out = do { local (@ARGV,$/)=$filename; <> };
-    is $out, $PLAIN, 'Plain writer'; 
+    is $out, $PLAIN, 'Plain writer';
 
     (undef, $filename) = tempfile(OPEN => 0);
     pica_writer('plain', fh => $filename);
@@ -81,7 +81,20 @@ note 'PICA::Writer::XML';
 
 {
     my ($fh, $filename) = tempfile();
-    my $writer = PICA::Writer::XML->new( fh => $fh );
+    my $schema = {
+        fields => {
+            '003@' => {
+                label => 'PPN',
+                url => 'http://example.org/'
+            },
+            '028C/01' => {
+                subfields => {
+                    d => { pica3 => ', ' }
+                }
+            }
+        }
+    };
+    my $writer = PICA::Writer::XML->new( fh => $fh, schema => $schema );
 
     foreach my $record (@pica_records) {
         $writer->write($record);
@@ -96,7 +109,7 @@ note 'PICA::Writer::XML';
 
 <collection xmlns="info:srw/schema/5/picaXML-v1.0">
   <record>
-    <datafield tag="003@">
+    <datafield tag="003@" label="PPN" url="http://example.org/">
       <subfield code="0">1041318383</subfield>
     </datafield>
     <datafield tag="021A">
@@ -105,7 +118,7 @@ note 'PICA::Writer::XML';
   </record>
   <record>
     <datafield tag="028C" occurrence="01">
-      <subfield code="d">Emma</subfield>
+      <subfield code="d" pica3=", ">Emma</subfield>
       <subfield code="a">Goldman</subfield>
     </datafield>
   </record>
@@ -116,9 +129,9 @@ XML
 }
 
 {
-    { 
+    {
       package MyStringWriter;
-      sub print { $_[0]->{out} .= $_[1] } 
+      sub print { $_[0]->{out} .= $_[1] }
     }
 
     my $string = bless { }, 'MyStringWriter';
@@ -167,7 +180,7 @@ note 'PICA::Writer::Generic';
 
 PLUS
 
-    is $out, $PLUS, 'Generic Writer'; 
+    is $out, $PLUS, 'Generic Writer';
 }
 
 {
@@ -235,4 +248,4 @@ PLUS
     is $out, $PLUS, 'undef occ';
 }
 
-done_testing;
+done_testing;