1## This file is part of simpleserver 2## Copyright (C) 2000-2015 Index Data. 3## All rights reserved. 4## Redistribution and use in source and binary forms, with or without 5## modification, are permitted provided that the following conditions are met: 6## 7## * Redistributions of source code must retain the above copyright 8## notice, this list of conditions and the following disclaimer. 9## * Redistributions in binary form must reproduce the above copyright 10## notice, this list of conditions and the following disclaimer in the 11## documentation and/or other materials provided with the distribution. 12## * Neither the name of Index Data nor the names of its contributors 13## may be used to endorse or promote products derived from this 14## software without specific prior written permission. 15## 16## THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY 17## EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18## WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19## DISCLAIMED. IN NO EVENT SHALL THE REGENTS AND CONTRIBUTORS BE LIABLE FOR ANY 20## DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 23## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24## (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 25## THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 27package Net::Z3950::GRS1; 28 29use strict; 30use IO::Handle; 31use Carp; 32 33sub new { 34 my ($class, $href, $map) = @_; 35 my $self = {}; 36 37 $self->{ELEMENTS} = []; 38 $self->{FH} = *STDOUT; ## Default output handle is STDOUT 39 $self->{MAP} = $map; 40 bless $self, $class; 41 if (defined($href) && ref($href) eq 'HASH') { 42 if (!defined($map)) { 43 croak 'Usage: new Net::Z3950::GRS1($href, $map);'; 44 } 45 $self->Hash2grs($href, $map); 46 } 47 48 return $self; 49} 50 51 52sub Hash2grs { 53 my ($self, $href, $mapping) = @_; 54 my $key; 55 my $content; 56 my $aref; 57 my $issue; 58 59 $mapping = defined($mapping) ? $mapping : $self->{MAP}; 60 $self->{MAP} = $mapping; 61 foreach $key (keys %$href) { 62 $content = $href->{$key}; 63 next unless defined($content); 64 if (!defined($aref = $mapping->{$key})) { 65 print STDERR "Hash2grs: Unmapped key: '$key'\n"; 66 next; 67 } 68 if (ref($content) eq 'HASH') { ## Subtree? 69 my $subtree = new Net::Z3950::GRS1($content, $mapping); 70 $self->AddElement($aref->[0], $aref->[1], &Net::Z3950::GRS1::ElementData::Subtree, $subtree); 71 } elsif (!ref($content)) { ## Regular string? 72 $self->AddElement($aref->[0], $aref->[1], &Net::Z3950::GRS1::ElementData::String, $content); 73 } elsif (ref($content) eq 'ARRAY') { 74 my $issues = new Net::Z3950::GRS1; 75 foreach $issue (@$content) { 76 my $entry = new Net::Z3950::GRS1($issue, $mapping); 77 $issues->AddElement(5, 1, &Net::Z3950::GRS1::ElementData::Subtree, $entry); 78 } 79 $self->AddElement($aref->[0], $aref->[1], &Net::Z3950::GRS1::ElementData::Subtree, $issues); 80 } else { 81 print STDERR "Hash2grs: Unsupported content type\n"; 82 next; 83 } 84 } 85} 86 87 88sub GetElementList { 89 my $self = shift; 90 91 return $self->{ELEMENTS}; 92} 93 94 95sub CreateTaggedElement { 96 my ($self, $type, $value, $element_data) = @_; 97 my $tagged = {}; 98 99 $tagged->{TYPE} = $type; 100 $tagged->{VALUE} = $value; 101 $tagged->{OCCURANCE} = undef; 102 $tagged->{META} = undef; 103 $tagged->{VARIANT} = undef; 104 $tagged->{ELEMENTDATA} = $element_data; 105 106 return $tagged; 107} 108 109 110sub GetTypeValue { 111 my ($self, $TaggedElement) = @_; 112 113 return ($TaggedElement->{TYPE}, $TaggedElement->{VALUE}); 114} 115 116 117sub GetElementData { 118 my ($self, $TaggedElement) = @_; 119 120 return $TaggedElement->{ELEMENTDATA}; 121} 122 123 124sub CheckTypes { 125 my ($self, $which, $content) = @_; 126 127 if ($which == &Net::Z3950::GRS1::ElementData::String) { 128 if (ref($content) eq '') { 129 return 1; 130 } else { 131 croak "Wrong content type, expected a scalar"; 132 } 133 } elsif ($which == &Net::Z3950::GRS1::ElementData::Subtree) { 134 if (ref($content) eq __PACKAGE__) { 135 return 1; 136 } else { 137 croak "Wrong content type, expected a blessed reference"; 138 } 139 } else { 140 croak "Content type currently not supported"; 141 } 142} 143 144 145sub CreateElementData { 146 my ($self, $which, $content) = @_; 147 my $ElementData = {}; 148 149 $self->CheckTypes($which, $content); 150 $ElementData->{WHICH} = $which; 151 $ElementData->{CONTENT} = $content; 152 153 return $ElementData; 154} 155 156 157sub AddElement { 158 my ($self, $type, $value, $which, $content) = @_; 159 my $Elements = $self->GetElementList; 160 my $ElmData = $self->CreateElementData($which, $content); 161 my $TaggedElm = $self->CreateTaggedElement($type, $value, $ElmData); 162 163 push(@$Elements, $TaggedElm); 164} 165 166 167sub _Indent { 168 my ($self, $level) = @_; 169 my $space = ""; 170 171 foreach (1..$level - 1) { 172 $space .= " "; 173 } 174 175 return $space; 176} 177 178 179sub _RecordLine { 180 my ($self, $level, $pool, @args) = @_; 181 my $fh = $self->{FH}; 182 my $str = sprintf($self->_Indent($level) . shift(@args), @args); 183 184 print $fh $str; 185 if (defined($pool)) { 186 $$pool .= $str; 187 } 188} 189 190 191sub Render { 192 my $self = shift; 193 my %args = ( 194 FORMAT => &Net::Z3950::GRS1::Render::Plain, 195 FILE => '/dev/null', 196 LEVEL => 0, 197 HANDLE => undef, 198 POOL => undef, 199 @_ ); 200 my @Elements = @{$self->GetElementList}; 201 my $TaggedElement; 202 my $fh = $args{HANDLE}; 203 my $level = ++$args{LEVEL}; 204 my $ref = $args{POOL}; 205 206 if (!defined($fh) && defined($args{FILE})) { 207 open(FH, '> ' . $args{FILE}) or croak "Render: Unable to open file '$args{FILE}' for writing: $!"; 208 FH->autoflush(1); 209 $fh = *FH; 210 } 211 $self->{FH} = defined($fh) ? $fh : $self->{FH}; 212 $args{HANDLE} = $fh; 213 foreach $TaggedElement (@Elements) { 214 my ($type, $value) = $self->GetTypeValue($TaggedElement); 215 if ($self->GetElementData($TaggedElement)->{WHICH} == &Net::Z3950::GRS1::ElementData::String) { 216 $self->_RecordLine($level, $ref, "(%s,%s) %s\n", $type, $value, $self->GetElementData($TaggedElement)->{CONTENT}); 217 } elsif ($self->GetElementData($TaggedElement)->{WHICH} == &Net::Z3950::GRS1::ElementData::Subtree) { 218 $self->_RecordLine($level, $ref, "(%s,%s) {\n", $type, $value); 219 $self->GetElementData($TaggedElement)->{CONTENT}->Render(%args); 220 $self->_RecordLine($level, $ref, "}\n"); 221 } 222 } 223 if ($level == 1) { 224 $self->_RecordLine($level, $ref, "(0,0)\n"); 225 } 226} 227 228 229package Net::Z3950::GRS1::ElementData; 230 231## Define some constants according to the GRS-1 specification 232 233sub Octets { 1 } 234sub Numeric { 2 } 235sub Date { 3 } 236sub Ext { 4 } 237sub String { 5 } 238sub TrueOrFalse { 6 } 239sub OID { 7 } 240sub IntUnit { 8 } 241sub ElementNotThere { 9 } 242sub ElementEmpty { 10 } 243sub NoDataRequested { 11 } 244sub Diagnostic { 12 } 245sub Subtree { 13 } 246 247 248package Net::Z3950::GRS1::Render; 249 250## Define various types of rendering formats 251 252sub Plain { 1 } 253sub XML { 2 } 254sub Raw { 3 } 255 256 2571; 258 259__END__ 260 261 262=head1 NAME 263 264Net::Z3950::Record::GRS1 - Perl package used to encode GRS-1 records. 265 266=head1 SYNOPSIS 267 268 use Net::Z3950::GRS1; 269 270 my $a_grs1_record = new Net::Z3950::Record::GRS1; 271 my $another_grs1_record = new Net::Z3950::Record::GRS1; 272 273 $a_grs1_record->AddElement($type, $value, $content); 274 $a_grs1_record->Render(); 275 276=head1 DESCRIPTION 277 278This Perl module helps you to create and manipulate GRS-1 records (generic record syntax). 279So far, you have only access to three methods: 280 281=head2 new 282 283Creates a new GRS-1 object, 284 285 my $grs1 = new Net::Z3950::GRS1; 286 287=head2 AddElement 288 289Lets you add entries to a GRS-1 object. The method should be called this way, 290 291 $grs1->AddElement($type, $value, $which, $content); 292 293where $type should be an integer, and $value is free text. The $which argument should 294contain one of the constants listed in Appendix A. Finally, $content contains the "thing" 295that should be stored in this entry. The structure of $content should match the chosen 296element data type. For 297 298 $which == Net::Z3950::GRS1::ElementData::String; 299 300$content should be some kind of scalar. If on the other hand, 301 302 $which == Net::Z3950::GRS1::ElementData::Subtree; 303 304$content should be a GRS1 object. 305 306=head2 Render 307 308This method digs through the GRS-1 data structure and renders the record. You call it 309this way, 310 311 $grs1->Render(); 312 313If you want to access the rendered record through a variable, you can do it like this, 314 315 my $record_as_string; 316 $grs1->Render(POOL => \$record_as_string); 317 318If you want it stored in a file, Render should be called this way, 319 320 $grs1->Render(FILE => 'record.grs1'); 321 322When no file name is specified, you can choose to stream the rendered record, for instance, 323 324 $grs1->Render(HANDLE => *STDOUT); ## or 325 $grs1->Render(HANDLE => *STDERR); ## or 326 $grs1->Render(HANDLE => *MY_HANDLE); 327 328=head2 Hash2grs 329 330This method converts a hash into a GRS-1 object. Scalar entries within the hash are converted 331into GRS-1 string elements. A hash entry can itself be a reference to another hash. In this case, 332the new referenced hash will be converted into a GRS-1 subtree. The method is called this way, 333 334 $grs1->Hash2grs($href, $mapping); 335 336where $href is the hash to be converted and $mapping is referenced hash specifying the mapping 337between keys in $href and (type, value) pairs in the $grs1 object. The $mapping hash could 338for instance look like this, 339 340 my $mapping = { 341 title => [2, 1], 342 author => [1, 1], 343 issn => [3, 1] 344 }; 345 346If the $grs1 object contains data prior to the invocation of Hash2grs, the new data represented 347by the hash is simply added. 348 349 350=head1 APPENDIX A 351 352These element data types are specified in the Z39.50 protocol: 353 354 Net::Z3950::GRS1::ElementData::Octets 355 Net::Z3950::GRS1::ElementData::Numeric 356 Net::Z3950::GRS1::ElementData::Date 357 Net::Z3950::GRS1::ElementData::Ext 358 Net::Z3950::GRS1::ElementData::String <--- 359 Net::Z3950::GRS1::ElementData::TrueOrFalse 360 Net::Z3950::GRS1::ElementData::OID 361 Net::Z3950::GRS1::ElementData::IntUnit 362 Net::Z3950::GRS1::ElementData::ElementNotThere 363 Net::Z3950::GRS1::ElementData::ElementEmpty 364 Net::Z3950::GRS1::ElementData::NoDataRequested 365 Net::Z3950::GRS1::ElementData::Diagnostic 366 Net::Z3950::GRS1::ElementData::Subtree <--- 367 368Only the '<---' marked types are so far supported in this package. 369 370=head1 AUTHOR 371 372Anders S�nderberg Mortensen <sondberg@indexdata.dk> 373Index Data ApS, Copenhagen, Denmark. 3742001/03/09 375 376=head1 SEE ALSO 377 378Specification of the GRS-1 standard, for instance in the Z39.50 protocol specification. 379 380=cut 381