GRS1.pm

   1 ## This file is part of simpleserver
   2 ## Copyright (C) 2000-2013 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
  27 package Net::Z3950::GRS1;
  28
  29 use strict;
  30 use IO::Handle;
  31 use Carp;
  32
  33 sub 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
  52 sub 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
  88 sub GetElementList {
  89         my $self = shift;
  90
  91         return $self->{ELEMENTS};
  92 }
  93
  94
  95 sub 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
 110 sub GetTypeValue {
 111         my ($self, $TaggedElement) = @_;
 112
 113         return ($TaggedElement->{TYPE}, $TaggedElement->{VALUE});
 114 }
 115
 116
 117 sub GetElementData {
 118         my ($self, $TaggedElement) = @_;
 119
 120         return $TaggedElement->{ELEMENTDATA};
 121 }
 122
 123
 124 sub 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
 145 sub 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
 157 sub 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
 167 sub _Indent {
 168         my ($self, $level) = @_;
 169         my $space = "";
 170
 171         foreach (1..$level - 1) {
 172                 $space .= "    ";
 173         }
 174
 175         return $space;
 176 }
 177
 178
 179 sub _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
 191 sub 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
 229 package Net::Z3950::GRS1::ElementData;
 230
 231 ## Define some constants according to the GRS-1 specification
 232
 233 sub Octets              { 1 }
 234 sub Numeric             { 2 }
 235 sub Date                { 3 }
 236 sub Ext                 { 4 }
 237 sub String              { 5 }
 238 sub TrueOrFalse         { 6 }
 239 sub OID                 { 7 }
 240 sub IntUnit             { 8 }
 241 sub ElementNotThere     { 9 }
 242 sub ElementEmpty        { 10 }
 243 sub NoDataRequested     { 11 }
 244 sub Diagnostic          { 12 }
 245 sub Subtree             { 13 }
 246
 247
 248 package Net::Z3950::GRS1::Render;
 249
 250 ## Define various types of rendering formats
 251
 252 sub Plain               { 1 }
 253 sub XML                 { 2 }
 254 sub Raw                 { 3 }
 255
 256
 257 1;
 258
 259 __END__
 260
 261
 262 =head1 NAME
 263
 264 Net::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
 278 This Perl module helps you to create and manipulate GRS-1 records (generic record syntax).
 279 So far, you have only access to three methods:
 280
 281 =head2 new
 282
 283 Creates a new GRS-1 object,
 284
 285   my $grs1 = new Net::Z3950::GRS1;
 286
 287 =head2 AddElement
 288
 289 Lets you add entries to a GRS-1 object. The method should be called this way,
 290
 291   $grs1->AddElement($type, $value, $which, $content);
 292
 293 where $type should be an integer, and $value is free text. The $which argument should
 294 contain one of the constants listed in Appendix A. Finally, $content contains the "thing"
 295 that should be stored in this entry. The structure of $content should match the chosen
 296 element 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
 308 This method digs through the GRS-1 data structure and renders the record. You call it
 309 this way,
 310
 311   $grs1->Render();
 312
 313 If 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
 318 If you want it stored in a file, Render should be called this way,
 319
 320   $grs1->Render(FILE => 'record.grs1');
 321
 322 When 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
 330 This method converts a hash into a GRS-1 object. Scalar entries within the hash are converted
 331 into GRS-1 string elements. A hash entry can itself be a reference to another hash. In this case,
 332 the new referenced hash will be converted into a GRS-1 subtree. The method is called this way,
 333
 334   $grs1->Hash2grs($href, $mapping);
 335
 336 where $href is the hash to be converted and $mapping is referenced hash specifying the mapping
 337 between keys in $href and (type, value) pairs in the $grs1 object. The $mapping hash could
 338 for instance look like this,
 339
 340   my $mapping = {
 341                         title   =>      [2, 1],
 342                         author  =>      [1, 1],
 343                         issn    =>      [3, 1]
 344                 };
 345
 346 If the $grs1 object contains data prior to the invocation of Hash2grs, the new data represented
 347 by the hash is simply added.
 348
 349
 350 =head1 APPENDIX A
 351
 352 These 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
 368 Only the '<---' marked types are so far supported in this package.
 369
 370 =head1 AUTHOR
 371
 372 Anders Sønderberg Mortensen <sondberg@indexdata.dk>
 373 Index Data ApS, Copenhagen, Denmark.
 374 2001/03/09
 375
 376 =head1 SEE ALSO
 377
 378 Specification of the GRS-1 standard, for instance in the Z39.50 protocol specification.
 379
 380 =cut