GRS1.pm

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